[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