[MLton-commit] r6725
Matthew Fluet
fluet at mlton.org
Tue Aug 19 15:11:21 PDT 2008
Regularize display of statistics with -verbose 3.
----------------------------------------------------------------------
U mlton/trunk/mlton/atoms/hash-type.fun
U mlton/trunk/mlton/backend/backend.fun
U mlton/trunk/mlton/control/control.sig
U mlton/trunk/mlton/control/control.sml
U mlton/trunk/mlton/main/compile.fun
U mlton/trunk/mlton/ssa/simplify.fun
U mlton/trunk/mlton/ssa/simplify2.fun
U mlton/trunk/mlton/ssa/ssa-tree.fun
U mlton/trunk/mlton/ssa/ssa-tree2.fun
U mlton/trunk/mlton/xml/polyvariance.fun
U mlton/trunk/mlton/xml/sxml-simplify.fun
U mlton/trunk/mlton/xml/xml-simplify.fun
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/atoms/hash-type.fun
===================================================================
--- mlton/trunk/mlton/atoms/hash-type.fun 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/atoms/hash-type.fun 2008-08-19 22:11:19 UTC (rev 6725)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -109,9 +109,9 @@
fun stats () =
let open Layout
- in align [seq [str "num distinct types = ",
+ in align [seq [str "num types in hash table = ",
Int.layout (HashSet.size table)],
- Control.sizeMessage ("hash table", table)]
+ Control.sizeMessage ("types hash table", table)]
end
end
Modified: mlton/trunk/mlton/backend/backend.fun
===================================================================
--- mlton/trunk/mlton/backend/backend.fun 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/backend/backend.fun 2008-08-19 22:11:19 UTC (rev 6725)
@@ -147,6 +147,7 @@
fun pass (name, doit, program) =
Control.passTypeCheck {display = Control.Layouts Rssa.Program.layouts,
name = name,
+ stats = R.Program.layoutStats,
style = Control.No,
suffix = "rssa",
thunk = fn () => doit program,
@@ -155,8 +156,6 @@
fun rssaSimplify p =
let
open Rssa
- fun stats p =
- Control.message (Control.Detail, fn () => Program.layoutStats p)
fun pass ({name, doit}, p) =
let
val _ =
@@ -168,13 +167,13 @@
end
val p =
Control.passTypeCheck
- {name = name,
+ {display = Control.Layouts Program.layouts,
+ name = name,
+ stats = Program.layoutStats,
+ style = Control.No,
suffix = "post.rssa",
- style = Control.No,
thunk = fn () => doit p,
- display = Control.Layouts Program.layouts,
typeCheck = Program.typeCheck}
- val _ = stats p
in
p
end
@@ -219,6 +218,7 @@
{display = Control.Layouts (fn ((program, _), output) =>
Rssa.Program.layouts (program, output)),
name = "rssaSimplify",
+ stats = fn (program,_) => Rssa.Program.layoutStats program,
style = Control.No,
suffix = "rssa",
thunk = fn () => rssaSimplify program,
@@ -236,9 +236,11 @@
end
val program =
Control.pass
- {name = "toMachine",
+ {display = Control.Layouts Machine.Program.layouts,
+ name = "toMachine",
+ stats = fn _ => Layout.empty,
+ style = Control.No,
suffix = "machine",
- style = Control.No,
thunk = fn () =>
let
val R.Program.T {functions, handlesSignals, main, objectTypes} = program
@@ -1146,8 +1148,7 @@
profileInfo = profileInfo,
reals = allReals (),
vectors = allVectors ()}
-end,
- display = Control.Layouts Machine.Program.layouts}
+end}
in
program
end
Modified: mlton/trunk/mlton/control/control.sig
===================================================================
--- mlton/trunk/mlton/control/control.sig 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/control/control.sig 2008-08-19 22:11:19 UTC (rev 6725)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2006 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -62,16 +62,18 @@
val outputHeader: style * (Layout.t -> unit) -> unit
val outputHeader': style * Out.t -> unit
- val pass: {name: string,
+ val pass: {display: 'a display,
+ name: string,
+ stats: 'a -> Layout.t,
+ style: style,
suffix: string,
- style: style,
- thunk: unit -> 'a,
- display: 'a display} -> 'a
+ thunk: unit -> 'a} -> 'a
- val passTypeCheck: {name: string,
+ val passTypeCheck: {display: 'a display,
+ name: string,
+ stats: 'a -> Layout.t,
+ style: style,
suffix: string,
- style: style,
thunk: unit -> 'a,
- display: 'a display,
typeCheck: 'a -> unit} -> 'a
end
Modified: mlton/trunk/mlton/control/control.sml
===================================================================
--- mlton/trunk/mlton/control/control.sml 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/control/control.sml 2008-08-19 22:11:19 UTC (rev 6725)
@@ -58,9 +58,14 @@
fun message (verb: Verbosity.t, th: unit -> Layout.t): unit =
if Verbosity.<= (verb, !verbosity)
- then let val out = Out.error
- in Layout.output (Layout.indent (th (), !depth), out)
- ; Out.newline out
+ then let
+ val out = Out.error
+ val lay = th ()
+ in
+ if Layout.isEmpty lay
+ then ()
+ else (Layout.output (Layout.indent (lay, !depth), out)
+ ; Out.newline out)
end
else ()
@@ -298,10 +303,11 @@
then ()
else saveToFile ({suffix = concat [name, ".", suffix]}, style, a, d)
-fun pass {name: string,
+fun pass {display: 'a display,
+ name: string,
suffix: string,
+ stats: 'a -> Layout.t,
style: style,
- display = disp,
thunk: unit -> 'a}: 'a =
let
val result =
@@ -322,12 +328,16 @@
valOf (!result)
end
val verb = Detail
+ val _ = message (verb, fn () => Layout.str (concat [name, " stats"]))
+ val _ = indent ()
val _ = message (verb, fn () => sizeMessage (suffix, result))
+ val _ = message (verb, fn () => stats result)
val _ = message (verb, PropertyList.stats)
val _ = message (verb, HashSet.stats)
+ val _ = unindent ()
val _ = checkForErrors name
val _ = maybeSaveToFile ({name = name, suffix = suffix},
- style, result, disp)
+ style, result, display)
in
result
end
@@ -350,17 +360,19 @@
end
else pass z
-fun passTypeCheck {name: string,
+fun passTypeCheck {display: 'a display,
+ name: string,
+ stats: 'a -> Layout.t,
+ style: style,
suffix: string,
- style: style,
- display,
thunk: unit -> 'a,
typeCheck = tc: 'a -> unit}: 'a =
let
- val result = pass {name = name,
+ val result = pass {display = display,
+ name = name,
+ stats = stats,
+ style = style,
suffix = suffix,
- display = display,
- style = style,
thunk = thunk}
val _ =
if !typeCheck
Modified: mlton/trunk/mlton/main/compile.fun
===================================================================
--- mlton/trunk/mlton/main/compile.fun 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/main/compile.fun 2008-08-19 22:11:19 UTC (rev 6725)
@@ -367,13 +367,14 @@
fun parseAndElaborateMLB (input: MLBString.t)
: Env.t * (CoreML.Dec.t list * bool) vector =
Control.pass
- {name = "parseAndElaborate",
- suffix = "core-ml",
+ {display = displayEnvDecs,
+ name = "parseAndElaborate",
+ stats = fn _ => Layout.empty,
style = Control.ML,
+ suffix = "core-ml",
thunk = (fn () =>
(Const.lookup := lookupConstant
- ; elaborateMLB (lexAndParseMLB input, {addPrim = addPrim}))),
- display = displayEnvDecs}
+ ; elaborateMLB (lexAndParseMLB input, {addPrim = addPrim})))}
(* ------------------------------------------------- *)
(* Basis Library *)
@@ -445,26 +446,23 @@
val _ = if !Control.elaborateOnly then raise Done else ()
val decs =
Control.pass
- {name = "deadCode",
+ {display = Control.Layouts (fn (decss,output) =>
+ (output (Layout.str "\n\n")
+ ; Vector.foreach (decss, fn decs =>
+ List.foreach (decs, fn dec =>
+ output (CoreML.Dec.layout dec))))),
+ name = "deadCode",
suffix = "core-ml",
style = Control.ML,
+ stats = fn _ => Layout.empty,
thunk = fn () => let
val {prog = decs} =
DeadCode.deadCode {prog = decs}
in
decs
- end,
- display = Control.Layouts (fn (decss,output) =>
- (output (Layout.str "\n\n")
- ; Vector.foreach (decss, fn decs =>
- List.foreach (decs, fn dec =>
- output (CoreML.Dec.layout dec)))))}
+ end}
val decs = Vector.concatV (Vector.map (decs, Vector.fromList))
val coreML = CoreML.Program.T {decs = decs}
-(*
- val _ = Control.message (Control.Detail, fn () =>
- CoreML.Program.layoutStats coreML)
-*)
val _ =
let
open Control
@@ -530,12 +528,13 @@
end
val xml =
Control.passTypeCheck
- {name = "defunctorize",
- suffix = "xml",
+ {display = Control.Layouts Xml.Program.layouts,
+ name = "defunctorize",
+ stats = Xml.Program.layoutStats,
style = Control.ML,
+ suffix = "xml",
thunk = fn () => Defunctorize.defunctorize coreML,
- typeCheck = Xml.typeCheck,
- display = Control.Layouts Xml.Program.layouts}
+ typeCheck = Xml.typeCheck}
in
xml
end
@@ -543,18 +542,15 @@
fun preCodegen {input: MLBString.t}: Machine.Program.t =
let
val xml = elaborate {input = input}
- val _ = Control.message (Control.Detail, fn () =>
- Xml.Program.layoutStats xml)
val xml =
Control.passTypeCheck
- {name = "xmlSimplify",
- suffix = "xml",
+ {display = Control.Layouts Xml.Program.layouts,
+ name = "xmlSimplify",
+ stats = Xml.Program.layoutStats,
style = Control.ML,
+ suffix = "xml",
thunk = fn () => Xml.simplify xml,
- typeCheck = Xml.typeCheck,
- display = Control.Layouts Xml.Program.layouts}
- val _ = Control.message (Control.Detail, fn () =>
- Xml.Program.layoutStats xml)
+ typeCheck = Xml.typeCheck}
val _ =
let
open Control
@@ -566,24 +562,22 @@
end
val sxml =
Control.passTypeCheck
- {name = "monomorphise",
- suffix = "sxml",
+ {display = Control.Layouts Sxml.Program.layouts,
+ name = "monomorphise",
+ stats = Sxml.Program.layoutStats,
style = Control.ML,
+ suffix = "sxml",
thunk = fn () => Monomorphise.monomorphise xml,
- typeCheck = Sxml.typeCheck,
- display = Control.Layouts Sxml.Program.layouts}
- val _ = Control.message (Control.Detail, fn () =>
- Sxml.Program.layoutStats sxml)
+ typeCheck = Sxml.typeCheck}
val sxml =
Control.passTypeCheck
- {name = "sxmlSimplify",
- suffix = "sxml",
+ {display = Control.Layouts Sxml.Program.layouts,
+ name = "sxmlSimplify",
+ stats = Sxml.Program.layoutStats,
style = Control.ML,
+ suffix = "sxml",
thunk = fn () => Sxml.simplify sxml,
- typeCheck = Sxml.typeCheck,
- display = Control.Layouts Sxml.Program.layouts}
- val _ = Control.message (Control.Detail, fn () =>
- Sxml.Program.layoutStats sxml)
+ typeCheck = Sxml.typeCheck}
val _ =
let
open Control
@@ -595,24 +589,22 @@
end
val ssa =
Control.passTypeCheck
- {name = "closureConvert",
- suffix = "ssa",
+ {display = Control.Layouts Ssa.Program.layouts,
+ name = "closureConvert",
+ stats = Ssa.Program.layoutStats,
style = Control.No,
+ suffix = "ssa",
thunk = fn () => ClosureConvert.closureConvert sxml,
- typeCheck = Ssa.typeCheck,
- display = Control.Layouts Ssa.Program.layouts}
- val _ = Control.message (Control.Detail, fn () =>
- Ssa.Program.layoutStats ssa)
+ typeCheck = Ssa.typeCheck}
val ssa =
Control.passTypeCheck
- {name = "ssaSimplify",
- suffix = "ssa",
+ {display = Control.Layouts Ssa.Program.layouts,
+ name = "ssaSimplify",
+ stats = Ssa.Program.layoutStats,
style = Control.No,
+ suffix = "ssa",
thunk = fn () => Ssa.simplify ssa,
- typeCheck = Ssa.typeCheck,
- display = Control.Layouts Ssa.Program.layouts}
- val _ = Control.message (Control.Detail, fn () =>
- Ssa.Program.layoutStats ssa)
+ typeCheck = Ssa.typeCheck}
val _ =
let
open Control
@@ -624,24 +616,22 @@
end
val ssa2 =
Control.passTypeCheck
- {name = "toSsa2",
- suffix = "ssa2",
+ {display = Control.Layouts Ssa2.Program.layouts,
+ name = "toSsa2",
+ stats = Ssa2.Program.layoutStats,
style = Control.No,
+ suffix = "ssa2",
thunk = fn () => SsaToSsa2.convert ssa,
- typeCheck = Ssa2.typeCheck,
- display = Control.Layouts Ssa2.Program.layouts}
- val _ = Control.message (Control.Detail, fn () =>
- Ssa2.Program.layoutStats ssa2)
+ typeCheck = Ssa2.typeCheck}
val ssa2 =
Control.passTypeCheck
- {name = "ssa2Simplify",
- suffix = "ssa2",
+ {display = Control.Layouts Ssa2.Program.layouts,
+ name = "ssa2Simplify",
+ stats = Ssa2.Program.layoutStats,
style = Control.No,
+ suffix = "ssa2",
thunk = fn () => Ssa2.simplify ssa2,
- typeCheck = Ssa2.typeCheck,
- display = Control.Layouts Ssa2.Program.layouts}
- val _ = Control.message (Control.Detail, fn () =>
- Ssa2.Program.layoutStats ssa2)
+ typeCheck = Ssa2.typeCheck}
val _ =
let
open Control
@@ -658,14 +648,21 @@
| Control.x86Codegen => x86Codegen.implementsPrim
| Control.amd64Codegen => amd64Codegen.implementsPrim
val machine =
- Control.pass
- {name = "backend",
- suffix = "machine",
+ Control.passTypeCheck
+ {display = Control.Layouts Machine.Program.layouts,
+ name = "backend",
+ stats = fn _ => Layout.empty,
style = Control.No,
- thunk = fn () => (Backend.toMachine
- (ssa2,
- {codegenImplementsPrim = codegenImplementsPrim})),
- display = Control.Layouts Machine.Program.layouts}
+ suffix = "machine",
+ thunk = fn () =>
+ (Backend.toMachine
+ (ssa2,
+ {codegenImplementsPrim = codegenImplementsPrim})),
+ typeCheck = fn machine =>
+ (* For now, machine type check is too slow to run. *)
+ (if !Control.typeCheck
+ then Machine.Program.typeCheck machine
+ else ())}
val _ =
let
open Control
@@ -675,15 +672,6 @@
Layouts Machine.Program.layouts)
else ()
end
- val _ =
- (*
- * For now, machine type check is too slow to run.
- *)
- if !Control.typeCheck
- then
- Control.trace (Control.Pass, "machine type check")
- Machine.Program.typeCheck machine
- else ()
in
machine
end
Modified: mlton/trunk/mlton/ssa/simplify.fun
===================================================================
--- mlton/trunk/mlton/ssa/simplify.fun 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/ssa/simplify.fun 2008-08-19 22:11:19 UTC (rev 6725)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -242,8 +242,6 @@
val _ = List.push (Control.optimizationPassesSet, ("ssa", ssaPassesSet))
end
-fun stats p = Control.message (Control.Detail, fn () => Program.layoutStats p)
-
fun pass ({name, doit, midfix}, p) =
let
val _ =
@@ -255,13 +253,13 @@
end
val p =
Control.passTypeCheck
- {name = name,
- suffix = midfix ^ "post.ssa",
+ {display = Control.Layouts Program.layouts,
+ name = name,
+ stats = Program.layoutStats,
style = Control.No,
+ suffix = midfix ^ "post.ssa",
thunk = fn () => doit p,
- display = Control.Layouts Program.layouts,
typeCheck = typeCheck}
- val _ = stats p
in
p
end
@@ -287,9 +285,9 @@
(!ssaPasses, p, fn ({name, doit}, p) =>
maybePass ({name = name, doit = doit, midfix = midfix}, p)))
end
+ val p = simplify' 0 p
in
- stats p
- ; simplify' 0 p
+ p
end
val simplify = fn p => let
Modified: mlton/trunk/mlton/ssa/simplify2.fun
===================================================================
--- mlton/trunk/mlton/ssa/simplify2.fun 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/ssa/simplify2.fun 2008-08-19 22:11:19 UTC (rev 6725)
@@ -1,4 +1,4 @@
-(* Copyright (C) 1999-2007 Henry Cejtin, Matthew Fluet, Suresh
+(* Copyright (C) 1999-2008 Henry Cejtin, Matthew Fluet, Suresh
* Jagannathan, and Stephen Weeks.
* Copyright (C) 1997-2000 NEC Research Institute.
*
@@ -104,8 +104,6 @@
val _ = List.push (Control.optimizationPassesSet, ("ssa2", ssa2PassesSet))
end
-fun stats p = Control.message (Control.Detail, fn () => Program.layoutStats p)
-
fun pass ({name, doit, midfix}, p) =
let
val _ =
@@ -117,13 +115,13 @@
end
val p =
Control.passTypeCheck
- {name = name,
- suffix = midfix ^ "post.ssa2",
+ {display = Control.Layouts Program.layouts,
+ name = name,
+ stats = Program.layoutStats,
style = Control.No,
+ suffix = midfix ^ "post.ssa2",
thunk = fn () => doit p,
- display = Control.Layouts Program.layouts,
typeCheck = typeCheck}
- val _ = stats p
in
p
end
@@ -149,9 +147,9 @@
(!ssa2Passes, p, fn ({name, doit}, p) =>
maybePass ({name = name, doit = doit, midfix = midfix}, p)))
end
+ val p = simplify' 0 p
in
- stats p
- ; simplify' 0 p
+ p
end
val simplify = fn p => let
Modified: mlton/trunk/mlton/ssa/ssa-tree.fun
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree.fun 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/ssa/ssa-tree.fun 2008-08-19 22:11:19 UTC (rev 6725)
@@ -1609,7 +1609,7 @@
end
end
- fun layoutStats (T {globals, functions, main, ...}) =
+ fun layoutStats (T {datatypes, globals, functions, main, ...}) =
let
val (mainNumVars, mainNumBlocks) =
case List.peek (functions, fn f =>
@@ -1627,6 +1627,11 @@
val numTypes = ref 0
val {hom = countType, destroy} =
Type.makeMonoHom {con = fn _ => Int.inc numTypes}
+ val _ =
+ Vector.foreach
+ (datatypes, fn Datatype.T {cons, ...} =>
+ Vector.foreach (cons, fn {args, ...} =>
+ Vector.foreach (args, countType)))
val numStatements = ref (Vector.length globals)
val numBlocks = ref 0
val _ =
Modified: mlton/trunk/mlton/ssa/ssa-tree2.fun
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree2.fun 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/ssa/ssa-tree2.fun 2008-08-19 22:11:19 UTC (rev 6725)
@@ -167,8 +167,7 @@
| _ => false
val table: t HashSet.t = HashSet.new {hash = hash}
in
- val lookup: word * tree -> t =
- fn (hash, tr) =>
+ fun lookup (hash, tr) =
HashSet.lookupOrInsert (table, hash,
fn t => same (tr, tree t),
fn () => T {hash = hash,
@@ -177,7 +176,7 @@
fun stats () =
let open Layout
- in align [seq [str "num distinct types = ",
+ in align [seq [str "num types in hash table = ",
Int.layout (HashSet.size table)],
Control.sizeMessage ("types hash table", lookup)]
end
Modified: mlton/trunk/mlton/xml/polyvariance.fun
===================================================================
--- mlton/trunk/mlton/xml/polyvariance.fun 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/xml/polyvariance.fun 2008-08-19 22:11:19 UTC (rev 6725)
@@ -437,17 +437,21 @@
| SOME {hofo, rounds, small, product} =>
let
fun loop (p, n) =
- if n = 0
+ if n = rounds
then p
else let
- val p = shrink (duplicate (p, hofo, small, product))
- val _ =
- Control.message (Control.Detail, fn () =>
- Program.layoutStats p)
+ val p =
+ Control.pass
+ {display = Control.Layouts Program.layouts,
+ name = "duplicate" ^ (Int.toString (n + 1)),
+ stats = Program.layoutStats,
+ style = Control.No,
+ suffix = "post.xml",
+ thunk = fn () => shrink (duplicate (p, hofo, small, product))}
in
- loop (p, n - 1)
+ loop (p, n + 1)
end
- in loop (p, rounds)
+ in loop (p, 0)
end
end
Modified: mlton/trunk/mlton/xml/sxml-simplify.fun
===================================================================
--- mlton/trunk/mlton/xml/sxml-simplify.fun 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/xml/sxml-simplify.fun 2008-08-19 22:11:19 UTC (rev 6725)
@@ -162,37 +162,44 @@
val _ = List.push (Control.optimizationPassesSet, ("sxml", sxmlPassesSet))
end
-fun stats p =
- Control.message (Control.Detail, fn () => Program.layoutStats p)
+fun pass ({name, doit}, p) =
+ let
+ val _ =
+ let open Control
+ in maybeSaveToFile
+ ({name = name,
+ suffix = "pre.sxml"},
+ Control.No, p, Control.Layouts Program.layouts)
+ end
+ val p =
+ Control.passTypeCheck
+ {display = Control.Layouts Program.layouts,
+ name = name,
+ stats = Program.layoutStats,
+ style = Control.No,
+ suffix = "post.sxml",
+ thunk = fn () => doit p,
+ typeCheck = typeCheck}
+ in
+ p
+ end
+fun maybePass ({name, doit, enable}, 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)
fun simplify p =
- (stats p
- ; (List.fold
- (!sxmlPasses, p, fn ({name, enable, doit}, p) =>
- if List.exists (!Control.dropPasses, fn re =>
- Regexp.Compiled.matchesAll (re, name))
- orelse not (enable ())
- then p
- else
- let
- val _ =
- let open Control
- in maybeSaveToFile
- ({name = name, suffix = "pre.sxml"},
- Control.No, p, Control.Layouts Program.layouts)
- end
- val p =
- Control.passTypeCheck
- {name = name,
- suffix = "post.sxml",
- style = Control.No,
- thunk = fn () => doit p,
- display = Control.Layouts Program.layouts,
- typeCheck = typeCheck}
- val _ = stats p
- in
- p
- end)))
+ let
+ fun simplify' p =
+ List.fold
+ (!sxmlPasses, p, fn ({name, doit, enable}, p) =>
+ maybePass ({name = name, doit = doit, enable = enable}, p))
+ val p = simplify' p
+ in
+ p
+ end
val simplify = fn p => let
(* Always want to type check the initial and final XML
Modified: mlton/trunk/mlton/xml/xml-simplify.fun
===================================================================
--- mlton/trunk/mlton/xml/xml-simplify.fun 2008-08-19 22:11:12 UTC (rev 6724)
+++ mlton/trunk/mlton/xml/xml-simplify.fun 2008-08-19 22:11:19 UTC (rev 6725)
@@ -73,37 +73,43 @@
val _ = List.push (Control.optimizationPassesSet, ("xml", xmlPassesSet))
end
+fun pass ({name, doit}, p) =
+ let
+ val _ =
+ let open Control
+ in maybeSaveToFile
+ ({name = name,
+ suffix = "pre.xml"},
+ Control.No, p, Control.Layouts Program.layouts)
+ end
+ val p =
+ Control.passTypeCheck
+ {display = Control.Layouts Program.layouts,
+ name = name,
+ stats = Program.layoutStats,
+ style = Control.No,
+ suffix = "post.xml",
+ thunk = fn () => doit p,
+ typeCheck = typeCheck}
+ in
+ p
+ end
+fun maybePass ({name, doit}, p) =
+ if List.exists (!Control.dropPasses, fn re =>
+ Regexp.Compiled.matchesAll (re, name))
+ then p
+ else pass ({name = name, doit = doit}, p)
-fun stats p =
- Control.message (Control.Detail, fn () => Program.layoutStats p)
-
fun simplify p =
- (stats p
- ; (List.fold
- (!xmlPasses, p, fn ({name, doit}, p) =>
- if List.exists (!Control.dropPasses, fn re =>
- Regexp.Compiled.matchesAll (re, name))
- then p
- else
- let
- val _ =
- let open Control
- in maybeSaveToFile
- ({name = name, suffix = "pre.xml"},
- Control.No, p, Control.Layouts Program.layouts)
- end
- val p =
- Control.passTypeCheck
- {name = name,
- suffix = "post.xml",
- style = Control.No,
- thunk = fn () => doit p,
- display = Control.Layouts Program.layouts,
- typeCheck = typeCheck}
- val _ = stats p
- in
- p
- end)))
+ let
+ fun simplify' p =
+ List.fold
+ (!xmlPasses, p, fn ({name, doit}, p) =>
+ maybePass ({name = name, doit = doit}, p))
+ val p = simplify' p
+ in
+ p
+ end
val simplify = fn p => let
(* Always want to type check the initial and final XML
More information about the MLton-commit
mailing list