Commit | Line | Data |
---|---|---|
7f918cf1 CE |
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 |