[MLton-commit] r6754
Matthew Fluet
fluet at mlton.org
Tue Aug 19 15:15:02 PDT 2008
Changed the implementation of -opt-passes and related expert options.
Choose sets of optimization passes by either a string name or a string
describing the optimization passes. This makes it a little easier to
define new sets of optimization passes for an IL and use then via the
appropriate -il-passes option.
----------------------------------------------------------------------
U mlton/trunk/mlton/control/control-flags.sig
U mlton/trunk/mlton/control/control-flags.sml
U mlton/trunk/mlton/main/main.fun
U mlton/trunk/mlton/ssa/simplify.fun
U mlton/trunk/mlton/ssa/simplify2.fun
U mlton/trunk/mlton/xml/sxml-simplify.fun
U mlton/trunk/mlton/xml/xml-simplify.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig 2008-08-19 22:14:55 UTC (rev 6753)
+++ mlton/trunk/mlton/control/control-flags.sig 2008-08-19 22:15:00 UTC (rev 6754)
@@ -52,8 +52,6 @@
val contifyIntoMain: bool ref
- val cpsTransform: bool ref
-
(* Generate an executable with debugging info. *)
val debug: bool ref
@@ -263,12 +261,8 @@
val split: int option ref
end
- datatype optimizationPasses =
- OptPassesCustom of string
- | OptPassesDefault
- | OptPassesMinimal
- val optimizationPassesSet:
- (string * (optimizationPasses -> unit Result.t)) list ref
+ val optimizationPasses:
+ {il: string, set: string -> unit Result.t, get: unit -> string} list ref
(* Only duplicate big functions when
* (size - small) * (number of occurrences - 1) <= product
@@ -322,16 +316,6 @@
(* Should types be printed in ILs. *)
val showTypes: bool ref
- (* SSA Passes *)
- val ssaPassesSet: (optimizationPasses -> unit Result.t) ref
- val ssaPasses: string list ref
- val ssa2PassesSet: (optimizationPasses -> unit Result.t) ref
- val ssa2Passes: string list ref
-
- (* SXML Passes *)
- val sxmlPassesSet: (optimizationPasses -> unit Result.t) ref
- val sxmlPasses: string list ref
-
datatype target =
Cross of string
| Self
@@ -384,10 +368,6 @@
val warnAnn: bool ref
- (* XML Passes *)
- val xmlPassesSet: (optimizationPasses -> unit Result.t) ref
- val xmlPasses: string list ref
-
val zoneCutDepth: int ref
(*------------------------------------*)
Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml 2008-08-19 22:14:55 UTC (rev 6753)
+++ mlton/trunk/mlton/control/control-flags.sml 2008-08-19 22:15:00 UTC (rev 6754)
@@ -81,10 +81,6 @@
default = false,
toString = Bool.toString}
-val cpsTransform = control {name = "cpsTransform",
- default = false,
- toString = Bool.toString}
-
val debug = control {name = "debug",
default = false,
toString = Bool.toString}
@@ -825,31 +821,12 @@
toString = Option.toString Int.toString}
end
-structure OptimizationPasses =
- struct
- datatype t =
- OptPassesCustom of string
- | OptPassesDefault
- | OptPassesMinimal
-
-(*
- local open Layout
- in
- val layout =
- fn OptPassesCustom s => seq [str "Limit: ", str s]
- | OptPassesDefault => str "Default"
- | OptPassesMinimal => str "Minimal"
- end
- val toString = Layout.toString o layout
-*)
- end
-datatype optimizationPasses = datatype OptimizationPasses.t
-val optimizationPassesSet :
- (string * (optimizationPasses -> unit Result.t)) list ref =
- control {name = "optimizationPassesSet",
+val optimizationPasses:
+ {il: string, set: string -> unit Result.t, get: unit -> string} list ref =
+ control {name = "optimizationPasses",
default = [],
toString = List.toString
- (fn (s,_) => concat ["<",s,"PassesSet>"])}
+ (fn {il,get,...} => concat ["<",il,"::",get (),">"])}
val polyvariance =
control {name = "polyvariance",
@@ -966,32 +943,6 @@
default = true,
toString = Bool.toString}
-val ssaPassesSet : (optimizationPasses -> unit Result.t) ref =
- control {name = "ssaPassesSet",
- default = fn _ => Error.bug ("ControlFlags.ssaPassesSet: not installed"),
- toString = fn _ => "<ssaPassesSet>"}
-val ssaPasses : string list ref =
- control {name = "ssaPasses",
- default = ["default"],
- toString = List.toString String.toString}
-val ssa2PassesSet : (optimizationPasses -> unit Result.t) ref =
- control {name = "ssa2PassesSet",
- default = fn _ => Error.bug ("ControlFlags.ssa2PassesSet: not installed"),
- toString = fn _ => "<ssa2PassesSet>"}
-val ssa2Passes : string list ref =
- control {name = "ssa2Passes",
- default = ["default"],
- toString = List.toString String.toString}
-
-val sxmlPassesSet : (optimizationPasses -> unit Result.t) ref =
- control {name = "sxmlPassesSet",
- default = fn _ => Error.bug ("ControlFlags.sxmlPassesSet: not installed"),
- toString = fn _ => "<sxmlPassesSet>"}
-val sxmlPasses : string list ref =
- control {name = "sxmlPasses",
- default = ["default"],
- toString = List.toString String.toString}
-
structure Target =
struct
datatype t =
@@ -1128,15 +1079,6 @@
default = true,
toString = Bool.toString}
-val xmlPassesSet: (optimizationPasses -> unit Result.t) ref =
- control {name = "xmlPassesSet",
- default = fn _ => Error.bug ("ControlFlags.xmlPassesSet: not installed"),
- toString = fn _ => "<xmlPassesSet>"}
-val xmlPasses: string list ref =
- control {name = "xmlPasses",
- default = ["default"],
- toString = List.toString String.toString}
-
val zoneCutDepth: int ref =
control {name = "zone cut depth",
default = 100,
Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun 2008-08-19 22:14:55 UTC (rev 6753)
+++ mlton/trunk/mlton/main/main.fun 2008-08-19 22:15:00 UTC (rev 6754)
@@ -279,9 +279,6 @@
(Expert, "contify-into-main", " {false|true}",
"contify functions into main",
boolRef contifyIntoMain),
- (Expert, "cps-transform", " {false|true}",
- "perform cps transform on sxml il",
- boolRef cpsTransform),
(Expert, "debug", " {false|true}", "produce executable with debug info",
Bool (fn b => (debug := b
; debugRuntime := b))),
@@ -522,17 +519,12 @@
let
fun err s =
usage (concat ["invalid -opt-passes flag: ", s])
- fun doit optPasses =
- List.foreach
- (!optimizationPassesSet, fn (_,optPassesSet) =>
- case optPassesSet optPasses of
- Result.Yes () => ()
- | Result.No s' => err ("il :: " ^ s'))
in
- case s of
- "default" => doit OptPassesDefault
- | "minimal" => doit OptPassesMinimal
- | _ => err s
+ List.foreach
+ (!optimizationPasses, fn {il,set,...} =>
+ case set s of
+ Result.Yes () => ()
+ | Result.No s' => err (concat [s', "(for ", il, ")"]))
end)),
(Normal, "output", " <file>", "name of output file",
SpaceString (fn s => output := SOME s)),
@@ -686,15 +678,23 @@
(Expert, "ssa-passes", " <passes>", "ssa optimization passes",
SpaceString
(fn s =>
- case !Control.ssaPassesSet (OptPassesCustom s) of
- Result.Yes () => ()
- | Result.No s' => usage (concat ["invalid -ssa-pass arg: ", s']))),
+ case List.peek (!Control.optimizationPasses,
+ fn {il, ...} => String.equals ("ssa", il)) of
+ SOME {set, ...} =>
+ (case set s of
+ Result.Yes () => ()
+ | Result.No s' => usage (concat ["invalid -ssa-passes arg: ", s']))
+ | NONE => Error.bug "ssa optimization passes missing")),
(Expert, "ssa2-passes", " <passes>", "ssa2 optimization passes",
SpaceString
(fn s =>
- case !Control.ssa2PassesSet (OptPassesCustom s) of
- Result.Yes () => ()
- | Result.No s' => usage (concat ["invalid -ssa2-pass arg: ", s']))),
+ case List.peek (!Control.optimizationPasses,
+ fn {il, ...} => String.equals ("ssa2", il)) of
+ SOME {set, ...} =>
+ (case set s of
+ Result.Yes () => ()
+ | Result.No s' => usage (concat ["invalid -ssa2-passes arg: ", s']))
+ | NONE => Error.bug "ssa2 optimization passes missing")),
(Normal, "stop", " {f|g|o|sml|tc}", "when to stop",
SpaceString
(fn s =>
@@ -708,9 +708,13 @@
(Expert, "sxml-passes", " <passes>", "sxml optimization passes",
SpaceString
(fn s =>
- case !Control.sxmlPassesSet (OptPassesCustom s) of
- Result.Yes () => ()
- | Result.No s' => usage (concat ["invalid -sxml-pass arg: ", s']))),
+ case List.peek (!Control.optimizationPasses,
+ fn {il, ...} => String.equals ("sxml", il)) of
+ SOME {set, ...} =>
+ (case set s of
+ Result.Yes () => ()
+ | Result.No s' => usage (concat ["invalid -sxml-passes arg: ", s']))
+ | NONE => Error.bug "sxml optimization passes missing")),
(Normal, "target",
concat [" {",
(case targetMap () of
@@ -765,9 +769,13 @@
(Expert, "xml-passes", " <passes>", "xml optimization passes",
SpaceString
(fn s =>
- case !Control.xmlPassesSet (OptPassesCustom s) of
- Result.Yes () => ()
- | Result.No s' => usage (concat ["invalid -xml-pass arg: ", s']))),
+ case List.peek (!Control.optimizationPasses,
+ fn {il, ...} => String.equals ("xml", il)) of
+ SOME {set, ...} =>
+ (case set s of
+ Result.Yes () => ()
+ | Result.No s' => usage (concat ["invalid -xml-passes arg: ", s']))
+ | NONE => Error.bug "xml optimization passes missing")),
(Expert, "zone-cut-depth", " <n>", "zone cut depth",
intRef zoneCutDepth)
],
Modified: mlton/trunk/mlton/ssa/simplify.fun
===================================================================
--- mlton/trunk/mlton/ssa/simplify.fun 2008-08-19 22:14:55 UTC (rev 6753)
+++ mlton/trunk/mlton/ssa/simplify.fun 2008-08-19 22:15:00 UTC (rev 6754)
@@ -210,7 +210,7 @@
("reverseFunctions",S.reverseFunctions),
("shrink", S.shrink)],
mkSimplePassGen))
-
+in
fun ssaPassesSetCustom s =
Exn.withEscape
(fn esc =>
@@ -221,25 +221,26 @@
case (List.peekMap (passGens, fn gen => gen s)) of
NONE => esc (Result.No s)
| SOME pass => pass)
- ; Control.ssaPasses := ss
; Result.Yes ()
end))
-
- datatype t = datatype Control.optimizationPasses
- fun ssaPassesSet opt =
- case opt of
- OptPassesDefault => (ssaPasses := ssaPassesDefault
- ; Control.ssaPasses := ["default"]
- ; Result.Yes ())
- | OptPassesMinimal => (ssaPasses := ssaPassesMinimal
- ; Control.ssaPasses := ["minimal"]
- ; Result.Yes ())
- | OptPassesCustom s => ssaPassesSetCustom s
-in
- val _ = Control.ssaPassesSet := ssaPassesSet
- val _ = List.push (Control.optimizationPassesSet, ("ssa", ssaPassesSet))
end
+val ssaPassesString = ref "default"
+val ssaPassesGet = fn () => !ssaPassesString
+val ssaPassesSet = fn s =>
+ let
+ val _ = ssaPassesString := s
+ in
+ case s of
+ "default" => (ssaPasses := ssaPassesDefault
+ ; Result.Yes ())
+ | "minimal" => (ssaPasses := ssaPassesMinimal
+ ; Result.Yes ())
+ | _ => ssaPassesSetCustom s
+ end
+val _ = List.push (Control.optimizationPasses,
+ {il = "ssa", get = ssaPassesGet, set = ssaPassesSet})
+
fun pass ({name, doit, midfix}, p) =
let
val _ =
Modified: mlton/trunk/mlton/ssa/simplify2.fun
===================================================================
--- mlton/trunk/mlton/ssa/simplify2.fun 2008-08-19 22:14:55 UTC (rev 6753)
+++ mlton/trunk/mlton/ssa/simplify2.fun 2008-08-19 22:15:00 UTC (rev 6754)
@@ -74,7 +74,7 @@
("reverseFunctions",S.reverseFunctions),
("shrink", S.shrink)],
mkSimplePassGen)
-
+in
fun ssa2PassesSetCustom s =
Exn.withEscape
(fn esc =>
@@ -85,25 +85,26 @@
case (List.peekMap (passGens, fn gen => gen s)) of
NONE => esc (Result.No s)
| SOME pass => pass)
- ; Control.ssa2Passes := ss
; Result.Yes ()
end))
-
- datatype t = datatype Control.optimizationPasses
- fun ssa2PassesSet opt =
- case opt of
- OptPassesDefault => (ssa2Passes := ssa2PassesDefault
- ; Control.ssa2Passes := ["default"]
- ; Result.Yes ())
- | OptPassesMinimal => (ssa2Passes := ssa2PassesMinimal
- ; Control.ssa2Passes := ["minimal"]
- ; Result.Yes ())
- | OptPassesCustom s => ssa2PassesSetCustom s
-in
- val _ = Control.ssa2PassesSet := ssa2PassesSet
- val _ = List.push (Control.optimizationPassesSet, ("ssa2", ssa2PassesSet))
end
+val ssa2PassesString = ref "default"
+val ssa2PassesGet = fn () => !ssa2PassesString
+val ssa2PassesSet = fn s =>
+ let
+ val _ = ssa2PassesString := s
+ in
+ case s of
+ "default" => (ssa2Passes := ssa2PassesDefault
+ ; Result.Yes ())
+ | "minimal" => (ssa2Passes := ssa2PassesMinimal
+ ; Result.Yes ())
+ | _ => ssa2PassesSetCustom s
+ end
+val _ = List.push (Control.optimizationPasses,
+ {il = "ssa2", get = ssa2PassesGet, set = ssa2PassesSet})
+
fun pass ({name, doit, midfix}, p) =
let
val _ =
Modified: mlton/trunk/mlton/xml/sxml-simplify.fun
===================================================================
--- mlton/trunk/mlton/xml/sxml-simplify.fun 2008-08-19 22:14:55 UTC (rev 6753)
+++ mlton/trunk/mlton/xml/sxml-simplify.fun 2008-08-19 22:15:00 UTC (rev 6754)
@@ -24,45 +24,31 @@
fn () => Polyvariance.duplicate p)
type pass = {name: string,
- enable: unit -> bool,
doit: Program.t -> Program.t}
val sxmlPassesDefault =
- {name = "sxmlShrink1",
- enable = fn () => true, doit = S.shrink} ::
- {name = "implementSuffix",
- enable = fn () => true, doit = ImplementSuffix.doit} ::
- {name = "sxmlShrink2",
- enable = fn () => true, doit = S.shrink} ::
- {name = "implementExceptions",
- enable = fn () => true, doit = ImplementExceptions.doit} ::
- {name = "sxmlShrink3",
- enable = fn () => true, doit = S.shrink} ::
-(*
- {name = "uncurry",
- enable = fn () => true, doit = Uncurry.uncurry} ::
- {name = "sxmlShrink4",
- enable = fn () => true, doit = S.shrink} ::
-*)
- {name = "polyvariance",
- enable = fn () => true, doit = Polyvariance.duplicate} ::
- {name = "sxmlShrink4",
- enable = fn () => true, doit = S.shrink} ::
- {name = "cpsTransform",
- enable = fn () => !Control.cpsTransform, doit = CPSTransform.doit} ::
- {name = "cpsSxmlShrink5",
- enable = fn () => !Control.cpsTransform, doit = S.shrink} ::
- {name = "cpsPolyvariance",
- enable = fn () => !Control.cpsTransform, doit = Polyvariance.duplicate} ::
- {name = "cpsSxmlShrink6",
- enable = fn () => !Control.cpsTransform, doit = S.shrink} ::
+ {name = "sxmlShrink1", doit = S.shrink} ::
+ {name = "implementSuffix", doit = ImplementSuffix.doit} ::
+ {name = "sxmlShrink2", doit = S.shrink} ::
+ {name = "implementExceptions", doit = ImplementExceptions.doit} ::
+ {name = "sxmlShrink3", doit = S.shrink} ::
+ (* {name = "uncurry", doit = Uncurry.uncurry} :: *)
+ (* {name = "sxmlShrink4", doit = S.shrink} :: *)
+ {name = "polyvariance", doit = Polyvariance.duplicate} ::
+ {name = "sxmlShrink4", doit = S.shrink} ::
nil
+val sxmlPassesCpsTransform =
+ sxmlPassesDefault @
+ {name = "cpsTransform", doit = CPSTransform.doit} ::
+ {name = "cpsSxmlShrink5", doit = S.shrink} ::
+ {name = "cpsPolyvariance", doit = Polyvariance.duplicate} ::
+ {name = "cpsSxmlShrink6", doit = S.shrink} ::
+ nil
+
val sxmlPassesMinimal =
- {name = "implementSuffix",
- enable = fn () => true, doit = ImplementSuffix.doit} ::
- {name = "implementExceptions",
- enable = fn () => true, doit = ImplementExceptions.doit} ::
+ {name = "implementSuffix", doit = ImplementSuffix.doit} ::
+ {name = "implementExceptions", doit = ImplementExceptions.doit} ::
nil
val sxmlPasses : pass list ref = ref sxmlPassesDefault
@@ -75,7 +61,6 @@
in fn s => if s = name
then SOME {name = name ^ "#" ^
(Int.toString (Counter.next count)),
- enable = fn () => true,
doit = doit}
else NONE
end
@@ -111,7 +96,6 @@
Int.toString small, ",",
Int.toString product, ")#",
Int.toString (Counter.next count)],
- enable = fn () => true,
doit = polyvariance (hofo, rounds, small, product)}
val s = String.dropPrefix (s, String.size "polyvariance")
in
@@ -130,7 +114,7 @@
("implementExceptions", ImplementExceptions.doit),
("implementSuffix", ImplementSuffix.doit)],
mkSimplePassGen))
-
+in
fun sxmlPassesSetCustom s =
Exn.withEscape
(fn esc =>
@@ -141,25 +125,28 @@
case (List.peekMap (passGens, fn gen => gen s)) of
NONE => esc (Result.No s)
| SOME pass => pass)
- ; Control.sxmlPasses := ss
; Result.Yes ()
end))
-
- datatype t = datatype Control.optimizationPasses
- fun sxmlPassesSet opt =
- case opt of
- OptPassesDefault => (sxmlPasses := sxmlPassesDefault
- ; Control.sxmlPasses := ["default"]
- ; Result.Yes ())
- | OptPassesMinimal => (sxmlPasses := sxmlPassesMinimal
- ; Control.sxmlPasses := ["minimal"]
- ; Result.Yes ())
- | OptPassesCustom s => sxmlPassesSetCustom s
-in
- val _ = Control.sxmlPassesSet := sxmlPassesSet
- val _ = List.push (Control.optimizationPassesSet, ("sxml", sxmlPassesSet))
end
+val sxmlPassesString = ref "default"
+val sxmlPassesGet = fn () => !sxmlPassesString
+val sxmlPassesSet = fn s =>
+ let
+ val _ = sxmlPassesString := s
+ in
+ case s of
+ "default" => (sxmlPasses := sxmlPassesDefault
+ ; Result.Yes ())
+ | "cpsTransform" => (sxmlPasses := sxmlPassesCpsTransform
+ ; Result.Yes ())
+ | "minimal" => (sxmlPasses := sxmlPassesMinimal
+ ; Result.Yes ())
+ | _ => sxmlPassesSetCustom s
+ end
+val _ = List.push (Control.optimizationPasses,
+ {il = "sxml", get = sxmlPassesGet, set = sxmlPassesSet})
+
fun pass ({name, doit}, p) =
let
val _ =
@@ -181,10 +168,9 @@
in
p
end
-fun maybePass ({name, doit, enable}, p) =
+fun maybePass ({name, doit}, p) =
if List.exists (!Control.dropPasses, fn re =>
Regexp.Compiled.matchesAll (re, name))
- orelse not (enable ())
then p
else pass ({name = name, doit = doit}, p)
@@ -192,8 +178,8 @@
let
fun simplify' p =
List.fold
- (!sxmlPasses, p, fn ({name, doit, enable}, p) =>
- maybePass ({name = name, doit = doit, enable = enable}, p))
+ (!sxmlPasses, p, fn ({name, doit}, p) =>
+ maybePass ({name = name, doit = doit}, p))
val p = simplify' p
in
p
Modified: mlton/trunk/mlton/xml/xml-simplify.fun
===================================================================
--- mlton/trunk/mlton/xml/xml-simplify.fun 2008-08-19 22:14:55 UTC (rev 6753)
+++ mlton/trunk/mlton/xml/xml-simplify.fun 2008-08-19 22:15:00 UTC (rev 6754)
@@ -43,7 +43,7 @@
(List.map([("xmlShrink", S.shrink),
("xmlSimplifyTypes", SimplifyTypes.simplifyTypes)],
mkSimplePassGen))
-
+in
fun xmlPassesSetCustom s =
Exn.withEscape
(fn esc =>
@@ -54,25 +54,26 @@
case (List.peekMap (passGens, fn gen => gen s)) of
NONE => esc (Result.No s)
| SOME pass => pass)
- ; Control.xmlPasses := ss
; Result.Yes ()
end))
-
- datatype t = datatype Control.optimizationPasses
- fun xmlPassesSet opt =
- case opt of
- OptPassesDefault => (xmlPasses := xmlPassesDefault
- ; Control.xmlPasses := ["default"]
- ; Result.Yes ())
- | OptPassesMinimal => (xmlPasses := xmlPassesMinimal
- ; Control.xmlPasses := ["minimal"]
- ; Result.Yes ())
- | OptPassesCustom s => xmlPassesSetCustom s
-in
- val _ = Control.xmlPassesSet := xmlPassesSet
- val _ = List.push (Control.optimizationPassesSet, ("xml", xmlPassesSet))
end
+val xmlPassesString = ref "default"
+val xmlPassesGet = fn () => !xmlPassesString
+val xmlPassesSet = fn s =>
+ let
+ val _ = xmlPassesString := s
+ in
+ case s of
+ "default" => (xmlPasses := xmlPassesDefault
+ ; Result.Yes ())
+ | "minimal" => (xmlPasses := xmlPassesMinimal
+ ; Result.Yes ())
+ | _ => xmlPassesSetCustom s
+ end
+val _ = List.push (Control.optimizationPasses,
+ {il = "xml", get = xmlPassesGet, set = xmlPassesSet})
+
fun pass ({name, doit}, p) =
let
val _ =
More information about the MLton-commit
mailing list