[MLton] Option to show path map
Vesa Karvonen
vesa.karvonen at cs.helsinki.fi
Thu Dec 28 16:02:27 PST 2006
Quoting Stephen Weeks <sweeks at sweeks.com>:
[...]
> > I'd vote for -save-{basis,def-use}. As -show-{anns,path-map} are mutually
> > exclusive (the first one exits), it might be better to have a single option
> >
> > -show {anns|path-map}
>
> Both sound good to me.
Below is a patch that implements the
-show {anns,path-map}
option and deprecates the
-show-anns {false|true}
option.
Shall I commit the below patch?
What is the policy for the changelog file? If I commit the below patch,
should I also add an entry to the changelog?
-Vesa Karvonen
Index: mlton/control/control-flags.sig
===================================================================
--- mlton/control/control-flags.sig (revision 5003)
+++ mlton/control/control-flags.sig (working copy)
@@ -195,6 +195,8 @@
val maxFunctionSize: int ref
val mlbPathMaps: string list ref
+ val mlbPathMap: unit -> {var: string,
+ path: string} list
structure Native:
sig
Index: mlton/control/control-flags.sml
===================================================================
--- mlton/control/control-flags.sml (revision 5003)
+++ mlton/control/control-flags.sml (working copy)
@@ -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}
Index: mlton/main/main.fun
===================================================================
--- mlton/main/main.fun (revision 5003)
+++ mlton/main/main.fun (working copy)
@@ -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,12 +456,24 @@
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", " {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",
SpaceString (fn s => showDefUse := SOME s)),
+ (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-types", " {false|true}", "show types in ILs",
boolRef showTypes),
(Expert, "ssa-passes", " <passes>", "ssa optimization passes",
@@ -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
Index: mlton/front-end/mlb-front-end.fun
===================================================================
--- mlton/front-end/mlb-front-end.fun (revision 5003)
+++ mlton/front-end/mlb-front-end.fun (working copy)
@@ -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
More information about the MLton
mailing list