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.
6 * MLton is released under a BSD-style license.
7 * See the file MLton-LICENSE for details.
10 functor Compile (S: COMPILE_STRUCTS): COMPILE =
15 (*---------------------------------------------------*)
16 (* Intermediate Languages *)
17 (*---------------------------------------------------*)
19 structure Atoms = Atoms ()
23 structure Const = Const
24 structure ConstType = Const.ConstType
26 structure Symbol = Symbol
27 structure WordSize = WordSize
28 structure WordX = WordX
30 structure Ast = Ast (open Atoms)
31 structure TypeEnv = TypeEnv (open Atoms)
32 structure CoreML = CoreML (open Atoms
45 (t, {expandOpaque = true,
46 layoutPrettyTycon = Tycon.layout,
47 layoutPrettyTyvar = Tyvar.layout}))
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)
59 structure Runtime = Runtime
62 (*---------------------------------------------------*)
64 (*---------------------------------------------------*)
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
72 structure Elaborate = Elaborate (structure Ast = Ast
73 structure CoreML = CoreML
74 structure TypeEnv = TypeEnv)
80 structure LookupConstant = LookupConstant (structure Const = Const
81 structure ConstType = ConstType
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)
102 (* ------------------------------------------------- *)
103 (* Lookup Constant *)
104 (* ------------------------------------------------- *)
106 val commandLineConstants: {name: string, value: string} list ref = ref []
107 fun setCommandLineConstant (c as {name, value}) =
109 fun make (fromString, control) =
112 case fromString value of
113 NONE => Error.bug (concat ["bad value for ", name])
114 | SOME v => control := v
119 case List.peek ([("Exn.keepHistory",
120 make (Bool.fromString, Control.exnHistory))],
121 fn (s, _) => s = name) of
123 | SOME (_,set) => set ()
125 List.push (commandLineConstants, c)
128 val allConstants: (string * ConstType.t) list ref = ref []
129 val amBuildingConstants: bool ref = ref false
133 val zero = Const.word (WordX.fromIntInf (0, WordSize.word32))
137 if !amBuildingConstants
138 then (fn ({name, default, ...}, t) =>
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.
147 else List.push (allConstants, (name, t))
153 (concat [!Control.libTargetDir, "/constants"], fn ins =>
154 LookupConstant.load (ins, !commandLineConstants)))
159 (* ------------------------------------------------- *)
161 (* ------------------------------------------------- *)
164 structure Con = TypeEnv.Con
165 structure Tycon = TypeEnv.Tycon
166 structure Type = TypeEnv.Type
170 open TypeEnv.TyvarExt
173 val primitiveDatatypes =
175 ({tycon = Tycon.bool,
176 tyvars = Vector.new0 (),
177 cons = Vector.new2 ({con = Con.falsee, arg = NONE},
178 {con = Con.truee, arg = NONE})},
180 val a = Tyvar.makeNoname {equality = false}
183 tyvars = Vector.new1 a,
184 cons = Vector.new2 ({con = Con.nill, arg = NONE},
186 arg = SOME (Type.tuple
189 Type.list (Type.var a))))})}
192 val a = Tyvar.makeNoname {equality = false}
195 tyvars = Vector.new1 a,
196 cons = Vector.new1 {con = Con.reff, arg = SOME (Type.var a)}}
199 val primitiveExcons =
203 [bind, match, overflow]
211 Ast.Con.fromSymbol (Symbol.fromString (Con.toString c),
224 Ast.Tycon.fromSymbol (Symbol.fromString (Tycon.toString c),
227 structure Type = TypeEnv.Type
228 structure Scheme = TypeEnv.Scheme
230 fun addPrim (E: t): unit =
234 (Tycon.prims, fn {name, tycon, ...} =>
235 if List.contains ([Tycon.arrow, Tycon.tuple], tycon, Tycon.equals)
238 (E, Ast.Tycon.fromSymbol (Symbol.fromString name,
241 {forceUsed = false, isRebind = false}))
244 (primitiveDatatypes, fn {tyvars, tycon, cons} =>
248 (cons, fn {con, arg} =>
251 Type.con (tycon, Vector.map (tyvars, Type.var))
255 | SOME arg => Type.arrow (arg, res)
258 {canGeneralize = true,
263 name = Con.toAst con,
266 val cons = Env.newCons (E, cons)
269 (E, Tycon.toAst tycon,
270 TypeStr.data (tycon, cons),
271 {forceUsed = false, isRebind = false})
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))
286 val primitiveDecs: CoreML.Dec.t list =
290 List.concat [[Datatype primitiveDatatypes],
292 (primitiveExcons, fn c =>
293 Exception {con = c, arg = NONE})]
304 (* ------------------------------------------------- *)
305 (* parseAndElaborateMLB *)
306 (* ------------------------------------------------- *)
308 fun quoteFile s = concat ["\"", String.escapeSML s, "\""]
310 structure MLBString:>
314 val fromFile: File.t -> t
315 val fromString: string -> t
316 val lexAndParseMLB: t -> Ast.Basdec.t
321 val fromFile = quoteFile
323 val fromString = fn s => s
325 val lexAndParseMLB = MLBFrontEnd.lexAndParseString
328 val lexAndParseMLB = MLBString.lexAndParseMLB
330 val lexAndParseMLB: MLBString.t -> Ast.Basdec.t =
333 val ast = lexAndParseMLB input
334 val _ = Control.checkForErrors "parse"
339 fun sourceFilesMLB {input} =
340 Ast.Basdec.sourceFiles (lexAndParseMLB (MLBString.fromFile input))
342 val elaborateMLB = Elaborate.elaborateMLB
346 (fn ((_, decs),output) =>
347 (output (Layout.str "\n\n")
349 (decs, fn (dec, dc) =>
350 (output o Layout.record)
351 [("deadCode", Bool.layout dc),
352 ("decs", List.layout CoreML.Dec.layout dec)])))
354 fun parseAndElaborateMLB (input: MLBString.t)
355 : Env.t * (CoreML.Dec.t list * bool) vector =
357 {display = displayEnvDecs,
358 name = "parseAndElaborate",
359 stats = fn _ => Layout.empty,
364 then File.remove (concat [!Control.inputFile, ".ast"])
366 ; Const.lookup := lookupConstant
367 ; elaborateMLB (lexAndParseMLB input, {addPrim = addPrim})))}
369 (* ------------------------------------------------- *)
371 (* ------------------------------------------------- *)
373 fun outputBasisConstants (out: Out.t): unit =
375 val _ = amBuildingConstants := true
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)
386 (* ------------------------------------------------- *)
388 (* ------------------------------------------------- *)
392 fun elaborate {input: MLBString.t}: Xml.Program.t =
394 val (E, decs) = parseAndElaborateMLB input
396 case !Control.showBasis of
403 {compact = !Control.showBasisCompact,
404 def = !Control.showBasisDef,
405 flat = !Control.showBasisFlat,
407 prefixUnset = true}))
408 val _ = Env.processDefUse E
410 case !Control.exportHeader of
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")
424 (concat [!Control.libDir, "/include/ml-types.h"], out)
428 (concat [!Control.libDir, "/include/export.h"], out)
430 (* How do programs link against this library by default *)
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"
438 print ("#if !defined(PART_OF_" ^ libcap ^ ") && \\\n\
439 \ !defined(STATIC_LINK_" ^ libcap ^ ") && \\\n\
440 \ !defined(DYNAMIC_LINK_" ^ libcap ^ ")\n")
442 print ("#define " ^ defaultLinkage ^ "_" ^ libcap ^ "\n")
443 val _ = print "#endif\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"
460 val _ = print "#ifdef __cplusplus\n"
461 val _ = print "extern \"C\" {\n"
462 val _ = print "#endif\n"
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}
470 val _ = print "#undef MLLIB_PRIVATE\n"
471 val _ = print "#undef MLLIB_PUBLIC\n"
473 val _ = print "#ifdef __cplusplus\n"
475 val _ = print "#endif\n"
477 val _ = print ("#endif /* __" ^ libcap ^ "_ML_H__ */\n")
481 val _ = if !Control.elaborateOnly then raise Done else ()
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))))),
492 stats = fn _ => Layout.empty,
495 DeadCode.deadCode {prog = decs}
499 val decs = Vector.concatV (Vector.map (decs, Vector.fromList))
500 val coreML = CoreML.Program.T {decs = decs}
506 then saveToFile ({suffix = "core-ml"}, No, coreML,
507 Layouts CoreML.Program.layouts)
513 Control.passTypeCheck
514 {display = Control.Layouts Xml.Program.layouts,
515 name = "defunctorize",
516 stats = Xml.Program.layoutStats,
519 thunk = fn () => Defunctorize.defunctorize coreML,
520 typeCheck = Xml.typeCheck}
525 fun simplifyXml xml =
527 Control.passTypeCheck
528 {display = Control.Layouts Xml.Program.layouts,
529 name = "xmlSimplify",
530 stats = Xml.Program.layoutStats,
533 thunk = fn () => Xml.simplify xml,
534 typeCheck = Xml.typeCheck}
538 then saveToFile ({suffix = "xml"}, No, xml,
539 Layouts Xml.Program.layouts)
546 Control.passTypeCheck
547 {display = Control.Layouts Sxml.Program.layouts,
548 name = "monomorphise",
549 stats = Sxml.Program.layoutStats,
552 thunk = fn () => Monomorphise.monomorphise xml,
553 typeCheck = Sxml.typeCheck}
555 fun simplifySxml sxml =
558 Control.passTypeCheck
559 {display = Control.Layouts Sxml.Program.layouts,
560 name = "sxmlSimplify",
561 stats = Sxml.Program.layoutStats,
564 thunk = fn () => Sxml.simplify sxml,
565 typeCheck = Sxml.typeCheck}
569 then saveToFile ({suffix = "sxml"}, No, sxml,
570 Layouts Sxml.Program.layouts)
577 Control.passTypeCheck
578 {display = Control.Layouts Ssa.Program.layouts,
579 name = "closureConvert",
580 stats = Ssa.Program.layoutStats,
583 thunk = fn () => ClosureConvert.closureConvert sxml,
584 typeCheck = Ssa.typeCheck}
586 fun simplifySsa ssa =
589 Control.passTypeCheck
590 {display = Control.Layouts Ssa.Program.layouts,
591 name = "ssaSimplify",
592 stats = Ssa.Program.layoutStats,
595 thunk = fn () => Ssa.simplify ssa,
596 typeCheck = Ssa.typeCheck}
600 then saveToFile ({suffix = "ssa"}, No, ssa,
601 Layouts Ssa.Program.layouts)
608 Control.passTypeCheck
609 {display = Control.Layouts Ssa2.Program.layouts,
611 stats = Ssa2.Program.layoutStats,
614 thunk = fn () => SsaToSsa2.convert ssa,
615 typeCheck = Ssa2.typeCheck}
617 fun simplifySsa2 ssa2 =
620 Control.passTypeCheck
621 {display = Control.Layouts Ssa2.Program.layouts,
622 name = "ssa2Simplify",
623 stats = Ssa2.Program.layoutStats,
626 thunk = fn () => Ssa2.simplify ssa2,
627 typeCheck = Ssa2.typeCheck}
631 then saveToFile ({suffix = "ssa2"}, No, ssa2,
632 Layouts Ssa2.Program.layouts)
638 fun makeMachine ssa2 =
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
647 Control.passTypeCheck
648 {display = Control.Layouts Machine.Program.layouts,
650 stats = fn _ => Layout.empty,
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
667 then saveToFile ({suffix = "machine"}, No, machine,
668 Layouts Machine.Program.layouts)
675 fun setupConstants() : unit =
676 (* Set GC_state offsets and sizes. *)
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"
686 Runtime.GCField.setOffsets
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"
702 Runtime.GCField.setSizes
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"
719 (* Setup endianness *)
722 fun get (name:string): bool =
723 case lookupConstant ({default = NONE, name = name},
725 Const.Word w => 1 = WordX.toInt w
726 | _ => Error.bug "Compile.setupConstants: endian unknown"
728 Control.Target.setBigEndian (get "MLton_Platform_Arch_bigendian")
735 fun preCodegen (input: MLBString.t): Machine.Program.t =
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
750 fun compile {input: 'a, resolve: 'a -> Machine.Program.t, outputC, outputLL, outputS}: unit =
753 Control.trace (Control.Top, "pre codegen")
756 (Machine.Program.clearLabelNames machine
757 ; Machine.Label.printNameAlphaNumeric := true)
759 case !Control.codegen of
760 Control.AMD64Codegen =>
762 ; (Control.trace (Control.Top, "amd64 code gen")
763 amd64Codegen.output {program = machine,
766 | Control.CCodegen =>
768 ; (Control.trace (Control.Top, "C code gen")
769 CCodegen.output {program = machine,
771 | Control.LLVMCodegen =>
773 ; (Control.trace (Control.Top, "llvm code gen")
774 LLVMCodegen.output {program = machine,
776 outputLL = outputLL}))
777 | Control.X86Codegen =>
779 ; (Control.trace (Control.Top, "x86 code gen")
780 x86Codegen.output {program = machine,
783 val _ = Control.message (Control.Detail, PropertyList.stats)
784 val _ = Control.message (Control.Detail, HashSet.stats)
787 end handle Done => ()
789 fun compileMLB {input: File.t, outputC, outputLL, outputS}: unit =
790 compile {input = MLBString.fromFile input,
791 resolve = preCodegen,
797 fn {input: File.t} =>
798 (ignore (elaborate {input = MLBString.fromFile input}))
802 fun genMLB {input: File.t list}: MLBString.t =
804 val basis = "$(SML_LIB)/basis/default.mlb"
811 val input = List.map (input, quoteFile)
817 String.concat (List.separate (input, "\n")), "\n",
822 fun compileSML {input: File.t list, outputC, outputLL, outputS}: unit =
823 compile {input = genMLB {input = input},
824 resolve = preCodegen,
829 fn {input: File.t list} =>
830 (ignore (elaborate {input = genMLB {input = input}}))
834 fun genFromSXML (input: File.t): Machine.Program.t =
836 val _ = setupConstants()
838 Control.passTypeCheck
839 {display = Control.Layouts Sxml.Program.layouts,
841 stats = Sxml.Program.layoutStats,
844 thunk = (fn () => case
845 Parse.parseFile(ParseSxml.program, input)
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 *)
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
862 fun compileSXML {input: File.t, outputC, outputLL, outputS}: unit =
863 compile {input = input,
864 resolve = genFromSXML,