[MLton-commit] r5004
Vesa Karvonen
vesak at mlton.org
Thu Dec 28 16:53:54 PST 2006
Added command line switch -show {anns|path-map} and deprecated command
line switch -show-anns {false|true}. Use -show path-map to see the
complete MLB path map as seen by the compiler.
----------------------------------------------------------------------
U mlton/trunk/doc/changelog
U mlton/trunk/mlton/control/control-flags.sig
U mlton/trunk/mlton/control/control-flags.sml
U mlton/trunk/mlton/front-end/mlb-front-end.fun
U mlton/trunk/mlton/main/main.fun
----------------------------------------------------------------------
Modified: mlton/trunk/doc/changelog
===================================================================
--- mlton/trunk/doc/changelog 2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/doc/changelog 2006-12-29 00:53:36 UTC (rev 5004)
@@ -1,5 +1,15 @@
Here are the changes since version 20051202.
+* 2006-12-29
+ - Added command line switch -show {anns|path-map} and deprecated command
+ line switch -show-anns {false|true}. Use -show path-map to see the
+ complete MLB path map as seen by the compiler.
+
+* 2006-12-20
+ - Changed the output of command line switch -stop f to include mlb-files.
+ This is useful for generating Makefile dependencies. The old output is
+ easy to recover if necessary (e.g. grep -v '\.mlb$').
+
* 2006-12-8
- Added command line switches -{,target}-{as,cc,link}-opt-quote, which
pass their argument as a single argument to gcc (i.e., without
Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig 2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/control/control-flags.sig 2006-12-29 00:53:36 UTC (rev 5004)
@@ -195,6 +195,8 @@
val maxFunctionSize: int ref
val mlbPathMaps: string list ref
+ val mlbPathMap: unit -> {var: string,
+ path: string} list
structure Native:
sig
Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml 2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/control/control-flags.sml 2006-12-29 00:53:36 UTC (rev 5004)
@@ -991,6 +991,49 @@
default = Linux,
toString = MLton.Platform.OS.toString}
+local
+ fun make (file: File.t) =
+ if not (File.canRead file) then
+ Error.bug (concat ["can't read MLB path map file: ", file])
+ else
+ List.keepAllMap
+ (File.lines file, fn line =>
+ if String.forall (line, Char.isSpace)
+ then NONE
+ else
+ case String.tokens (line, Char.isSpace) of
+ [var, path] => SOME {var = var, path = path}
+ | _ => Error.bug (concat ["strange mlb path mapping: ",
+ file, ":: ", line]))
+in
+ fun mlbPathMap () =
+ List.rev
+ (List.concat
+ [[{var = "LIB_MLTON_DIR",
+ path = !libDir},
+ {var = "TARGET_ARCH",
+ path = String.toLower (MLton.Platform.Arch.toString
+ (!targetArch))},
+ {var = "TARGET_OS",
+ path = String.toLower (MLton.Platform.OS.toString
+ (!targetOS))},
+ {var = "OBJPTR_REP",
+ path = "objptr-rep32.sml"},
+ {var = "HEADER_WORD",
+ path = "header-word32.sml"},
+ {var = "SEQINDEX_INT",
+ path = "seqindex-int32.sml"},
+ {var = "DEFAULT_CHAR",
+ path = concat ["default-", !defaultChar, ".sml"]},
+ {var = "DEFAULT_INT",
+ path = concat ["default-", !defaultInt, ".sml"]},
+ {var = "DEFAULT_REAL",
+ path = concat ["default-", !defaultReal, ".sml"]},
+ {var = "DEFAULT_WORD",
+ path = concat ["default-", !defaultWord, ".sml"]}],
+ List.concat (List.map (!mlbPathMaps, make))])
+end
+
val typeCheck = control {name = "type check",
default = false,
toString = Bool.toString}
Modified: mlton/trunk/mlton/front-end/mlb-front-end.fun
===================================================================
--- mlton/trunk/mlton/front-end/mlb-front-end.fun 2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/front-end/mlb-front-end.fun 2006-12-29 00:53:36 UTC (rev 5004)
@@ -84,46 +84,8 @@
val psi : (File.t * Ast.Basdec.t Promise.t) HashSet.t =
HashSet.new {hash = String.hash o #1}
local
- fun make (file: File.t) =
- if not (File.canRead file) then
- Error.bug (concat ["can't read MLB path map file: ", file])
- else
- List.keepAllMap
- (File.lines file, fn line =>
- if String.forall (line, Char.isSpace)
- then NONE
- else
- case String.tokens (line, Char.isSpace) of
- [var, path] => SOME {var = var, path = path}
- | _ => Error.bug (concat ["strange mlb path mapping: ",
- file, ":: ", line]))
val pathMap =
- List.rev
- (List.concat
- [[{var = "LIB_MLTON_DIR",
- path = !Control.libDir},
- {var = "TARGET_ARCH",
- path = String.toLower (MLton.Platform.Arch.toString
- (!Control.targetArch))},
- {var = "TARGET_OS",
- path = String.toLower (MLton.Platform.OS.toString
- (!Control.targetOS))},
- {var = "OBJPTR_REP",
- path = "objptr-rep32.sml"},
- {var = "HEADER_WORD",
- path = "header-word32.sml"},
- {var = "SEQINDEX_INT",
- path = "seqindex-int32.sml"},
- {var = "DEFAULT_CHAR",
- path = concat ["default-", !Control.defaultChar, ".sml"]},
- {var = "DEFAULT_INT",
- path = concat ["default-", !Control.defaultInt, ".sml"]},
- {var = "DEFAULT_REAL",
- path = concat ["default-", !Control.defaultReal, ".sml"]},
- {var = "DEFAULT_WORD",
- path = concat ["default-", !Control.defaultWord, ".sml"]}],
- List.concat (List.map (!Control.mlbPathMaps, make))])
-
+ Control.mlbPathMap ()
fun peekPathMap var' =
case List.peek (pathMap, fn {var,...} =>
var = var') of
Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun 2006-12-28 22:26:34 UTC (rev 5003)
+++ mlton/trunk/mlton/main/main.fun 2006-12-29 00:53:36 UTC (rev 5004)
@@ -47,6 +47,11 @@
| Yes
end
+structure Show =
+ struct
+ datatype t = Anns | PathMap
+ end
+
val gcc: string ref = ref "<unset>"
val asOpts: {opt: string, pred: OptPred.t} list ref = ref []
val ccOpts: {opt: string, pred: OptPred.t} list ref = ref []
@@ -65,7 +70,7 @@
val profileSet: bool ref = ref false
val profileTimeSet: bool ref = ref false
val runtimeArgs: string list ref = ref ["@MLton"]
-val showAnns: bool ref = ref false
+val show: Show.t option ref = ref NONE
val stop = ref Place.OUT
val targetMap: unit -> {arch: MLton.Platform.Arch.t,
@@ -451,8 +456,20 @@
boolRef profileStack),
(Normal, "runtime", " <arg>", "pass arg to runtime via @MLton",
SpaceString (fn s => List.push (runtimeArgs, s))),
- (Expert, "show-anns", " {false|true}", "show annotations",
- boolRef showAnns),
+ (Expert, "show", " {anns|path-map}", "print specified data and stop",
+ SpaceString
+ (fn s =>
+ show := SOME (case s of
+ "anns" => Show.Anns
+ | "path-map" => Show.PathMap
+ | _ => usage (concat ["invalid -show arg: ", s])))),
+ (Expert, "show-anns", " {false|true}", "deprecated (use -show anns)",
+ Bool
+ (fn b =>
+ (if b then show := SOME Show.Anns else ()
+ ; Out.output
+ (Out.error,
+ "Warning: deprecated option: -show-anns. Use -show anns.\n")))),
(Normal, "show-basis", " <file>", "write out the final basis environment",
SpaceString (fn s => showBasis := SOME s)),
(Normal, "show-def-use", " <file>", "write def-use information",
@@ -583,11 +600,24 @@
| SOME c => c)
val () = MLton.Rusage.measureGC (!verbosity <> Silent)
val () =
- if !showAnns then
- (Layout.outputl (Control.Elaborate.document {expert = !expert},
- Out.standard)
+ case !show of
+ NONE => ()
+ | SOME info =>
+ (case info of
+ Show.Anns =>
+ Layout.outputl (Control.Elaborate.document {expert = !expert},
+ Out.standard)
+ | Show.PathMap =>
+ let
+ open Layout
+ in
+ outputl (align
+ (List.map (Control.mlbPathMap (),
+ fn {var, path, ...} =>
+ str (concat [var, " ", path]))),
+ Out.standard)
+ end
; let open OS.Process in exit success end)
- else ()
val () = if !profileTimeSet
then (case !codegen of
Native => profile := ProfileTimeLabel
More information about the MLton-commit
mailing list