HCoop / hcoop / debian / mlton.git / blame
? search:
summary | shortlog | log | commit | commitdiff | tree
blob | blame (incremental) | history | HEAD
Import Debian changes 20180207-1
[hcoop/debian/mlton.git] / mlton / main / main.fun
CommitLineData
7f918cf1
CE		 1(* Copyright (C) 2010-2011,2013-2018 Matthew Fluet.
2 * Copyright (C) 1999-2009 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
10functor Main (S: MAIN_STRUCTS): MAIN =
11struct
12
13open S
14
15structure Compile = Compile ()
16
17structure Place =
18 struct
19 datatype t = Files | Generated | MLB | O | OUT | SML | SXML | TypeCheck
20 val toInt: t -> int =
21 fn MLB => 1
22 | SML => 1
23 | Files => 2
24 | TypeCheck => 4
25 | SXML => 7
26 | Generated => 10
27 | O => 11
28 | OUT => 12
29
30 val toString =
31 fn Files => "files"
32 | Generated => "g"
33 | MLB => "mlb"
34 | O => "o"
35 | OUT => "out"
36 | SML => "sml"
37 | SXML => "sxml"
38 | TypeCheck => "tc"
39
40 fun compare (p, p') = Int.compare (toInt p, toInt p')
41 end
42
43structure OptPred =
44 struct
45 datatype t =
46 Target of string
47 | Yes
48 end
49
50structure Show =
51 struct
52 datatype t = Anns | PathMap
53 end
54
55val cc: string list ref = ref ["cc"]
56val arScript: string ref = ref "<unset>"
57val asOpts: {opt: string, pred: OptPred.t} list ref = ref []
58val ccOpts: {opt: string, pred: OptPred.t} list ref = ref []
59val linkOpts: {opt: string, pred: OptPred.t} list ref = ref []
60val llvm_as: string ref = ref "llvm-as"
61val llvm_asOpts: {opt: string, pred: OptPred.t} list ref = ref []
62val llvm_llc: string ref = ref "llc"
63val llvm_llcOpts: {opt: string, pred: OptPred.t} list ref = ref []
64val llvm_opt: string ref = ref "opt"
65val llvm_optOpts: {opt: string, pred: OptPred.t} list ref = ref []
66
67val buildConstants: bool ref = ref false
68val debugRuntime: bool ref = ref false
69val expert: bool ref = ref false
70val explicitAlign: Control.align option ref = ref NONE
71val explicitChunk: Control.chunk option ref = ref NONE
72datatype explicitCodegen = Native | Explicit of Control.Codegen.t
73val explicitCodegen: explicitCodegen option ref = ref NONE
74val keepGenerated = ref false
75val keepO = ref false
76val output: string option ref = ref NONE
77val profileSet: bool ref = ref false
78val profileTimeSet: bool ref = ref false
79val runtimeArgs: string list ref = ref ["@MLton"]
80val show: Show.t option ref = ref NONE
81val stop = ref Place.OUT
82
83fun parseMlbPathVar (line: String.t) =
84 case String.tokens (line, Char.isSpace) of
85 [var, path] => SOME {var = var, path = path}
86 | _ => NONE
87
88fun readMlbPathMap (file: File.t) =
89 if not (File.canRead file) then
90 Error.bug (concat ["can't read MLB path map file: ", file])
91 else
92 List.keepAllMap
93 (File.lines file, fn line =>
94 if String.forall (line, Char.isSpace)
95 then NONE
96 else
97 case parseMlbPathVar line of
98 NONE => Error.bug (concat ["strange mlb path mapping: ",
99 file, ":: ", line])
100 | SOME v => SOME v)
101
102val targetMap: unit -> {arch: MLton.Platform.Arch.t,
103 os: MLton.Platform.OS.t,
104 target: string} list =
105 Promise.lazy
106 (fn () =>
107 let
108 val targetsDir =
109 OS.Path.mkAbsolute {path = "targets", relativeTo = !Control.libDir}
110 val potentialTargets = Dir.lsDirs targetsDir
111 fun targetMap target =
112 let
113 val targetDir =
114 OS.Path.mkAbsolute {path = target, relativeTo = targetsDir}
115 val osFile =
116 OS.Path.joinDirFile {dir = targetDir, file = "os"}
117 val archFile =
118 OS.Path.joinDirFile {dir = targetDir, file = "arch"}
119 val os = File.contents osFile
120 val arch = File.contents archFile
121 val os = List.first (String.tokens (os, Char.isSpace))
122 val arch = List.first (String.tokens (arch, Char.isSpace))
123 val os =
124 case MLton.Platform.OS.fromString os of
125 NONE => Error.bug (concat ["strange os: ", os])
126 | SOME os => os
127 val arch =
128 case MLton.Platform.Arch.fromString arch of
129 NONE => Error.bug (concat ["strange arch: ", arch])
130 | SOME a => a
131 in
132 SOME {arch = arch, os = os, target = target}
133 end
134 handle _ => NONE
135 in
136 List.keepAllMap (potentialTargets, targetMap)
137 end)
138
139fun setTargetType (target: string, usage): unit =
140 case List.peek (targetMap (), fn {target = t, ...} => target = t) of
141 NONE => usage (concat ["invalid target: ", target])
142 | SOME {arch, os, ...} =>
143 let
144 open Control
145 in
146 Target.arch := arch
147 ; Target.os := os
148 end
149
150fun hasCodegen (cg) =
151 let
152 datatype z = datatype Control.Target.arch
153 datatype z = datatype Control.Target.os
154 datatype z = datatype Control.Format.t
155 datatype z = datatype Control.codegen
156 in
157 case !Control.Target.arch of
158 AMD64 => (case cg of
159 X86Codegen => false
160 | _ => true)
161 | X86 => (case cg of
162 AMD64Codegen => false
163 | X86Codegen =>
164 (* Darwin PIC doesn't work *)
165 !Control.Target.os <> Darwin orelse
166 !Control.format = Executable orelse
167 !Control.format = Archive
168 | _ => true)
169 | _ => (case cg of
170 AMD64Codegen => false
171 | X86Codegen => false
172 | _ => true)
173 end
174fun hasNativeCodegen () =
175 let
176 datatype z = datatype Control.codegen
177 in
178 hasCodegen AMD64Codegen
179 orelse hasCodegen X86Codegen
180 end
181
182
183fun defaultAlignIs8 () =
184 let
185 datatype z = datatype Control.Target.arch
186 in
187 case !Control.Target.arch of
188 Alpha => true
189 | AMD64 => true
190 | ARM => true
191 | ARM64 => true
192 | HPPA => true
193 | IA64 => true
194 | MIPS => true
195 | Sparc => true
196 | S390 => true
197 | _ => false
198 end
199
200fun makeOptions {usage} =
201 let
202 val usage = fn s => (ignore (usage s); raise Fail "unreachable")
203 fun reportAnnotation (s, flag, e) =
204 case e of
205 Control.Elaborate.Bad =>
206 usage (concat ["invalid -", flag, " flag: ", s])
207 | Control.Elaborate.Good _ => ()
208 | Control.Elaborate.Other =>
209 usage (concat ["invalid -", flag, " flag: ", s])
210 | Control.Elaborate.Proxy (ids, {deprecated}) =>
211 if deprecated andalso !Control.warnDeprecated
212 then
213 Out.output
214 (Out.error,
215 concat ["Warning: ", "deprecated annotation: ", s, ", use ",
216 List.toString Control.Elaborate.Id.name ids, ".\n"])
217 else ()
218 open Control Popt
219 datatype z = datatype MLton.Platform.Arch.t
220 datatype z = datatype MLton.Platform.OS.t
221 fun tokenizeOpt f opts =
222 List.foreach (String.tokens (opts, Char.isSpace),
223 fn opt => f opt)
224 fun tokenizeTargetOpt f (target, opts) =
225 List.foreach (String.tokens (opts, Char.isSpace),
226 fn opt => f (target, opt))
227 in
228 List.map
229 (
230 [
231 (Normal, "align", if defaultAlignIs8 () then " {8|4}" else " {4|8}",
232 "object alignment",
233 (SpaceString (fn s =>
234 explicitAlign
235 := SOME (case s of
236 "4" => Align4
237 | "8" => Align8
238 | _ => usage (concat ["invalid -align flag: ",
239 s]))))),
240 (Expert, "ar-script", " <ar>", "path to a script producing archives",
241 SpaceString (fn s => arScript := s)),
242 (Normal, "as-opt", " <opt>", "pass option to assembler",
243 (SpaceString o tokenizeOpt)
244 (fn s => List.push (asOpts, {opt = s, pred = OptPred.Yes}))),
245 (Expert, "as-opt-quote", " <opt>", "pass (quoted) option to assembler",
246 SpaceString
247 (fn s => List.push (asOpts, {opt = s, pred = OptPred.Yes}))),
248 (Expert, "build-constants", " {false|true}",
249 "output C file that prints basis constants",
250 boolRef buildConstants),
251 (Expert, "cc", " <cc>", "set C compiler",
252 SpaceString
253 (fn s => cc := String.tokens (s, Char.isSpace))),
254 (Normal, "cc-opt", " <opt>", "pass option to C compiler",
255 (SpaceString o tokenizeOpt)
256 (fn s => List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
257 (Expert, "cc-opt-quote", " <opt>", "pass (quoted) option to C compiler",
258 SpaceString
259 (fn s => List.push (ccOpts, {opt = s, pred = OptPred.Yes}))),
260 (Expert, "chunkify", " {coalesce<n>|func|one}", "set chunkify method",
261 SpaceString (fn s =>
262 explicitChunk
263 := SOME (case s of
264 "func" => ChunkPerFunc
265 | "one" => OneChunk
266 | _ => let
267 val usage = fn () =>
268 usage (concat ["invalid -chunkify flag: ", s])
269 in
270 if String.hasPrefix (s, {prefix = "coalesce"})
271 then let
272 val s = String.dropPrefix (s, 8)
273 in
274 if String.forall (s, Char.isDigit)
275 then (case Int.fromString s of
276 NONE => usage ()
277 | SOME n => Coalesce
278 {limit = n})
279 else usage ()
280 end
281 else usage ()
282 end))),
283 (Expert, "closure-convert-globalize", " {true|false}",
284 "whether to globalize during closure conversion",
285 Bool (fn b => (closureConvertGlobalize := b))),
286 (Expert, "closure-convert-shrink", " {true|false}",
287 "whether to shrink during closure conversion",
288 Bool (fn b => (closureConvertShrink := b))),
289 (Normal, "codegen",
290 concat [" {",
291 String.concatWith
292 (List.keepAllMap
293 (Native :: (List.map (Control.Codegen.all, Explicit)),
294 fn cg =>
295 case cg of
296 Native => if hasNativeCodegen () then SOME "native" else NONE
297 | Explicit cg => if hasCodegen cg
298 then SOME (Control.Codegen.toString cg)
299 else NONE),
300 "|"),
301 "}"],
302 "which code generator to use",
303 SpaceString (fn s =>
304 explicitCodegen
305 := SOME (if s = "native"
306 then Native
307 else (case List.peek
308 (Control.Codegen.all, fn cg =>
309 s = Control.Codegen.toString cg) of
310 SOME cg => Explicit cg
311 | NONE => usage (concat ["invalid -codegen flag: ", s]))))),
312 (Normal, "const", " '<name> <value>'", "set compile-time constant",
313 SpaceString (fn s =>
314 case String.tokens (s, Char.isSpace) of
315 [name, value] =>
316 Compile.setCommandLineConstant {name = name,
317 value = value}
318 | _ => usage (concat ["invalid -const flag: ", s]))),
319 (Expert, "contify-into-main", " {false|true}",
320 "contify functions into main",
321 boolRef contifyIntoMain),
322 (Expert, "debug", " {false|true}", "produce executable with debug info",
323 Bool (fn b => (debug := b
324 ; debugRuntime := b))),
325 (Expert, "debug-runtime", " {false|true}", "produce executable with debug info",
326 boolRef debugRuntime),
327 let
328 val flag = "default-ann"
329 in
330 (Normal, flag, " <ann>", "set annotation default for mlb files",
331 SpaceString
332 (fn s => reportAnnotation (s, flag,
333 Control.Elaborate.processDefault s)))
334 end,
335 (Normal, "default-type", " '<ty><N>'", "set default type",
336 SpaceString
337 (fn s => (case s of
338 "char8" => Control.defaultChar := s
339 | "int8" => Control.defaultInt := s
340 | "int16" => Control.defaultInt := s
341 | "int32" => Control.defaultInt := s
342 | "int64" => Control.defaultInt := s
343 | "intinf" => Control.defaultInt := s
344 | "real32" => Control.defaultReal := s
345 | "real64" => Control.defaultReal := s
346 | "widechar16" => Control.defaultWideChar := s
347 | "widechar32" => Control.defaultWideChar := s
348 | "word8" => Control.defaultWord := s
349 | "word16" => Control.defaultWord := s
350 | "word32" => Control.defaultWord := s
351 | "word64" => Control.defaultWord := s
352 | _ => usage (concat ["invalid -default-type flag: ", s])))),
353 (Expert, "diag-pass", " <pass>", "keep diagnostic info for pass",
354 SpaceString
355 (fn s =>
356 (case Regexp.fromString s of
357 SOME (re,_) => let val re = Regexp.compileDFA re
358 in List.push (diagPasses, re)
359 end
360 | NONE => usage (concat ["invalid -diag-pass flag: ", s])))),
361 let
362 val flag = "disable-ann"
363 in
364 (Normal, flag, " <ann>", "disable annotation in mlb files",
365 SpaceString
366 (fn s =>
367 reportAnnotation (s, flag,
368 Control.Elaborate.processEnabled (s, false))))
369 end,
370 (Expert, "disable-pass", " <pass>", "disable optimization pass",
371 SpaceString
372 (fn s => (case Regexp.fromString s of
373 SOME (re,_) => let val re = Regexp.compileDFA re
374 in List.push (executePasses, (re, false))
375 end
376 | NONE => usage (concat ["invalid -disable-pass flag: ", s])))),
377 (Expert, "drop-pass", " <pass>", "disable optimization pass",
378 SpaceString
379 (fn s => (if !Control.warnDeprecated
380 then Out.output
381 (Out.error,
382 "Warning: -drop-pass is deprecated. Use -disable-pass.\n")
383 else ();
384 case Regexp.fromString s of
385 SOME (re,_) => let val re = Regexp.compileDFA re
386 in List.push (executePasses, (re, false))
387 end
388 | NONE => usage (concat ["invalid -disable-pass flag: ", s])))),
389 let
390 val flag = "enable-ann"
391 in
392 (Expert, flag, " <ann>", "globally enable annotation",
393 SpaceString
394 (fn s =>
395 reportAnnotation (s, flag,
396 Control.Elaborate.processEnabled (s, true))))
397 end,
398 (Expert, "enable-pass", " <pass>", "enable optimization pass",
399 SpaceString
400 (fn s => (case Regexp.fromString s of
401 SOME (re,_) => let val re = Regexp.compileDFA re
402 in List.push (executePasses, (re, true))
403 end
404 | NONE => usage (concat ["invalid -enable-pass flag: ", s])))),
405 (Expert, "error-threshhold", " <n>", "error threshhold (20)",
406 intRef errorThreshhold),
407 (Expert, "emit-main", " {true|false}", "emit main() startup function",
408 boolRef emitMain),
409 (Expert, "expert", " {false|true}", "enable expert status",
410 boolRef expert),
411 (Normal, "export-header", " <file>", "write C header file for _export's",
412 SpaceString (fn s => exportHeader := SOME s)),
413 (Expert, "format",
414 concat [" {",
415 String.concatWith
416 (List.keepAllMap
417 (Control.Format.all, fn cg => SOME (Control.Format.toString cg)),
418 "|"),
419 "}"],
420 "generated output format",
421 SpaceString (fn s =>
422 Control.format
423 := (case List.peek
424 (Control.Format.all, fn cg =>
425 s = Control.Format.toString cg) of
426 SOME cg => cg
427 | NONE => usage (concat ["invalid -format flag: ", s])))),
428 (Expert, "gc-check", " {limit|first|every}", "force GCs",
429 SpaceString (fn s =>
430 gcCheck :=
431 (case s of
432 "limit" => Limit
433 | "first" => First
434 | "every" => Every
435 | _ => usage (concat ["invalid -gc-check flag: ", s])))),
436 (Normal, "ieee-fp", " {false|true}", "use strict IEEE floating-point",
437 boolRef Native.IEEEFP),
438 (Expert, "indentation", " <n>", "indentation level in ILs",
439 intRef indentation),
440 (Normal, "inline", " <n>", "set inlining threshold",
441 Int (fn i => inlineNonRec := {small = i,
442 product = #product (!inlineNonRec)})),
443 (Expert, "inline-into-main", " {true|false}",
444 "inline functions into main",
445 boolRef inlineIntoMain),
446 (Expert, "inline-leafa-loops", " {true|false}", "leaf inline loops",
447 Bool (fn loops =>
448 case !inlineLeafA of
449 {repeat, size, ...} =>
450 inlineLeafA :=
451 {loops = loops, repeat = repeat, size = size})),
452 (Expert, "inline-leafa-repeat", " {true|false}", "leaf inline repeat",
453 Bool (fn repeat =>
454 case !inlineLeafA of
455 {loops, size, ...} =>
456 inlineLeafA :=
457 {loops = loops, repeat = repeat, size = size})),
458 (Expert, "inline-leafa-size", " <n>", "set leaf inlining threshold (20)",
459 SpaceString (fn s =>
460 case !inlineLeafA of
461 {loops, repeat, ...} =>
462 inlineLeafA :=
463 {loops = loops, repeat = repeat,
464 size = (if s = "inf"
465 then NONE
466 else if String.forall (s, Char.isDigit)
467 then Int.fromString s
468 else (usage o concat)
469 ["invalid -inline-leaf-size flag: ", s])})),
470 (Expert, "inline-leafb-loops", " {true|false}", "leaf inline loops",
471 Bool (fn loops =>
472 case !inlineLeafB of
473 {repeat, size, ...} =>
474 inlineLeafB :=
475 {loops = loops, repeat = repeat, size = size})),
476 (Expert, "inline-leafb-repeat", " {true|false}", "leaf inline repeat",
477 Bool (fn repeat =>
478 case !inlineLeafB of
479 {loops, size, ...} =>
480 inlineLeafB :=
481 {loops = loops, repeat = repeat, size = size})),
482 (Expert, "inline-leafb-size", " <n>", "set leaf inlining threshold (40)",
483 SpaceString (fn s =>
484 case !inlineLeafB of
485 {loops, repeat, ...} =>
486 inlineLeafB :=
487 {loops = loops, repeat = repeat,
488 size = (if s = "inf"
489 then NONE
490 else if String.forall (s, Char.isDigit)
491 then Int.fromString s
492 else (usage o concat)
493 ["invalid -inline-leaf-size flag: ", s])})),
494 (Expert, "inline-nonrec-product", " <n>", "set inlining threshold (320)",
495 Int (fn product =>
496 case !inlineNonRec of
497 {small, ...} =>
498 inlineNonRec := {small = small, product = product})),
499 (Expert, "inline-nonrec-small", " <n>", "set inlining threshold (60)",
500 Int (fn small =>
501 case !inlineNonRec of
502 {product, ...} =>
503 inlineNonRec := {small = small, product = product})),
504 (Normal, "keep", " {g|o}", "save intermediate files",
505 SpaceString (fn s =>
506 case s of
507 "ast" => keepAST := true
508 | "core-ml" => keepCoreML := true
509 | "dot" => keepDot := true
510 | "g" => keepGenerated := true
511 | "machine" => keepMachine := true
512 | "o" => keepO := true
513 | "rssa" => keepRSSA := true
514 | "ssa" => keepSSA := true
515 | "ssa2" => keepSSA2 := true
516 | "sxml" => keepSXML := true
517 | "xml" => keepXML := true
518 | _ => usage (concat ["invalid -keep flag: ", s]))),
519 (Expert, "keep-pass", " <pass>", "keep the results of pass",
520 SpaceString
521 (fn s => (case Regexp.fromString s of
522 SOME (re,_) => let val re = Regexp.compileDFA re
523 in List.push (keepPasses, re)
524 end
525 | NONE => usage (concat ["invalid -keep-pass flag: ", s])))),
526 (Expert, "layout-width", " <n>", "target width for pretty printer",
527 Int (fn n =>
528 if n > 0
529 then Layout.setDefaultWidth n
530 else usage (concat ["invalid -layout-width arg: ", Int.toString n]))),
531 (Expert, "libname", " <basename>", "the name of the generated library",
532 SpaceString (fn s => libname := s)),
533 (Normal, "link-opt", " <opt>", "pass option to linker",
534 (SpaceString o tokenizeOpt)
535 (fn s => List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
536 (Expert, "link-opt-quote", " <opt>", "pass (quoted) option to linker",
537 SpaceString
538 (fn s => List.push (linkOpts, {opt = s, pred = OptPred.Yes}))),
539 (Expert, "llvm-as", " <llvm-as>", "path to llvm .ll -> .bc assembler",
540 SpaceString (fn s => llvm_as := s)),
541 (Normal, "llvm-as-opt", " <opt>", "pass option to llvm assembler",
542 (SpaceString o tokenizeOpt)
543 (fn s => List.push (llvm_asOpts, {opt = s, pred = OptPred.Yes}))),
544 (Expert, "llvm-as-opt-quote", " <opt>", "pass (quoted) option to llvm assembler",
545 SpaceString
546 (fn s => List.push (llvm_asOpts, {opt = s, pred = OptPred.Yes}))),
547 (Expert, "llvm-llc", " <llc>", "path to llvm .bc -> .o compiler",
548 SpaceString (fn s => llvm_llc := s)),
549 (Normal, "llvm-llc-opt", " <opt>", "pass option to llvm compiler",
550 (SpaceString o tokenizeOpt)
551 (fn s => List.push (llvm_llcOpts, {opt = s, pred = OptPred.Yes}))),
552 (Expert, "llvm-llc-opt-quote", " <opt>", "pass (quoted) option to llvm compiler",
553 SpaceString
554 (fn s => List.push (llvm_llcOpts, {opt = s, pred = OptPred.Yes}))),
555 (Expert, "llvm-opt", " <llvm-as>", "path to llvm .bc -> .bc optimizer",
556 SpaceString (fn s => llvm_opt := s)),
557 (Normal, "llvm-opt-opt", " <opt>", "pass option to llvm optimizer",
558 (SpaceString o tokenizeOpt)
559 (fn s => List.push (llvm_optOpts, {opt = s, pred = OptPred.Yes}))),
560 (Expert, "llvm-opt-opt-quote", " <opt>", "pass (quoted) option to llvm optimizer",
561 SpaceString
562 (fn s => List.push (llvm_optOpts, {opt = s, pred = OptPred.Yes}))),
563 (Expert, "loop-ssa-passes", " <n>", "loop ssa optimization passes (1)",
564 Int
565 (fn i =>
566 if i >= 1
567 then loopSsaPasses := i
568 else usage (concat ["invalid -loop-ssa-passes arg: ", Int.toString i]))),
569 (Expert, "loop-ssa2-passes", " <n>", "loop ssa2 optimization passes (1)",
570 Int
571 (fn i =>
572 if i >= 1
573 then loopSsa2Passes := i
574 else usage (concat ["invalid -loop-ssa2-passes arg: ", Int.toString i]))),
575 (Expert, "loop-unroll-limit", " <n>", "limit code growth by loop unrolling",
576 Int
577 (fn i =>
578 if i >= 0
579 then loopUnrollLimit := i
580 else usage (concat ["invalid -loop-unroll-limit: ", Int.toString i]))),
581 (Expert, "loop-unswitch-limit", " <n>", "limit code growth by loop unswitching",
582 Int
583 (fn i =>
584 if i >= 0
585 then loopUnswitchLimit := i
586 else usage (concat ["invalid -loop-unswitch-limit: ", Int.toString i]))),
587 (Expert, "mark-cards", " {true|false}", "mutator marks cards",
588 boolRef markCards),
589 (Expert, "max-function-size", " <n>", "max function size (blocks)",
590 intRef maxFunctionSize),
591 (Normal, "mlb-path-map", " <file>", "additional MLB path map",
592 SpaceString (fn s => mlbPathVars := !mlbPathVars @ readMlbPathMap s)),
593 (Normal, "mlb-path-var", " '<name> <value>'", "additional MLB path var",
594 SpaceString
595 (fn s => mlbPathVars := !mlbPathVars @
596 [case parseMlbPathVar s of
597 NONE => Error.bug ("strange mlb path var: " ^ s)
598 | SOME v => v])),
599 (Expert, "native-commented", " <n>", "level of comments (0)",
600 intRef Native.commented),
601 (Expert, "native-copy-prop", " {true|false}",
602 "use copy propagation",
603 boolRef Native.copyProp),
604 (Expert, "native-cutoff", " <n>",
605 "live transfer cutoff distance",
606 intRef Native.cutoff),
607 (Expert, "native-live-transfer", " {0,...,8}",
608 "use live transfer",
609 intRef Native.liveTransfer),
610 (Expert, "native-live-stack", " {false|true}",
611 "track liveness of stack slots",
612 boolRef Native.liveStack),
613 (Expert, "native-move-hoist", " {true|false}",
614 "use move hoisting",
615 boolRef Native.moveHoist),
616 (Expert, "native-optimize", " <n>", "level of optimizations",
617 intRef Native.optimize),
618 (Expert, "native-split", " <n>", "split assembly files at ~n lines",
619 Int (fn i => Native.split := SOME i)),
620 (Expert, "native-shuffle", " {true|false}",
621 "shuffle registers at C-calls",
622 Bool (fn b => Native.shuffle := b)),
623 (Expert, "opt-fuel", " <n>", "optimization 'fuel'",
624 Int (fn n => optFuel := SOME n)),
625 (Expert, "opt-passes", " {default|minimal}", "level of optimizations",
626 SpaceString (fn s =>
627 let
628 fun err s =
629 usage (concat ["invalid -opt-passes flag: ", s])
630 in
631 List.foreach
632 (!optimizationPasses, fn {il,set,...} =>
633 case set s of
634 Result.Yes () => ()
635 | Result.No s' => err (concat [s', "(for ", il, ")"]))
636 end)),
637 (Normal, "output", " <file>", "name of output file",
638 SpaceString (fn s => output := SOME s)),
639 (Expert, "polyvariance", " {true|false}", "use polyvariance",
640 Bool (fn b => if b then () else polyvariance := NONE)),
641 (Expert, "polyvariance-hofo", " {true|false}", "duplicate higher-order fns only",
642 Bool (fn hofo =>
643 case !polyvariance of
644 SOME {product, rounds, small, ...} =>
645 polyvariance := SOME {hofo = hofo,
646 product = product,
647 rounds = rounds,
648 small = small}
649 | _ => ())),
650 (Expert, "polyvariance-product", " <n>", "set polyvariance threshold (300)",
651 Int (fn product =>
652 case !polyvariance of
653 SOME {hofo, rounds, small, ...} =>
654 polyvariance := SOME {hofo = hofo,
655 product = product,
656 rounds = rounds,
657 small = small}
658 | _ => ())),
659 (Expert, "polyvariance-rounds", " <n>", "set polyvariance rounds (2)",
660 Int (fn rounds =>
661 case !polyvariance of
662 SOME {hofo, product, small, ...} =>
663 polyvariance := SOME {hofo = hofo,
664 product = product,
665 rounds = rounds,
666 small = small}
667 | _ => ())),
668 (Expert, "polyvariance-small", " <n>", "set polyvariance threshold (30)",
669 Int (fn small =>
670 case !polyvariance of
671 SOME {hofo, product, rounds, ...} =>
672 polyvariance := SOME {hofo = hofo,
673 product = product,
674 rounds = rounds,
675 small = small}
676 | _ => ())),
677 (Expert, "prefer-abs-paths", " {false|true}",
678 "prefer absolute paths when referring to files",
679 boolRef preferAbsPaths),
680 (Expert, "prof-pass", " <pass>", "keep profile info for pass",
681 SpaceString (fn s =>
682 (case Regexp.fromString s of
683 SOME (re,_) => let val re = Regexp.compileDFA re
684 in
685 List.push (profPasses, re)
686 end
687 | NONE => usage (concat ["invalid -diag-pass flag: ", s])))),
688 (Normal, "profile", " {no|alloc|count|time}",
689 "produce executable suitable for profiling",
690 SpaceString
691 (fn s =>
692 if !profileSet
693 then usage "can't have multiple -profile switches"
694 else
695 (profileSet := true
696 ; profile := (case s of
697 "no" => ProfileNone
698 | "alloc" => ProfileAlloc
699 | "call" => ProfileCallStack
700 | "count" => ProfileCount
701 | "drop" => ProfileDrop
702 | "label" => ProfileLabel
703 | "time" => (profileTimeSet := true
704 ; ProfileTimeLabel)
705 | "time-field" => ProfileTimeField
706 | "time-label" => ProfileTimeLabel
707 | _ => usage (concat
708 ["invalid -profile arg: ", s]))))),
709 (Normal, "profile-branch", " {false|true}",
710 "profile branches in addition to functions",
711 boolRef profileBranch),
712 (Expert, "profile-c", " <regexp>",
713 "include C-calls in files matching <regexp> in profile",
714 SpaceString
715 (fn s =>
716 (case Regexp.fromString s of
717 SOME (re,_) => let
718 open Regexp
719 val re = seq [anys, re, anys]
720 val re = compileDFA re
721 in List.push (profileC, re)
722 end
723 | NONE => usage (concat ["invalid -profile-c flag: ", s])))),
724 (Expert, "profile-exclude", " <regexp>",
725 "exclude files matching <regexp> from profile",
726 SpaceString
727 (fn s =>
728 (case Regexp.fromString s of
729 SOME (re,_) => let
730 open Regexp
731 val re = seq [anys, re, anys]
732 val re = compileDFA re
733 in List.push (profileInclExcl, (re, false))
734 end
735 | NONE => usage (concat ["invalid -profile-exclude flag: ", s])))),
736 (Expert, "profile-il", " {source}", "where to insert profile exps",
737 SpaceString
738 (fn s =>
739 case s of
740 "source" => profileIL := ProfileSource
741 | "ssa" => profileIL := ProfileSSA
742 | "ssa2" => profileIL := ProfileSSA2
743 | _ => usage (concat ["invalid -profile-il arg: ", s]))),
744 (Expert, "profile-include", " <regexp>",
745 "include files matching <regexp> from profile",
746 SpaceString
747 (fn s =>
748 (case Regexp.fromString s of
749 SOME (re,_) => let
750 open Regexp
751 val re = seq [anys, re, anys]
752 val re = compileDFA re
753 in List.push (profileInclExcl, (re, true))
754 end
755 | NONE => usage (concat ["invalid -profile-include flag: ", s])))),
756 (Expert, "profile-raise", " {false|true}",
757 "profile raises in addition to functions",
758 boolRef profileRaise),
759 (Normal, "profile-stack", " {false|true}", "profile the stack",
760 boolRef profileStack),
761 (Normal, "profile-val", " {false|true}",
762 "profile val bindings in addition to functions",
763 boolRef profileVal),
764 (Normal, "runtime", " <arg>", "pass arg to runtime via @MLton",
765 SpaceString (fn s => List.push (runtimeArgs, s))),
766 (Expert, "seed-rand", " <w>", "seed the pseudo-random number generator",
767 Word Random.srand),
768 (Expert, "show", " {anns|path-map}", "print specified data and stop",
769 SpaceString
770 (fn s =>
771 show := SOME (case s of
772 "anns" => Show.Anns
773 | "path-map" => Show.PathMap
774 | _ => usage (concat ["invalid -show arg: ", s])))),
775 (Normal, "show-basis", " <file>", "write final basis environment",
776 SpaceString (fn s => showBasis := SOME s)),
777 (Expert, "show-basis-compact", " {false|true}", "show basis environment in compact form",
778 boolRef showBasisCompact),
779 (Expert, "show-basis-def", " {true|false}", "show basis environment with definition source position",
780 boolRef showBasisDef),
781 (Expert, "show-basis-flat", " {true|false}", "show basis environment with long identifier names",
782 boolRef showBasisFlat),
783 (Normal, "show-def-use", " <file>", "write def-use information",
784 SpaceString (fn s => showDefUse := SOME s)),
785 (Expert, "show-types", " {true|false}", "show types in ILs",
786 boolRef showTypes),
787 (Expert, "ssa-passes", " <passes>", "ssa optimization passes",
788 SpaceString
789 (fn s =>
790 case List.peek (!Control.optimizationPasses,
791 fn {il, ...} => String.equals ("ssa", il)) of
792 SOME {set, ...} =>
793 (case set s of
794 Result.Yes () => ()
795 | Result.No s' => usage (concat ["invalid -ssa-passes arg: ", s']))
796 | NONE => Error.bug "ssa optimization passes missing")),
797 (Expert, "ssa2-passes", " <passes>", "ssa2 optimization passes",
798 SpaceString
799 (fn s =>
800 case List.peek (!Control.optimizationPasses,
801 fn {il, ...} => String.equals ("ssa2", il)) of
802 SOME {set, ...} =>
803 (case set s of
804 Result.Yes () => ()
805 | Result.No s' => usage (concat ["invalid -ssa2-passes arg: ", s']))
806 | NONE => Error.bug "ssa2 optimization passes missing")),
807 (Normal, "stop", " {f|g|o|tc}", "when to stop",
808 SpaceString
809 (fn s =>
810 stop := (case s of
811 "f" => Place.Files
812 | "g" => Place.Generated
813 | "o" => Place.O
814 | "tc" => Place.TypeCheck
815 | _ => usage (concat ["invalid -stop arg: ", s])))),
816 (Expert, "sxml-passes", " <passes>", "sxml optimization passes",
817 SpaceString
818 (fn s =>
819 case List.peek (!Control.optimizationPasses,
820 fn {il, ...} => String.equals ("sxml", il)) of
821 SOME {set, ...} =>
822 (case set s of
823 Result.Yes () => ()
824 | Result.No s' => usage (concat ["invalid -sxml-passes arg: ", s']))
825 | NONE => Error.bug "sxml optimization passes missing")),
826 (Normal, "target",
827 concat [" {",
828 (case targetMap () of
829 [] => ""
830 | [x] => #target x
831 | x :: _ => concat [#target x, "|..."]),
832 "}"],
833 "platform that executable will run on",
834 SpaceString
835 (fn t =>
836 (target := (if t = "self" then Self else Cross t);
837 setTargetType (t, usage)))),
838 (Normal, "target-as-opt", " <target> <opt>", "target-dependent assembler option",
839 (SpaceString2 o tokenizeTargetOpt)
840 (fn (target, opt) =>
841 List.push (asOpts, {opt = opt, pred = OptPred.Target target}))),
842 (Expert, "target-as-opt-quote", " <target> <opt>", "target-dependent assembler option (quoted)",
843 (SpaceString2
844 (fn (target, opt) =>
845 List.push (asOpts, {opt = opt, pred = OptPred.Target target})))),
846 (Normal, "target-cc-opt", " <target> <opt>", "target-dependent C compiler option",
847 (SpaceString2 o tokenizeTargetOpt)
848 (fn (target, opt) =>
849 List.push (ccOpts, {opt = opt, pred = OptPred.Target target}))),
850 (Expert, "target-cc-opt-quote", " <target> <opt>", "target-dependent C compiler option (quoted)",
851 (SpaceString2
852 (fn (target, opt) =>
853 List.push (ccOpts, {opt = opt, pred = OptPred.Target target})))),
854 (Normal, "target-link-opt", " <target> <opt>", "target-dependent linker option",
855 (SpaceString2 o tokenizeTargetOpt)
856 (fn (target, opt) =>
857 List.push (linkOpts, {opt = opt, pred = OptPred.Target target}))),
858 (Expert, "target-link-opt-quote", " <target> <opt>", "target-dependent linker option (quoted)",
859 (SpaceString2
860 (fn (target, opt) =>
861 List.push (linkOpts, {opt = opt, pred = OptPred.Target target})))),
862 (Expert, "target-llvm-as-opt", " <target> <opt>", "target-dependent llvm assembler option",
863 (SpaceString2 o tokenizeTargetOpt)
864 (fn (target, opt) => List.push (llvm_asOpts, {opt = opt, pred = OptPred.Target target}))),
865 (Expert, "target-llvm-as-opt-quote", " <target> <opt>", "target-dependent llvm assembler option (quoted)",
866 SpaceString2
867 (fn (target, opt) => List.push (llvm_asOpts, {opt = opt, pred = OptPred.Target target}))),
868 (Expert, "target-llvm-llc-opt", " <target> <opt>", "target-dependent llvm compiler option",
869 (SpaceString2 o tokenizeTargetOpt)
870 (fn (target, opt) => List.push (llvm_llcOpts, {opt = opt, pred = OptPred.Target target}))),
871 (Expert, "target-llvm-llc-opt-quote", " <target> <opt>", "target-dependent llvm compiler option (quoted)",
872 SpaceString2
873 (fn (target, opt) => List.push (llvm_llcOpts, {opt = opt, pred = OptPred.Target target}))),
874 (Expert, "target-llvm-opt-opt", " <target> <opt>", "target-dependent llvm optimizer option",
875 (SpaceString2 o tokenizeTargetOpt)
876 (fn (target, opt) => List.push (llvm_optOpts, {opt = opt, pred = OptPred.Target target}))),
877 (Expert, "target-llvm-opt-opt-quote", " <target> <opt>", "target-dependent llvm optimizer option (quoted)",
878 SpaceString2
879 (fn (target, opt) => List.push (llvm_optOpts, {opt = opt, pred = OptPred.Target target}))),
880 (Expert, #1 trace, " name1,...", "trace compiler internals", #2 trace),
881 (Expert, "type-check", " {false|true}", "type check ILs",
882 boolRef typeCheck),
883 (Normal, "verbose", " {0|1|2|3}", "how verbose to be",
884 SpaceString
885 (fn s =>
886 verbosity := (case s of
887 "0" => Silent
888 | "1" => Top
889 | "2" => Pass
890 | "3" => Detail
891 | _ => usage (concat ["invalid -verbose arg: ", s])))),
892 (Expert, "warn-ann", " {true|false}",
893 "unrecognized annotation warnings",
894 boolRef warnAnn),
895 (Expert, "warn-deprecated", " {true|false}",
896 "deprecated feature warnings",
897 boolRef warnDeprecated),
898 (Expert, "xml-passes", " <passes>", "xml optimization passes",
899 SpaceString
900 (fn s =>
901 case List.peek (!Control.optimizationPasses,
902 fn {il, ...} => String.equals ("xml", il)) of
903 SOME {set, ...} =>
904 (case set s of
905 Result.Yes () => ()
906 | Result.No s' => usage (concat ["invalid -xml-passes arg: ", s']))
907 | NONE => Error.bug "xml optimization passes missing")),
908 (Expert, "zone-cut-depth", " <n>", "zone cut depth",
909 intRef zoneCutDepth)
910 ],
911 fn (style, name, arg, desc, opt) =>
912 {arg = arg, desc = desc, name = name, opt = opt, style = style})
913 end
914
915val mainUsage =
916 "mlton [option ...] file.{c|mlb|o|sml} [file.{c|o|s|S} ...]"
917
918val {parse, usage} =
919 Popt.makeUsage {mainUsage = mainUsage,
920 makeOptions = makeOptions,
921 showExpert = fn () => !expert}
922
923val usage = fn s => (usage s; raise Fail "unreachable")
924
925fun commandLine (args: string list): unit =
926 let
927 open Control
928 datatype z = datatype MLton.Platform.Arch.t
929 datatype z = datatype MLton.Platform.OS.t
930 val args =
931 case args of
932 lib :: args =>
933 (libDir := OS.Path.mkCanonical lib
934 ; args)
935 | _ => Error.bug "incorrect args from shell script"
936 val () = setTargetType ("self", usage)
937 val result = parse args
938
939 val target = !target
940 val targetStr =
941 case target of
942 Cross s => s
943 | Self => "self"
944 val targetsDir =
945 OS.Path.mkAbsolute {path = "targets", relativeTo = !libDir}
946 val targetDir =
947 OS.Path.mkAbsolute {path = targetStr, relativeTo = targetsDir}
948 val () = Control.libTargetDir := targetDir
949 val targetIncDir =
950 OS.Path.mkAbsolute {path = "include", relativeTo = targetDir}
951 val targetLibDir = targetDir
952 val targetArch = !Target.arch
953 val targetArchStr = String.toLower (MLton.Platform.Arch.toString targetArch)
954 val targetOS = !Target.os
955 val targetOSStr = String.toLower (MLton.Platform.OS.toString targetOS)
956 val targetArchOSStr = concat [targetArchStr, "-", targetOSStr]
957
958 (* Determine whether code should be PIC (position independent) or not.
959 * This decision depends on the platform and output format.
960 *)
961 val positionIndependent =
962 case (targetOS, targetArch, !format) of
963 (* Windows is never position independent *)
964 (MinGW, _, _) => false
965 | (Cygwin, _, _) => false
966 (* GCC on AMD64 now produces PIC by default in many Linux distros. *)
967 | (Linux, AMD64, _) => true
968 (* Technically, Darwin should always be PIC.
969 * However, PIC on i386/darwin is unimplemented so we avoid it.
970 * PowerPC PIC is bad too, but the C codegen will use PIC behind
971 * our back unless forced, so let's just admit that it's PIC.
972 *)
973 | (Darwin, X86, Executable) => false
974 | (Darwin, X86, Archive) => false
975 | (Darwin, _, _) => true
976 | (OpenBSD, _, _) => true
977 (* On ELF systems, we only need PIC for LibArchive/Library *)
978 | (_, _, Library) => true
979 | (_, _, LibArchive) => true
980 | _ => false
981 val () = Control.positionIndependent := positionIndependent
982
983 val stop = !stop
984
985 val () =
986 align := (case !explicitAlign of
987 NONE => if defaultAlignIs8 () then Align8 else Align4
988 | SOME a => a)
989 val () =
990 codegen := (case !explicitCodegen of
991 NONE =>
992 if hasCodegen AMD64Codegen
993 then AMD64Codegen
994 else if hasCodegen X86Codegen
995 then X86Codegen
996 else CCodegen
997 | SOME Native =>
998 if hasCodegen AMD64Codegen
999 then AMD64Codegen
1000 else if hasCodegen X86Codegen
1001 then X86Codegen
1002 else usage (concat ["can't use native codegen on ",
1003 MLton.Platform.Arch.toString targetArch,
1004 " target"])
1005 | SOME (Explicit cg) => cg)
1006 val () = MLton.Rusage.measureGC (!verbosity <> Silent)
1007 val () = if !profileTimeSet
1008 then (case !codegen of
1009 X86Codegen => profile := ProfileTimeLabel
1010 | AMD64Codegen => profile := ProfileTimeLabel
1011 | _ => profile := ProfileTimeField)
1012 else ()
1013 val () = if !exnHistory
1014 then (case !profile of
1015 ProfileNone => profile := ProfileCallStack
1016 | ProfileCallStack => ()
1017 | _ => usage "can't use -profile with Exn.keepHistory"
1018 ; profileRaise := true)
1019 else ()
1020
1021 val () =
1022 Compile.setCommandLineConstant
1023 {name = "CallStack.keep",
1024 value = Bool.toString (!Control.profile = Control.ProfileCallStack)}
1025
1026 val () =
1027 let
1028 val sizeMap =
1029 List.map
1030 (File.lines (OS.Path.joinDirFile {dir = targetDir,
1031 file = "sizes"}),
1032 fn line =>
1033 case String.tokens (line, Char.isSpace) of
1034 [ty, "=", size] =>
1035 (case Int.fromString size of
1036 NONE => Error.bug (concat ["strange size: ", size])
1037 | SOME size =>
1038 (ty, Bytes.toBits (Bytes.fromInt size)))
1039 | _ => Error.bug (concat ["strange size mapping: ", line]))
1040 fun lookup ty' =
1041 case List.peek (sizeMap, fn (ty, _) => String.equals (ty, ty')) of
1042 NONE => Error.bug (concat ["missing size mapping: ", ty'])
1043 | SOME (_, size) => size
1044 in
1045 Control.Target.setSizes
1046 {arrayMetaData = lookup "arrayMetaData",
1047 cint = lookup "cint",
1048 cpointer = lookup "cpointer",
1049 cptrdiff = lookup "cptrdiff",
1050 csize = lookup "csize",
1051 header = lookup "header",
1052 mplimb = lookup "mplimb",
1053 normalMetaData = lookup "normalMetaData",
1054 objptr = lookup "objptr",
1055 seqIndex = lookup "seqIndex"}
1056 end
1057
1058 fun tokenize l =
1059 String.tokens (concat (List.separate (l, " ")), Char.isSpace)
1060
1061 (* When cross-compiling, use the named cross compiler.
1062 * Older gcc versions used -b for multiple targets.
1063 * If this is still needed, a shell script wrapper can hide this.
1064 *)
1065 val cc =
1066 case target of
1067 Cross s =>
1068 let
1069 val {dir = ccDir, file = ccFile} =
1070 OS.Path.splitDirFile (hd (!cc))
1071 in
1072 OS.Path.joinDirFile
1073 {dir = ccDir,
1074 file = s ^ "-" ^ ccFile}
1075 ::
1076 tl (!cc)
1077 end
1078 | Self => !cc
1079 val arScript = !arScript
1080
1081 fun addTargetOpts opts =
1082 List.fold
1083 (!opts, [], fn ({opt, pred}, ac) =>
1084 if (case pred of
1085 OptPred.Target s =>
1086 let
1087 val s = String.toLower s
1088 in
1089 s = targetArchOSStr
1090 orelse s = targetArchStr
1091 orelse s = targetOSStr
1092 end
1093 | OptPred.Yes => true)
1094 then opt :: ac
1095 else ac)
1096 val asOpts = addTargetOpts asOpts
1097 val asOpts = if !debug
1098 then "-Wa,-g" :: asOpts
1099 else asOpts
1100 val ccOpts = addTargetOpts ccOpts
1101 val ccOpts = ("-I" ^ targetIncDir) :: ccOpts
1102 val ccOpts = if !debug
1103 then "-g" :: "-DASSERT=1" :: ccOpts
1104 else ccOpts
1105 val linkOpts = addTargetOpts linkOpts
1106 val linkOpts = if !debugRuntime then
1107 "-lmlton-gdb" :: "-lgdtoa-gdb" :: linkOpts
1108 else if positionIndependent then
1109 "-lmlton-pic" :: "-lgdtoa-pic" :: linkOpts
1110 else
1111 "-lmlton" :: "-lgdtoa" :: linkOpts
1112 val linkOpts = ("-L" ^ targetLibDir) :: linkOpts
1113
1114 val linkArchives =
1115 if !debugRuntime then
1116 [OS.Path.joinDirFile {dir = targetLibDir, file = "libmlton-gdb.a"},
1117 OS.Path.joinDirFile {dir = targetLibDir, file = "libgdtoa-gdb.a"}]
1118 else if positionIndependent then
1119 [OS.Path.joinDirFile {dir = targetLibDir, file = "libmlton-pic.a"},
1120 OS.Path.joinDirFile {dir = targetLibDir, file = "libgdtoa-pic.a"}]
1121 else
1122 [OS.Path.joinDirFile {dir = targetLibDir, file = "libmlton.a"},
1123 OS.Path.joinDirFile {dir = targetLibDir, file = "libgdtoa.a"}]
1124
1125 val llvm_as = !llvm_as
1126 val llvm_llc = !llvm_llc
1127 val llvm_opt = !llvm_opt
1128 val llvm_asOpts = addTargetOpts llvm_asOpts
1129 val llvm_llcOpts = addTargetOpts llvm_llcOpts
1130 val llvm_optOpts = addTargetOpts llvm_optOpts
1131
1132 val _ =
1133 if not (hasCodegen (!codegen))
1134 then usage (concat ["can't use ",
1135 Control.Codegen.toString (!codegen),
1136 " codegen on ",
1137 MLton.Platform.Arch.toString targetArch,
1138 " target"])
1139 else ()
1140 val () =
1141 Control.labelsHaveExtra_ := (case (targetOS, targetArch) of
1142 (Cygwin, X86) => true
1143 | (Darwin, _) => true
1144 | (MinGW, X86) => true
1145 | _ => false)
1146 val _ =
1147 chunk :=
1148 (case !explicitChunk of
1149 NONE => (case !codegen of
1150 AMD64Codegen => ChunkPerFunc
1151 | CCodegen => Coalesce {limit = 4096}
1152 | LLVMCodegen => Coalesce {limit = 4096}
1153 | X86Codegen => ChunkPerFunc
1154 )
1155 | SOME c => c)
1156 val _ = if not (!Control.codegen = X86Codegen) andalso !Native.IEEEFP
1157 then usage "must use x86 codegen with -ieee-fp true"
1158 else ()
1159 val _ =
1160 if !keepDot andalso List.isEmpty (!keepPasses)
1161 then keepSSA := true
1162 else ()
1163 val () =
1164 keepDefUse
1165 := (isSome (!showDefUse)
1166 orelse (Control.Elaborate.enabled Control.Elaborate.warnUnused)
1167 orelse (Control.Elaborate.default Control.Elaborate.warnUnused))
1168 val warnMatch =
1169 (Control.Elaborate.enabled Control.Elaborate.nonexhaustiveMatch)
1170 orelse (Control.Elaborate.enabled Control.Elaborate.redundantMatch)
1171 orelse (Control.Elaborate.default Control.Elaborate.nonexhaustiveMatch <>
1172 Control.Elaborate.DiagEIW.Ignore)
1173 orelse (Control.Elaborate.default Control.Elaborate.redundantMatch <>
1174 Control.Elaborate.DiagEIW.Ignore)
1175 val _ = elaborateOnly := (stop = Place.TypeCheck
1176 andalso not (warnMatch)
1177 andalso not (!keepDefUse))
1178 val _ =
1179 case targetOS of
1180 Darwin => ()
1181 | FreeBSD => ()
1182 | HPUX => ()
1183 | Linux => ()
1184 | MinGW => ()
1185 | NetBSD => ()
1186 | OpenBSD => ()
1187 | Solaris => ()
1188 | _ =>
1189 if !profile = ProfileTimeField
1190 orelse !profile = ProfileTimeLabel
1191 then usage (concat ["can't use -profile time on ",
1192 MLton.Platform.OS.toString targetOS])
1193 else ()
1194 fun printVersion (out: Out.t): unit =
1195 Out.output (out, concat [Version.banner, "\n"])
1196 val () =
1197 case !show of
1198 NONE => ()
1199 | SOME info =>
1200 (case info of
1201 Show.Anns =>
1202 Layout.outputl (Control.Elaborate.document {expert = !expert},
1203 Out.standard)
1204 | Show.PathMap =>
1205 let
1206 open Layout
1207 in
1208 outputl (align
1209 (List.revMap (Control.mlbPathMap (),
1210 fn {var, path, ...} =>
1211 str (concat [var, " ", path]))),
1212 Out.standard)
1213 end
1214 ; let open OS.Process in exit success end)
1215 in
1216 case result of
1217 Result.No msg => usage msg
1218 | Result.Yes [] =>
1219 (inputFile := "<none>"
1220 ; if isSome (!showBasis)
1221 then (trace (Top, "Type Check SML")
1222 Compile.elaborateSML {input = []})
1223 else if !buildConstants
1224 then Compile.outputBasisConstants Out.standard
1225 else if !verbosity = Silent orelse !verbosity = Top
1226 then printVersion Out.standard
1227 else outputHeader' (No, Out.standard))
1228 | Result.Yes (input :: rest) =>
1229 let
1230 val _ = inputFile := File.base (File.fileOf input)
1231 val (start, base) =
1232 let
1233 val rec loop =
1234 fn [] => usage (concat ["invalid file suffix on ", input])
1235 | (suf, start, hasNum) :: sufs =>
1236 if String.hasSuffix (input, {suffix = suf})
1237 then (start,
1238 let
1239 val f = File.base input
1240 in
1241 if hasNum
1242 then File.base f
1243 else f
1244 end)
1245 else loop sufs
1246 datatype z = datatype Place.t
1247 in
1248 loop [(".mlb", MLB, false),
1249 (".sml", SML, false),
1250 (".sxml", SXML, false),
1251 (".c", Generated, true),
1252 (".o", O, true)]
1253 end
1254 val _ =
1255 List.foreach
1256 (rest, fn f =>
1257 if List.exists ([".c", ".o", ".s", ".S"], fn suffix =>
1258 String.hasSuffix (f, {suffix = suffix}))
1259 then File.withIn (f, fn _ => ())
1260 else usage (concat ["invalid file suffix: ", f]))
1261 val csoFiles = rest
1262 in
1263 case Place.compare (start, stop) of
1264 GREATER => usage (concat ["cannot go from ", Place.toString start,
1265 " to ", Place.toString stop])
1266 | EQUAL => usage "nothing to do"
1267 | LESS =>
1268 let
1269 val _ =
1270 if !verbosity = Top
1271 then printVersion Out.error
1272 else ()
1273 val tempFiles: File.t list ref = ref []
1274 val tmpDir =
1275 let
1276 val (tmpVar, default) =
1277 case MLton.Platform.OS.host of
1278 MinGW => ("TEMP", "C:/WINDOWS/TEMP")
1279 | _ => ("TMPDIR", "/tmp")
1280 in
1281 case Process.getEnv tmpVar of
1282 NONE => default
1283 | SOME d => d
1284 end
1285 fun temp (suf: string): File.t =
1286 let
1287 val (f, out) =
1288 File.temp {prefix = OS.Path.concat (tmpDir, "file"),
1289 suffix = suf}
1290 val _ = Out.close out
1291 val _ = List.push (tempFiles, f)
1292 in
1293 f
1294 end
1295 fun suffix s = concat [base, s]
1296 fun maybeOut suf =
1297 case !output of
1298 NONE => suffix suf
1299 | SOME f => f
1300 fun maybeOutBase suf =
1301 case !output of
1302 NONE => suffix suf
1303 | SOME f => if File.extension f = SOME "exe"
1304 then concat [File.base f, suf]
1305 else concat [f, suf]
1306 val {base = outputBase, ...} =
1307 OS.Path.splitBaseExt (maybeOut ".ext")
1308 val {file = defLibname, ...} =
1309 OS.Path.splitDirFile outputBase
1310 val defLibname =
1311 if String.hasPrefix (defLibname, {prefix = "lib"})
1312 then String.extract (defLibname, 3, NONE)
1313 else defLibname
1314 fun toAlNum c = if Char.isAlphaNum c then c else #"_"
1315 val () =
1316 if !libname <> "" then () else
1317 libname := CharVector.map toAlNum defLibname
1318 (* Library output includes a header by default *)
1319 val () =
1320 case (!format, !exportHeader) of
1321 (Executable, _) => ()
1322 | (_, NONE) => exportHeader := SOME (!libname ^ ".h")
1323 | _ => ()
1324 val _ =
1325 atMLtons :=
1326 Vector.fromList
1327 (tokenize (rev ("--" :: (!runtimeArgs))))
1328 val (ccDebug, asDebug) = (["-g", "-DASSERT=1"], "-Wa,-g")
1329 fun compileO (inputs: File.t list): unit =
1330 let
1331 val output =
1332 case (!format, targetOS) of
1333 (Archive, _) => maybeOut ".a"
1334 | (Executable, _) => maybeOut ""
1335 | (LibArchive, _) => maybeOut ".a"
1336 | (Library, Darwin) => maybeOut ".dylib"
1337 | (Library, Cygwin) => !libname ^ ".dll"
1338 | (Library, MinGW) => !libname ^ ".dll"
1339 | (Library, _) => maybeOut ".so"
1340 val libOpts =
1341 case targetOS of
1342 Darwin => [ "-dynamiclib" ]
1343 | Cygwin => [ "-shared",
1344 "-Wl,--out-implib," ^
1345 maybeOut ".a",
1346 "-Wl,--output-def," ^
1347 !libname ^ ".def"]
1348 | MinGW => [ "-shared",
1349 "-Wl,--out-implib," ^
1350 maybeOut ".a",
1351 "-Wl,--output-def," ^
1352 !libname ^ ".def"]
1353 | _ => [ "-shared" ]
1354 val _ =
1355 trace (Top, "Link")
1356 (fn () =>
1357 if !format = Archive orelse
1358 !format = LibArchive
1359 then System.system
1360 (arScript,
1361 List.concat
1362 [[targetStr, targetOSStr, output],
1363 inputs,
1364 linkArchives])
1365 else System.system
1366 (hd cc,
1367 List.concat
1368 [tl cc,
1369 if !format = Library then libOpts else [],
1370 ["-o", output],
1371 inputs,
1372 linkOpts]))
1373 ()
1374 (* gcc on Cygwin appends .exe, which I don't want, so
1375 * move the output file to it's rightful place.
1376 * Notice that we do not use targetOS here, since we
1377 * care about the platform we're running on, not the
1378 * platform we're generating for.
1379 *
1380 * We want to keep the .exe as is for MinGW/Win32.
1381 *)
1382 val _ =
1383 if MLton.Platform.OS.host = Cygwin
1384 then
1385 if String.contains (output, #".")
1386 then ()
1387 else
1388 File.move {from = concat [output, ".exe"],
1389 to = output}
1390 else ()
1391 in
1392 ()
1393 end
1394 fun mkOutputO (c: Counter.t, input: File.t): File.t =
1395 if stop = Place.O orelse !keepO
1396 then
1397 if File.dirOf input = File.dirOf (maybeOutBase ".o")
1398 then
1399 concat [File.base input, ".o"]
1400 else
1401 maybeOutBase
1402 (concat [".",
1403 Int.toString (Counter.next c),
1404 ".o"])
1405 else temp ".o"
1406 fun mkOutputBC (c: Counter.t, input: File.t, xsuf): File.t =
1407 if stop = Place.O orelse !keepO
1408 then
1409 if File.dirOf input = File.dirOf (maybeOutBase (xsuf ^ ".bc"))
1410 then
1411 concat [File.base input, xsuf, ".bc"]
1412 else
1413 maybeOutBase
1414 (concat [".",
1415 Int.toString (Counter.next c),
1416 xsuf,
1417 ".bc"])
1418 else temp (xsuf ^ ".bc")
1419 fun compileC (c: Counter.t, input: File.t): File.t =
1420 let
1421 val output = mkOutputO (c, input)
1422 val _ =
1423 System.system
1424 (hd cc,
1425 List.concat
1426 [tl cc,
1427 [ "-c" ],
1428 if !format = Executable
1429 then [] else [ "-DLIBNAME=" ^ !libname ],
1430 if positionIndependent
1431 then [ "-fPIC", "-DPIC" ] else [],
1432 if !debug then ccDebug else [],
1433 ccOpts,
1434 ["-o", output],
1435 [input]])
1436 in
1437 output
1438 end
1439 fun compileS (c: Counter.t, input: File.t): File.t =
1440 let
1441 val output = mkOutputO (c, input)
1442 val _ =
1443 System.system
1444 (hd cc,
1445 List.concat
1446 [tl cc,
1447 ["-c"],
1448 if !debug then [asDebug] else [],
1449 asOpts,
1450 ["-o", output],
1451 [input]])
1452 in
1453 output
1454 end
1455 fun compileLL (c: Counter.t, input: File.t): File.t =
1456 let
1457 val asBC = mkOutputBC (c, input, ".as")
1458 val _ =
1459 System.system
1460 (llvm_as,
1461 List.concat
1462 [llvm_asOpts,
1463 ["-o", asBC],
1464 [input]])
1465 val optBC = mkOutputBC (c, input, ".opt")
1466 val _ =
1467 System.system
1468 (llvm_opt,
1469 List.concat
1470 [llvm_optOpts,
1471 ["-o", optBC],
1472 [asBC]])
1473 val output = mkOutputO (c, input)
1474 val _ =
1475 System.system
1476 (llvm_llc,
1477 List.concat
1478 [llvm_llcOpts,
1479 ["-filetype=obj"],
1480 ["-o", output],
1481 [optBC]])
1482 in
1483 output
1484 end
1485 fun compileCSO (inputs: File.t list): unit =
1486 if List.forall (inputs, fn f =>
1487 SOME "o" = File.extension f)
1488 then compileO inputs
1489 else
1490 let
1491 val c = Counter.new 0
1492 val oFiles =
1493 trace (Top, "Compile and Assemble")
1494 (fn () =>
1495 List.fold
1496 (inputs, [], fn (input, ac) =>
1497 let
1498 val extension = File.extension input
1499 in
1500 if SOME "o" = extension
1501 then input :: ac
1502 else if SOME "c" = extension
1503 then (compileC (c, input)) :: ac
1504 else if SOME "ll" = extension
1505 then (compileLL(c, input)) :: ac
1506 else if SOME "s" = extension
1507 orelse SOME "S" = extension
1508 then (compileS (c, input)) :: ac
1509 else Error.bug
1510 (concat
1511 ["invalid extension: ",
1512 Option.toString (fn s => s) extension])
1513 end))
1514 ()
1515 in
1516 case stop of
1517 Place.O => ()
1518 | _ => compileO (rev oFiles)
1519 end
1520 fun mkCompileSrc {listFiles, elaborate, compile} input =
1521 let
1522 val outputs: File.t list ref = ref []
1523 val r = ref 0
1524 fun make (style: style, suf: string) () =
1525 let
1526 val suf = concat [".", Int.toString (!r), suf]
1527 val _ = Int.inc r
1528 val file = (if !keepGenerated
1529 orelse stop = Place.Generated
1530 then maybeOutBase
1531 else temp) suf
1532 val _ = List.push (outputs, file)
1533 val out = Out.openOut file
1534 fun print s = Out.output (out, s)
1535 val _ = outputHeader' (style, out)
1536 fun done () = Out.close out
1537 in
1538 {file = file,
1539 print = print,
1540 done = done}
1541 end
1542 val _ =
1543 case !verbosity of
1544 Silent => ()
1545 | Top => ()
1546 | _ =>
1547 outputHeader
1548 (Control.No, fn l =>
1549 let val out = Out.error
1550 in Layout.output (l, out)
1551 ; Out.newline out
1552 end)
1553 val _ =
1554 case stop of
1555 Place.Files =>
1556 Vector.foreach
1557 (listFiles {input = input}, fn f =>
1558 (print (String.translate
1559 (f, fn #"\\" => "/" | c => str c))
1560 ; print "\n"))
1561 | Place.TypeCheck =>
1562 trace (Top, "Type Check SML")
1563 elaborate
1564 {input = input}
1565 | _ =>
1566 trace (Top, "Compile SML")
1567 compile
1568 {input = input,
1569 outputC = make (Control.C, ".c"),
1570 outputLL = make (Control.LLVM, ".ll"),
1571 outputS = make (Control.Assembly, ".s")}
1572 in
1573 case stop of
1574 Place.Files => ()
1575 | Place.TypeCheck => ()
1576 | Place.Generated => ()
1577 | _ =>
1578 (* Shrink the heap before calling C compiler. *)
1579 (MLton.GC.pack ()
1580 ; compileCSO (List.concat [!outputs, csoFiles]))
1581 end
1582 val compileSML =
1583 mkCompileSrc {listFiles = fn {input} => Vector.fromList input,
1584 elaborate = Compile.elaborateSML,
1585 compile = Compile.compileSML}
1586 val compileMLB =
1587 mkCompileSrc {listFiles = Compile.sourceFilesMLB,
1588 elaborate = Compile.elaborateMLB,
1589 compile = Compile.compileMLB}
1590 val compileSXML =
1591 mkCompileSrc {listFiles = fn {input} => Vector.new1 input,
1592 elaborate = fn _ => raise Fail "Unimplemented",
1593 compile = Compile.compileSXML}
1594 fun compile () =
1595 case start of
1596 Place.SML => compileSML [input]
1597 | Place.MLB => compileMLB input
1598 | Place.Generated => compileCSO (input :: csoFiles)
1599 | Place.O => compileCSO (input :: csoFiles)
1600 | Place.SXML => compileSXML input
1601 | _ => Error.bug "invalid start"
1602 val doit
1603 = trace (Top, "MLton")
1604 (fn () =>
1605 Exn.finally
1606 (compile, fn () =>
1607 List.foreach (!tempFiles, File.remove)))
1608 in
1609 doit ()
1610 end
1611 end
1612 end
1613
1614val commandLine = Process.makeCommandLine commandLine
1615
1616val main = fn (_, args) => commandLine args
1617
1618val mainWrapped = fn () => OS.Process.exit (commandLine (CommandLine.arguments ()))
1619
1620end
mlton packaging