mlton/main/compile.fun

   1 (* Copyright (C) 2011,2014-2015,2017 Matthew Fluet.
   2  * Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
   3  *    Jagannathan, and Stephen Weeks.
   4  * Copyright (C) 1997-2000 NEC Research Institute.
   5  *
   6  * MLton is released under a BSD-style license.
   7  * See the file MLton-LICENSE for details.
   8  *)
   9
  10 functor Compile (S: COMPILE_STRUCTS): COMPILE =
  11 struct
  12
  13 open S
  14
  15 (*---------------------------------------------------*)
  16 (*              Intermediate Languages               *)
  17 (*---------------------------------------------------*)
  18
  19 structure Atoms = Atoms ()
  20 local
  21    open Atoms
  22 in
  23    structure Const = Const
  24    structure ConstType = Const.ConstType
  25    structure Ffi = Ffi
  26    structure Symbol = Symbol
  27    structure WordSize = WordSize
  28    structure WordX = WordX
  29 end
  30 structure Ast = Ast (open Atoms)
  31 structure TypeEnv = TypeEnv (open Atoms)
  32 structure CoreML = CoreML (open Atoms
  33                            structure Type =
  34                               struct
  35                                  open TypeEnv.Type
  36
  37                                  val makeHom =
  38                                     fn {con, var} =>
  39                                     makeHom {con = con,
  40                                              expandOpaque = true,
  41                                              var = var}
  42
  43                                  fun layout t =
  44                                     #1 (layoutPretty
  45                                         (t, {expandOpaque = true,
  46                                              layoutPrettyTycon = Tycon.layout,
  47                                              layoutPrettyTyvar = Tyvar.layout}))
  48                               end)
  49 structure Xml = Xml (open Atoms)
  50 structure Sxml = Sxml (open Xml)
  51 structure ParseSxml = ParseSxml(structure XmlTree = Xml)
  52 structure Ssa = Ssa (open Atoms)
  53 structure Ssa2 = Ssa2 (open Atoms)
  54 structure Machine = Machine (open Atoms
  55                              structure Label = Ssa.Label)
  56 local
  57    open Machine
  58 in
  59    structure Runtime = Runtime
  60 end
  61
  62 (*---------------------------------------------------*)
  63 (*                  Compiler Passes                  *)
  64 (*---------------------------------------------------*)
  65
  66 structure FrontEnd = FrontEnd (structure Ast = Ast)
  67 structure MLBFrontEnd = MLBFrontEnd (structure Ast = Ast
  68                                      structure FrontEnd = FrontEnd)
  69 structure DeadCode = DeadCode (structure CoreML = CoreML)
  70 structure Defunctorize = Defunctorize (structure CoreML = CoreML
  71                                        structure Xml = Xml)
  72 structure Elaborate = Elaborate (structure Ast = Ast
  73                                  structure CoreML = CoreML
  74                                  structure TypeEnv = TypeEnv)
  75 local
  76    open Elaborate
  77 in
  78    structure Env = Env
  79 end
  80 structure LookupConstant = LookupConstant (structure Const = Const
  81                                            structure ConstType = ConstType
  82                                            structure Ffi = Ffi)
  83 structure Monomorphise = Monomorphise (structure Xml = Xml
  84                                        structure Sxml = Sxml)
  85 structure ClosureConvert = ClosureConvert (structure Ssa = Ssa
  86                                            structure Sxml = Sxml)
  87 structure SsaToSsa2 = SsaToSsa2 (structure Ssa = Ssa
  88                                  structure Ssa2 = Ssa2)
  89 structure Backend = Backend (structure Ssa = Ssa2
  90                              structure Machine = Machine
  91                              fun funcToLabel f = f)
  92 structure CCodegen = CCodegen (structure Ffi = Ffi
  93                                structure Machine = Machine)
  94 structure LLVMCodegen = LLVMCodegen (structure CCodegen = CCodegen
  95                                      structure Machine = Machine)
  96 structure x86Codegen = x86Codegen (structure CCodegen = CCodegen
  97                                    structure Machine = Machine)
  98 structure amd64Codegen = amd64Codegen (structure CCodegen = CCodegen
  99                                        structure Machine = Machine)
 100
 101
 102 (* ------------------------------------------------- *)
 103 (*                 Lookup Constant                   *)
 104 (* ------------------------------------------------- *)
 105
 106 val commandLineConstants: {name: string, value: string} list ref = ref []
 107 fun setCommandLineConstant (c as {name, value}) =
 108    let
 109       fun make (fromString, control) =
 110          let
 111             fun set () =
 112                case fromString value of
 113                   NONE => Error.bug (concat ["bad value for ", name])
 114                 | SOME v => control := v
 115          in
 116             set
 117          end
 118       val () =
 119          case List.peek ([("Exn.keepHistory",
 120                            make (Bool.fromString, Control.exnHistory))],
 121                          fn (s, _) => s = name) of
 122             NONE => ()
 123           | SOME (_,set) => set ()
 124    in
 125       List.push (commandLineConstants, c)
 126    end
 127
 128 val allConstants: (string * ConstType.t) list ref = ref []
 129 val amBuildingConstants: bool ref = ref false
 130
 131 val lookupConstant =
 132    let
 133       val zero = Const.word (WordX.fromIntInf (0, WordSize.word32))
 134       val f =
 135          Promise.lazy
 136          (fn () =>
 137           if !amBuildingConstants
 138              then (fn ({name, default, ...}, t) =>
 139                    let
 140                       (* Don't keep constants that already have a default value.
 141                        * These are defined by _command_line_const and set by
 142                        * -const, and shouldn't be looked up.
 143                        *)
 144                       val () =
 145                          if isSome default
 146                             then ()
 147                          else List.push (allConstants, (name, t))
 148                    in
 149                       zero
 150                    end)
 151           else
 152              File.withIn
 153              (concat [!Control.libTargetDir, "/constants"], fn ins =>
 154               LookupConstant.load (ins, !commandLineConstants)))
 155    in
 156       fn z => f () z
 157    end
 158
 159 (* ------------------------------------------------- *)
 160 (*                   Primitive Env                   *)
 161 (* ------------------------------------------------- *)
 162
 163 local
 164    structure Con = TypeEnv.Con
 165    structure Tycon = TypeEnv.Tycon
 166    structure Type = TypeEnv.Type
 167    structure Tyvar =
 168       struct
 169          open TypeEnv.Tyvar
 170          open TypeEnv.TyvarExt
 171       end
 172
 173    val primitiveDatatypes =
 174       Vector.new3
 175       ({tycon = Tycon.bool,
 176         tyvars = Vector.new0 (),
 177         cons = Vector.new2 ({con = Con.falsee, arg = NONE},
 178                             {con = Con.truee, arg = NONE})},
 179        let
 180           val a = Tyvar.makeNoname {equality = false}
 181        in
 182           {tycon = Tycon.list,
 183            tyvars = Vector.new1 a,
 184            cons = Vector.new2 ({con = Con.nill, arg = NONE},
 185                                {con = Con.cons,
 186                                 arg = SOME (Type.tuple
 187                                             (Vector.new2
 188                                              (Type.var a,
 189                                               Type.list (Type.var a))))})}
 190        end,
 191        let
 192           val a = Tyvar.makeNoname {equality = false}
 193        in
 194           {tycon = Tycon.reff,
 195            tyvars = Vector.new1 a,
 196            cons = Vector.new1 {con = Con.reff, arg = SOME (Type.var a)}}
 197        end)
 198
 199    val primitiveExcons =
 200       let
 201          open CoreML.Con
 202       in
 203          [bind, match, overflow]
 204       end
 205
 206    structure Con =
 207       struct
 208          open Con
 209
 210          fun toAst c =
 211             Ast.Con.fromSymbol (Symbol.fromString (Con.toString c),
 212                                 Region.bogus)
 213       end
 214
 215    structure Env =
 216       struct
 217          open Env
 218
 219          structure Tycon =
 220             struct
 221                open Tycon
 222
 223                fun toAst c =
 224                   Ast.Tycon.fromSymbol (Symbol.fromString (Tycon.toString c),
 225                                         Region.bogus)
 226             end
 227          structure Type = TypeEnv.Type
 228          structure Scheme = TypeEnv.Scheme
 229
 230          fun addPrim (E: t): unit =
 231             let
 232                val _ =
 233                   List.foreach
 234                   (Tycon.prims, fn {name, tycon, ...} =>
 235                    if List.contains ([Tycon.arrow, Tycon.tuple], tycon, Tycon.equals)
 236                       then ()
 237                       else extendTycon
 238                            (E, Ast.Tycon.fromSymbol (Symbol.fromString name,
 239                                                      Region.bogus),
 240                             TypeStr.tycon tycon,
 241                             {forceUsed = false, isRebind = false}))
 242                val _ =
 243                   Vector.foreach
 244                   (primitiveDatatypes, fn {tyvars, tycon, cons} =>
 245                    let
 246                       val cons =
 247                          Vector.map
 248                          (cons, fn {con, arg} =>
 249                           let
 250                              val res =
 251                                 Type.con (tycon, Vector.map (tyvars, Type.var))
 252                              val ty =
 253                                 case arg of
 254                                    NONE => res
 255                                  | SOME arg => Type.arrow (arg, res)
 256                              val scheme =
 257                                 Scheme.make
 258                                 {canGeneralize = true,
 259                                  ty = ty,
 260                                  tyvars = tyvars}
 261                           in
 262                              {con = con,
 263                               name = Con.toAst con,
 264                               scheme = scheme}
 265                           end)
 266                       val cons = Env.newCons (E, cons)
 267                    in
 268                       extendTycon
 269                       (E, Tycon.toAst tycon,
 270                        TypeStr.data (tycon, cons),
 271                        {forceUsed = false, isRebind = false})
 272                    end)
 273                val _ =
 274                   extendTycon (E,
 275                                Ast.Tycon.fromSymbol (Symbol.unit, Region.bogus),
 276                                TypeStr.def (Scheme.fromType Type.unit),
 277                                {forceUsed = false, isRebind = false})
 278                val scheme = Scheme.fromType Type.exn
 279                val _ = List.foreach (primitiveExcons, fn c =>
 280                                      extendExn (E, Con.toAst c, c, scheme))
 281             in
 282                ()
 283             end
 284       end
 285
 286    val primitiveDecs: CoreML.Dec.t list =
 287       let
 288          open CoreML.Dec
 289       in
 290          List.concat [[Datatype primitiveDatatypes],
 291                       List.map
 292                       (primitiveExcons, fn c =>
 293                        Exception {con = c, arg = NONE})]
 294       end
 295
 296 in
 297
 298    fun addPrim E =
 299       (Env.addPrim E
 300        ; primitiveDecs)
 301 end
 302
 303
 304 (* ------------------------------------------------- *)
 305 (*                 parseAndElaborateMLB              *)
 306 (* ------------------------------------------------- *)
 307
 308 fun quoteFile s = concat ["\"", String.escapeSML s, "\""]
 309
 310 structure MLBString:>
 311    sig
 312       type t
 313
 314       val fromFile: File.t -> t
 315       val fromString: string -> t
 316       val lexAndParseMLB: t -> Ast.Basdec.t
 317    end =
 318    struct
 319       type t = string
 320
 321       val fromFile = quoteFile
 322
 323       val fromString = fn s => s
 324
 325       val lexAndParseMLB = MLBFrontEnd.lexAndParseString
 326    end
 327
 328 val lexAndParseMLB = MLBString.lexAndParseMLB
 329
 330 val lexAndParseMLB: MLBString.t -> Ast.Basdec.t =
 331    fn input =>
 332    let
 333       val ast = lexAndParseMLB input
 334       val _ = Control.checkForErrors "parse"
 335    in
 336       ast
 337    end
 338
 339 fun sourceFilesMLB {input} =
 340    Ast.Basdec.sourceFiles (lexAndParseMLB (MLBString.fromFile input))
 341
 342 val elaborateMLB = Elaborate.elaborateMLB
 343
 344 val displayEnvDecs =
 345    Control.Layouts
 346    (fn ((_, decs),output) =>
 347     (output (Layout.str "\n\n")
 348      ; Vector.foreach
 349        (decs, fn (dec, dc) =>
 350         (output o Layout.record)
 351         [("deadCode", Bool.layout dc),
 352          ("decs", List.layout CoreML.Dec.layout dec)])))
 353
 354 fun parseAndElaborateMLB (input: MLBString.t)
 355    : Env.t * (CoreML.Dec.t list * bool) vector =
 356    Control.pass
 357    {display = displayEnvDecs,
 358     name = "parseAndElaborate",
 359     stats = fn _ => Layout.empty,
 360     style = Control.ML,
 361     suffix = "core-ml",
 362     thunk = (fn () =>
 363              (if !Control.keepAST
 364                  then File.remove (concat [!Control.inputFile, ".ast"])
 365                  else ()
 366               ; Const.lookup := lookupConstant
 367               ; elaborateMLB (lexAndParseMLB input, {addPrim = addPrim})))}
 368
 369 (* ------------------------------------------------- *)
 370 (*                   Basis Library                   *)
 371 (* ------------------------------------------------- *)
 372
 373 fun outputBasisConstants (out: Out.t): unit =
 374    let
 375       val _ = amBuildingConstants := true
 376       val (_, decs) =
 377          parseAndElaborateMLB (MLBString.fromFile "$(SML_LIB)/basis/primitive/primitive.mlb")
 378       val decs = Vector.concatV (Vector.map (decs, Vector.fromList o #1))
 379       (* Need to defunctorize so the constants are forced. *)
 380       val _ = Defunctorize.defunctorize (CoreML.Program.T {decs = decs})
 381       val _ = LookupConstant.build (!allConstants, out)
 382    in
 383       ()
 384    end
 385
 386 (* ------------------------------------------------- *)
 387 (*                      compile                      *)
 388 (* ------------------------------------------------- *)
 389
 390 exception Done
 391
 392 fun elaborate {input: MLBString.t}: Xml.Program.t =
 393    let
 394       val (E, decs) = parseAndElaborateMLB input
 395       val _ =
 396          case !Control.showBasis of
 397             NONE => ()
 398           | SOME f =>
 399                File.withOut
 400                (f, fn out =>
 401                 Env.output
 402                 (E, out,
 403                  {compact = !Control.showBasisCompact,
 404                   def = !Control.showBasisDef,
 405                   flat = !Control.showBasisFlat,
 406                   onlyCurrent = false,
 407                   prefixUnset = true}))
 408       val _ = Env.processDefUse E
 409       val _ =
 410          case !Control.exportHeader of
 411             NONE => ()
 412           | SOME f =>
 413                File.withOut
 414                (f, fn out =>
 415                 let
 416                    fun print s = Out.output (out, s)
 417                    val libname = !Control.libname
 418                    val libcap = CharVector.map Char.toUpper libname
 419                    val _ = print ("#ifndef __" ^ libcap ^ "_ML_H__\n")
 420                    val _ = print ("#define __" ^ libcap ^ "_ML_H__\n")
 421                    val _ = print "\n"
 422                    val _ =
 423                       File.outputContents
 424                       (concat [!Control.libDir, "/include/ml-types.h"], out)
 425                    val _ = print "\n"
 426                    val _ =
 427                       File.outputContents
 428                       (concat [!Control.libDir, "/include/export.h"], out)
 429                    val _ = print "\n"
 430                    (* How do programs link against this library by default *)
 431                    val defaultLinkage =
 432                       case !Control.format of
 433                          Control.Archive    => "STATIC_LINK"
 434                        | Control.Executable => "PART_OF"
 435                        | Control.LibArchive => "NO_DEFAULT_LINK"
 436                        | Control.Library    => "DYNAMIC_LINK"
 437                    val _ =
 438                       print ("#if !defined(PART_OF_"      ^ libcap ^ ") && \\\n\
 439                              \    !defined(STATIC_LINK_"  ^ libcap ^ ") && \\\n\
 440                              \    !defined(DYNAMIC_LINK_" ^ libcap ^ ")\n")
 441                    val _ =
 442                       print ("#define " ^ defaultLinkage ^ "_" ^ libcap ^ "\n")
 443                    val _ = print "#endif\n"
 444                    val _ = print "\n"
 445                    val _ = print ("#if defined(PART_OF_" ^ libcap ^ ")\n")
 446                    val _ = print "#define MLLIB_PRIVATE(x) PRIVATE x\n"
 447                    val _ = print "#define MLLIB_PUBLIC(x) PUBLIC x\n"
 448                    val _ = print ("#elif defined(STATIC_LINK_" ^ libcap ^ ")\n")
 449                    val _ = print "#define MLLIB_PRIVATE(x)\n"
 450                    val _ = print "#define MLLIB_PUBLIC(x) PUBLIC x\n"
 451                    val _ = print ("#elif defined(DYNAMIC_LINK_" ^ libcap ^ ")\n")
 452                    val _ = print "#define MLLIB_PRIVATE(x)\n"
 453                    val _ = print "#define MLLIB_PUBLIC(x) EXTERNAL x\n"
 454                    val _ = print "#else\n"
 455                    val _ = print ("#error Must specify linkage for " ^ libname ^ "\n")
 456                    val _ = print "#define MLLIB_PRIVATE(x)\n"
 457                    val _ = print "#define MLLIB_PUBLIC(x)\n"
 458                    val _ = print "#endif\n"
 459                    val _ = print "\n"
 460                    val _ = print "#ifdef __cplusplus\n"
 461                    val _ = print "extern \"C\" {\n"
 462                    val _ = print "#endif\n"
 463                    val _ = print "\n"
 464                    val _ =
 465                       if !Control.format = Control.Executable then () else
 466                           (print ("MLLIB_PUBLIC(void " ^ libname ^ "_open(int argc, const char** argv);)\n")
 467                           ;print ("MLLIB_PUBLIC(void " ^ libname ^ "_close();)\n"))
 468                    val _ = Ffi.declareHeaders {print = print}
 469                    val _ = print "\n"
 470                    val _ = print "#undef MLLIB_PRIVATE\n"
 471                    val _ = print "#undef MLLIB_PUBLIC\n"
 472                    val _ = print "\n"
 473                    val _ = print "#ifdef __cplusplus\n"
 474                    val _ = print "}\n"
 475                    val _ = print "#endif\n"
 476                    val _ = print "\n"
 477                    val _ = print ("#endif /* __" ^ libcap ^ "_ML_H__ */\n")
 478                 in
 479                    ()
 480                 end)
 481       val _ = if !Control.elaborateOnly then raise Done else ()
 482       val decs =
 483          Control.pass
 484          {display = Control.Layouts (fn (decss,output) =>
 485                                      (output (Layout.str "\n\n")
 486                                       ; Vector.foreach (decss, fn decs =>
 487                                         List.foreach (decs, fn dec =>
 488                                         output (CoreML.Dec.layout dec))))),
 489           name = "deadCode",
 490           suffix = "core-ml",
 491           style = Control.ML,
 492           stats = fn _ => Layout.empty,
 493           thunk = fn () => let
 494                               val {prog = decs} =
 495                                  DeadCode.deadCode {prog = decs}
 496                            in
 497                               decs
 498                            end}
 499       val decs = Vector.concatV (Vector.map (decs, Vector.fromList))
 500       val coreML = CoreML.Program.T {decs = decs}
 501       val _ =
 502          let
 503             open Control
 504          in
 505             if !keepCoreML
 506                then saveToFile ({suffix = "core-ml"}, No, coreML,
 507                                 Layouts CoreML.Program.layouts)
 508             else ()
 509          end
 510
 511
 512       val xml =
 513          Control.passTypeCheck
 514          {display = Control.Layouts Xml.Program.layouts,
 515           name = "defunctorize",
 516           stats = Xml.Program.layoutStats,
 517           style = Control.ML,
 518           suffix = "xml",
 519           thunk = fn () => Defunctorize.defunctorize coreML,
 520           typeCheck = Xml.typeCheck}
 521    in
 522       xml
 523    end
 524
 525 fun simplifyXml xml =
 526    let val xml =
 527       Control.passTypeCheck
 528       {display = Control.Layouts Xml.Program.layouts,
 529        name = "xmlSimplify",
 530        stats = Xml.Program.layoutStats,
 531        style = Control.ML,
 532        suffix = "xml",
 533        thunk = fn () => Xml.simplify xml,
 534        typeCheck = Xml.typeCheck}
 535       open Control
 536       val _ =
 537          if !keepXML
 538             then saveToFile ({suffix = "xml"}, No, xml,
 539                Layouts Xml.Program.layouts)
 540             else ()
 541    in
 542       xml
 543    end
 544
 545 fun makeSxml xml =
 546    Control.passTypeCheck
 547    {display = Control.Layouts Sxml.Program.layouts,
 548     name = "monomorphise",
 549     stats = Sxml.Program.layoutStats,
 550     style = Control.ML,
 551     suffix = "sxml",
 552     thunk = fn () => Monomorphise.monomorphise xml,
 553     typeCheck = Sxml.typeCheck}
 554
 555 fun simplifySxml sxml =
 556    let
 557       val sxml =
 558          Control.passTypeCheck
 559          {display = Control.Layouts Sxml.Program.layouts,
 560           name = "sxmlSimplify",
 561           stats = Sxml.Program.layoutStats,
 562           style = Control.ML,
 563           suffix = "sxml",
 564           thunk = fn () => Sxml.simplify sxml,
 565           typeCheck = Sxml.typeCheck}
 566       open Control
 567       val _ =
 568          if !keepSXML
 569             then saveToFile ({suffix = "sxml"}, No, sxml,
 570                Layouts Sxml.Program.layouts)
 571             else ()
 572    in
 573       sxml
 574    end
 575
 576 fun makeSsa sxml =
 577    Control.passTypeCheck
 578    {display = Control.Layouts Ssa.Program.layouts,
 579     name = "closureConvert",
 580     stats = Ssa.Program.layoutStats,
 581     style = Control.No,
 582     suffix = "ssa",
 583     thunk = fn () => ClosureConvert.closureConvert sxml,
 584     typeCheck = Ssa.typeCheck}
 585
 586 fun simplifySsa ssa =
 587    let
 588       val ssa =
 589          Control.passTypeCheck
 590          {display = Control.Layouts Ssa.Program.layouts,
 591           name = "ssaSimplify",
 592           stats = Ssa.Program.layoutStats,
 593           style = Control.No,
 594           suffix = "ssa",
 595           thunk = fn () => Ssa.simplify ssa,
 596           typeCheck = Ssa.typeCheck}
 597       open Control
 598       val _ =
 599          if !keepSSA
 600             then saveToFile ({suffix = "ssa"}, No, ssa,
 601                Layouts Ssa.Program.layouts)
 602          else ()
 603    in
 604       ssa
 605    end
 606
 607 fun makeSsa2 ssa =
 608    Control.passTypeCheck
 609    {display = Control.Layouts Ssa2.Program.layouts,
 610     name = "toSsa2",
 611     stats = Ssa2.Program.layoutStats,
 612     style = Control.No,
 613     suffix = "ssa2",
 614     thunk = fn () => SsaToSsa2.convert ssa,
 615     typeCheck = Ssa2.typeCheck}
 616
 617 fun simplifySsa2 ssa2 =
 618    let
 619       val ssa2 =
 620          Control.passTypeCheck
 621          {display = Control.Layouts Ssa2.Program.layouts,
 622           name = "ssa2Simplify",
 623           stats = Ssa2.Program.layoutStats,
 624           style = Control.No,
 625           suffix = "ssa2",
 626           thunk = fn () => Ssa2.simplify ssa2,
 627           typeCheck = Ssa2.typeCheck}
 628       open Control
 629       val _ =
 630          if !keepSSA2
 631             then saveToFile ({suffix = "ssa2"}, No, ssa2,
 632                Layouts Ssa2.Program.layouts)
 633          else ()
 634    in
 635       ssa2
 636    end
 637
 638 fun makeMachine ssa2 =
 639    let
 640       val codegenImplementsPrim =
 641          case !Control.codegen of
 642             Control.AMD64Codegen => amd64Codegen.implementsPrim
 643           | Control.CCodegen => CCodegen.implementsPrim
 644           | Control.LLVMCodegen => LLVMCodegen.implementsPrim
 645           | Control.X86Codegen => x86Codegen.implementsPrim
 646       val machine =
 647          Control.passTypeCheck
 648          {display = Control.Layouts Machine.Program.layouts,
 649           name = "backend",
 650           stats = fn _ => Layout.empty,
 651           style = Control.No,
 652           suffix = "machine",
 653           thunk = fn () =>
 654                   (Backend.toMachine
 655                    (ssa2,
 656                     {codegenImplementsPrim = codegenImplementsPrim})),
 657           typeCheck = fn machine =>
 658                       (* For now, machine type check is too slow to run. *)
 659                       (if !Control.typeCheck
 660                           then Machine.Program.typeCheck machine
 661                        else ())}
 662       val _ =
 663          let
 664             open Control
 665          in
 666             if !keepMachine
 667                then saveToFile ({suffix = "machine"}, No, machine,
 668                                 Layouts Machine.Program.layouts)
 669             else ()
 670          end
 671    in
 672       machine
 673    end
 674
 675 fun setupConstants() : unit =
 676    (* Set GC_state offsets and sizes. *)
 677    let
 678       val _ =
 679          let
 680             fun get (name: string): Bytes.t =
 681                case lookupConstant ({default = NONE, name = name},
 682                                     ConstType.Word WordSize.word32) of
 683                   Const.Word w => Bytes.fromInt (WordX.toInt w)
 684                 | _ => Error.bug "Compile.setupConstants: GC_state offset must be an int"
 685          in
 686             Runtime.GCField.setOffsets
 687             {
 688              atomicState = get "atomicState_Offset",
 689              cardMapAbsolute = get "generationalMaps.cardMapAbsolute_Offset",
 690              currentThread = get "currentThread_Offset",
 691              curSourceSeqsIndex = get "sourceMaps.curSourceSeqsIndex_Offset",
 692              exnStack = get "exnStack_Offset",
 693              frontier = get "frontier_Offset",
 694              limit = get "limit_Offset",
 695              limitPlusSlop = get "limitPlusSlop_Offset",
 696              maxFrameSize = get "maxFrameSize_Offset",
 697              signalIsPending = get "signalsInfo.signalIsPending_Offset",
 698              stackBottom = get "stackBottom_Offset",
 699              stackLimit = get "stackLimit_Offset",
 700              stackTop = get "stackTop_Offset"
 701              };
 702             Runtime.GCField.setSizes
 703             {
 704              atomicState = get "atomicState_Size",
 705              cardMapAbsolute = get "generationalMaps.cardMapAbsolute_Size",
 706              currentThread = get "currentThread_Size",
 707              curSourceSeqsIndex = get "sourceMaps.curSourceSeqsIndex_Size",
 708              exnStack = get "exnStack_Size",
 709              frontier = get "frontier_Size",
 710              limit = get "limit_Size",
 711              limitPlusSlop = get "limitPlusSlop_Size",
 712              maxFrameSize = get "maxFrameSize_Size",
 713              signalIsPending = get "signalsInfo.signalIsPending_Size",
 714              stackBottom = get "stackBottom_Size",
 715              stackLimit = get "stackLimit_Size",
 716              stackTop = get "stackTop_Size"
 717              }
 718          end
 719       (* Setup endianness *)
 720       val _ =
 721          let
 722             fun get (name:string): bool =
 723                 case lookupConstant ({default = NONE, name = name},
 724                                      ConstType.Bool) of
 725                    Const.Word w => 1 = WordX.toInt w
 726                  | _ => Error.bug "Compile.setupConstants: endian unknown"
 727          in
 728             Control.Target.setBigEndian (get "MLton_Platform_Arch_bigendian")
 729          end
 730    in
 731       ()
 732    end
 733
 734
 735 fun preCodegen (input: MLBString.t): Machine.Program.t =
 736    let
 737       val xml = elaborate {input = input}
 738       val _ = setupConstants ()
 739       val xml = simplifyXml xml
 740       val sxml = makeSxml xml
 741       val sxml = simplifySxml sxml
 742       val ssa = makeSsa sxml
 743       val ssa = simplifySsa ssa
 744       val ssa2 = makeSsa2 ssa
 745       val ssa2 = simplifySsa2 ssa2
 746    in
 747       makeMachine ssa2
 748    end
 749
 750 fun compile {input: 'a, resolve: 'a -> Machine.Program.t, outputC, outputLL, outputS}: unit =
 751    let
 752       val machine =
 753          Control.trace (Control.Top, "pre codegen")
 754          resolve input
 755       fun clearNames () =
 756          (Machine.Program.clearLabelNames machine
 757           ; Machine.Label.printNameAlphaNumeric := true)
 758       val () =
 759          case !Control.codegen of
 760             Control.AMD64Codegen =>
 761                (clearNames ()
 762                 ; (Control.trace (Control.Top, "amd64 code gen")
 763                    amd64Codegen.output {program = machine,
 764                                         outputC = outputC,
 765                                         outputS = outputS}))
 766           | Control.CCodegen =>
 767                (clearNames ()
 768                 ; (Control.trace (Control.Top, "C code gen")
 769                    CCodegen.output {program = machine,
 770                                     outputC = outputC}))
 771           | Control.LLVMCodegen =>
 772                (clearNames ()
 773                 ; (Control.trace (Control.Top, "llvm code gen")
 774                    LLVMCodegen.output {program = machine,
 775                                        outputC = outputC,
 776                                       outputLL = outputLL}))
 777           | Control.X86Codegen =>
 778                (clearNames ()
 779                 ; (Control.trace (Control.Top, "x86 code gen")
 780                    x86Codegen.output {program = machine,
 781                                       outputC = outputC,
 782                                       outputS = outputS}))
 783       val _ = Control.message (Control.Detail, PropertyList.stats)
 784       val _ = Control.message (Control.Detail, HashSet.stats)
 785    in
 786       ()
 787    end handle Done => ()
 788
 789 fun compileMLB {input: File.t, outputC, outputLL, outputS}: unit =
 790    compile {input = MLBString.fromFile input,
 791             resolve = preCodegen,
 792             outputC = outputC,
 793             outputLL = outputLL,
 794             outputS = outputS}
 795
 796 val elaborateMLB =
 797    fn {input: File.t} =>
 798    (ignore (elaborate {input = MLBString.fromFile input}))
 799    handle Done => ()
 800
 801 local
 802    fun genMLB {input: File.t list}: MLBString.t =
 803       let
 804          val basis = "$(SML_LIB)/basis/default.mlb"
 805       in
 806          MLBString.fromString
 807          (case input of
 808              [] => basis
 809            | _ =>
 810                 let
 811                    val input = List.map (input, quoteFile)
 812                 in
 813                    String.concat
 814                    ["local\n",
 815                     basis, "\n",
 816                     "in\n",
 817                     String.concat (List.separate (input, "\n")), "\n",
 818                     "end\n"]
 819                 end)
 820       end
 821 in
 822    fun compileSML {input: File.t list, outputC, outputLL, outputS}: unit =
 823       compile {input = genMLB {input = input},
 824                resolve = preCodegen,
 825                outputC = outputC,
 826                outputLL = outputLL,
 827                outputS = outputS}
 828    val elaborateSML =
 829       fn {input: File.t list} =>
 830       (ignore (elaborate {input = genMLB {input = input}}))
 831       handle Done => ()
 832 end
 833
 834 fun genFromSXML (input: File.t): Machine.Program.t =
 835    let
 836       val _ = setupConstants()
 837       val sxml =
 838          Control.passTypeCheck
 839          {display = Control.Layouts Sxml.Program.layouts,
 840           name = "sxmlParse",
 841           stats = Sxml.Program.layoutStats,
 842           style = Control.ML,
 843           suffix = "sxml",
 844           thunk = (fn () => case
 845                      Parse.parseFile(ParseSxml.program, input)
 846                         of Result.Yes x => x
 847                          | Result.No msg => (Control.error
 848                            (Region.bogus, Layout.str "Sxml Parse failed", Layout.str msg);
 849                             Control.checkForErrors("parse");
 850                             (* can't be reached *)
 851                             raise Fail "parse")
 852                    ),
 853           typeCheck = Sxml.typeCheck}
 854       val sxml = simplifySxml sxml
 855       val ssa = makeSsa sxml
 856       val ssa = simplifySsa ssa
 857       val ssa2 = makeSsa2 ssa
 858       val ssa2 = simplifySsa2 ssa2
 859    in
 860       makeMachine ssa2
 861    end
 862 fun compileSXML {input: File.t, outputC, outputLL, outputS}: unit =
 863    compile {input = input,
 864             resolve = genFromSXML,
 865             outputC = outputC,
 866             outputLL = outputLL,
 867             outputS = outputS}
 868
 869 end