[MLton-commit] r6715
Matthew Fluet
fluet at mlton.org
Tue Aug 19 15:10:11 PDT 2008
Add 'core-ml', 'xml', and 'sxml' as '-keep' options; improve CoreML and S/XML IL layout
----------------------------------------------------------------------
U mlton/trunk/mlton/control/control-flags.sig
U mlton/trunk/mlton/control/control-flags.sml
U mlton/trunk/mlton/core-ml/core-ml.fun
U mlton/trunk/mlton/core-ml/core-ml.sig
U mlton/trunk/mlton/main/compile.fun
U mlton/trunk/mlton/main/main.fun
U mlton/trunk/mlton/xml/xml-tree.fun
U mlton/trunk/mlton/xml/xml-tree.sig
----------------------------------------------------------------------
Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig 2008-08-19 22:10:01 UTC (rev 6714)
+++ mlton/trunk/mlton/control/control-flags.sig 2008-08-19 22:10:09 UTC (rev 6715)
@@ -185,19 +185,23 @@
(* Keep dot files for whatever SSA files are produced. *)
val keepDot: bool ref
- (* Save the Machine to a file. *)
- val keepMachine: bool ref
-
- (* List of pass names to save the result of. *)
+ (* List of pass names to save the input/output. *)
val keepPasses: Regexp.Compiled.t list ref
- (* Save the RSSA to a file. *)
+ (* Save the final CoreML to a file. *)
+ val keepCoreML: bool ref
+ (* Save the final Machine to a file. *)
+ val keepMachine: bool ref
+ (* Save the final RSSA to a file. *)
val keepRSSA: bool ref
-
- (* Save the SSA to a file. *)
+ (* Save the final SSA to a file. *)
val keepSSA: bool ref
- (* Save the SSA2 to a file. *)
+ (* Save the final SSA2 to a file. *)
val keepSSA2: bool ref
+ (* Save the final SXML to a file. *)
+ val keepSXML: bool ref
+ (* Save the final XML to a file. *)
+ val keepXML: bool ref
(* For the codegen -- do labels for gcc and assembler need an extra leading
* underscore.
Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml 2008-08-19 22:10:01 UTC (rev 6714)
+++ mlton/trunk/mlton/control/control-flags.sml 2008-08-19 22:10:09 UTC (rev 6715)
@@ -703,10 +703,28 @@
default = "<bogus>",
toString = File.toString}
+val keepCoreML = control {name = "keep CoreML",
+ default = false,
+ toString = Bool.toString}
+
+val keepDefUse = control {name = "keep def use",
+ default = true,
+ toString = Bool.toString}
+
+val keepDot = control {name = "keep dot",
+ default = false,
+ toString = Bool.toString}
+
val keepMachine = control {name = "keep Machine",
default = false,
toString = Bool.toString}
+val keepPasses = control {name = "keep passes",
+ default = [],
+ toString = List.toString
+ (Layout.toString o
+ Regexp.Compiled.layout)}
+
val keepRSSA = control {name = "keep RSSA",
default = false,
toString = Bool.toString}
@@ -719,20 +737,15 @@
default = false,
toString = Bool.toString}
-val keepDefUse = control {name = "keep def use",
- default = true,
- toString = Bool.toString}
+val keepSXML = control {name = "keep SXML",
+ default = false,
+ toString = Bool.toString}
-val keepDot = control {name = "keep dot",
+
+val keepXML = control {name = "keep XML",
default = false,
toString = Bool.toString}
-val keepPasses = control {name = "keep passes",
- default = [],
- toString = List.toString
- (Layout.toString o
- Regexp.Compiled.layout)}
-
val labelsHaveExtra_ = control {name = "extra_",
default = false,
toString = Bool.toString}
Modified: mlton/trunk/mlton/core-ml/core-ml.fun
===================================================================
--- mlton/trunk/mlton/core-ml/core-ml.fun 2008-08-19 22:10:01 UTC (rev 6714)
+++ mlton/trunk/mlton/core-ml/core-ml.fun 2008-08-19 22:10:09 UTC (rev 6715)
@@ -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.
*
@@ -489,6 +489,18 @@
fun layout (T {decs, ...}) =
Layout.align (Vector.toListMap (decs, Dec.layout))
+ fun layouts (T {decs, ...}, output') =
+ let
+ open Layout
+ (* Layout includes an output function, so we need to rebind output
+ * to the one above.
+ *)
+ val output = output'
+ in
+ output (Layout.str "\n\nDecs:")
+ ; Vector.foreach (decs, output o Dec.layout)
+ end
+
(* fun typeCheck (T {decs, ...}) =
* let
* fun checkExp (e: Exp.t): Ty.t =
Modified: mlton/trunk/mlton/core-ml/core-ml.sig
===================================================================
--- mlton/trunk/mlton/core-ml/core-ml.sig 2008-08-19 22:10:01 UTC (rev 6714)
+++ mlton/trunk/mlton/core-ml/core-ml.sig 2008-08-19 22:10:09 UTC (rev 6715)
@@ -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.
*
@@ -182,5 +182,6 @@
datatype t = T of {decs: Dec.t vector}
val layout: t -> Layout.t
+ val layouts: t * (Layout.t -> unit) -> unit
end
end
Modified: mlton/trunk/mlton/main/compile.fun
===================================================================
--- mlton/trunk/mlton/main/compile.fun 2008-08-19 22:10:01 UTC (rev 6714)
+++ mlton/trunk/mlton/main/compile.fun 2008-08-19 22:10:09 UTC (rev 6715)
@@ -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.
*
@@ -355,14 +355,14 @@
val elaborateMLB = Elaborate.elaborateMLB
val displayEnvDecs =
- Control.Layout
- (fn (_, ds) =>
- Vector.layout
- (fn (d, b) =>
- Layout.record
- [("deadCode", Bool.layout b),
- ("decs", List.layout CoreML.Dec.layout d)])
- ds)
+ Control.Layouts
+ (fn ((_, decs),output) =>
+ (output (Layout.str "\n\n")
+ ; Vector.foreach
+ (decs, fn (dec, dc) =>
+ (output o Layout.record)
+ [("deadCode", Bool.layout dc),
+ ("decs", List.layout CoreML.Dec.layout dec)])))
fun parseAndElaborateMLB (input: MLBString.t)
: Env.t * (CoreML.Dec.t list * bool) vector =
@@ -454,13 +454,27 @@
in
decs
end,
- display = Control.Layout (Vector.layout (List.layout CoreML.Dec.layout))}
+ 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)))))}
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
+ in
+ if !keepCoreML
+ then saveToFile ({suffix = "core-ml"}, No, coreML,
+ Layouts CoreML.Program.layouts)
+ else ()
+ end
+
(* Set GC_state offsets and sizes. *)
val _ =
let
@@ -520,8 +534,8 @@
suffix = "xml",
style = Control.ML,
thunk = fn () => Defunctorize.defunctorize coreML,
- display = Control.Layout Xml.Program.layout,
- typeCheck = Xml.typeCheck}
+ typeCheck = Xml.typeCheck,
+ display = Control.Layouts Xml.Program.layouts}
in
xml
end
@@ -537,18 +551,27 @@
suffix = "xml",
style = Control.ML,
thunk = fn () => Xml.simplify xml,
- display = Control.Layout Xml.Program.layout,
- typeCheck = Xml.typeCheck}
+ typeCheck = Xml.typeCheck,
+ display = Control.Layouts Xml.Program.layouts}
val _ = Control.message (Control.Detail, fn () =>
Xml.Program.layoutStats xml)
+ val _ =
+ let
+ open Control
+ in
+ if !keepXML
+ then saveToFile ({suffix = "xml"}, No, xml,
+ Layouts Xml.Program.layouts)
+ else ()
+ end
val sxml =
Control.passTypeCheck
{name = "monomorphise",
suffix = "sxml",
style = Control.ML,
thunk = fn () => Monomorphise.monomorphise xml,
- display = Control.Layout Sxml.Program.layout,
- typeCheck = Sxml.typeCheck}
+ typeCheck = Sxml.typeCheck,
+ display = Control.Layouts Sxml.Program.layouts}
val _ = Control.message (Control.Detail, fn () =>
Sxml.Program.layoutStats sxml)
val sxml =
@@ -557,10 +580,19 @@
suffix = "sxml",
style = Control.ML,
thunk = fn () => Sxml.simplify sxml,
- display = Control.Layout Sxml.Program.layout,
- typeCheck = Sxml.typeCheck}
+ typeCheck = Sxml.typeCheck,
+ display = Control.Layouts Sxml.Program.layouts}
val _ = Control.message (Control.Detail, fn () =>
Sxml.Program.layoutStats sxml)
+ val _ =
+ let
+ open Control
+ in
+ if !keepSXML
+ then saveToFile ({suffix = "sxml"}, No, sxml,
+ Layouts Sxml.Program.layouts)
+ else ()
+ end
val ssa =
Control.passTypeCheck
{name = "closureConvert",
@@ -569,6 +601,8 @@
thunk = fn () => ClosureConvert.closureConvert sxml,
typeCheck = Ssa.typeCheck,
display = Control.Layouts Ssa.Program.layouts}
+ val _ = Control.message (Control.Detail, fn () =>
+ Ssa.Program.layoutStats ssa)
val ssa =
Control.passTypeCheck
{name = "ssaSimplify",
@@ -577,13 +611,15 @@
thunk = fn () => Ssa.simplify ssa,
typeCheck = Ssa.typeCheck,
display = Control.Layouts Ssa.Program.layouts}
+ val _ = Control.message (Control.Detail, fn () =>
+ Ssa.Program.layoutStats ssa)
val _ =
let
open Control
in
if !keepSSA
then saveToFile ({suffix = "ssa"}, No, ssa,
- Layouts Ssa.Program.layouts)
+ Layouts Ssa.Program.layouts)
else ()
end
val ssa2 =
@@ -594,6 +630,8 @@
thunk = fn () => SsaToSsa2.convert ssa,
typeCheck = Ssa2.typeCheck,
display = Control.Layouts Ssa2.Program.layouts}
+ val _ = Control.message (Control.Detail, fn () =>
+ Ssa2.Program.layoutStats ssa2)
val ssa2 =
Control.passTypeCheck
{name = "ssa2Simplify",
@@ -602,13 +640,15 @@
thunk = fn () => Ssa2.simplify ssa2,
typeCheck = Ssa2.typeCheck,
display = Control.Layouts Ssa2.Program.layouts}
+ val _ = Control.message (Control.Detail, fn () =>
+ Ssa2.Program.layoutStats ssa2)
val _ =
let
open Control
in
if !keepSSA2
then saveToFile ({suffix = "ssa2"}, No, ssa2,
- Layouts Ssa2.Program.layouts)
+ Layouts Ssa2.Program.layouts)
else ()
end
val codegenImplementsPrim =
@@ -632,7 +672,7 @@
in
if !keepMachine
then saveToFile ({suffix = "machine"}, No, machine,
- Layouts Machine.Program.layouts)
+ Layouts Machine.Program.layouts)
else ()
end
val _ =
Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun 2008-08-19 22:10:01 UTC (rev 6714)
+++ mlton/trunk/mlton/main/main.fun 2008-08-19 22:10:09 UTC (rev 6715)
@@ -450,14 +450,17 @@
(Normal, "keep", " {g|o|sml}", "save intermediate files",
SpaceString (fn s =>
case s of
- "dot" => keepDot := true
+ "core-ml" => keepCoreML := true
+ | "dot" => keepDot := true
| "g" => keepGenerated := true
| "machine" => keepMachine := true
| "o" => keepO := true
+ | "rssa" => keepRSSA := true
| "sml" => keepSML := true
- | "rssa" => keepRSSA := true
| "ssa" => keepSSA := true
| "ssa2" => keepSSA2 := true
+ | "sxml" => keepSXML := true
+ | "xml" => keepXML := true
| _ => usage (concat ["invalid -keep flag: ", s]))),
(Expert, "keep-pass", " <pass>", "keep the results of pass",
SpaceString
Modified: mlton/trunk/mlton/xml/xml-tree.fun
===================================================================
--- mlton/trunk/mlton/xml/xml-tree.fun 2008-08-19 22:10:01 UTC (rev 6714)
+++ mlton/trunk/mlton/xml/xml-tree.fun 2008-08-19 22:10:09 UTC (rev 6715)
@@ -213,14 +213,14 @@
fun layoutTyvars ts =
case Vector.length ts of
0 => empty
- | 1 => seq [str " ", Tyvar.layout (Vector.sub (ts, 0))]
- | _ => seq [str " ", tuple (Vector.toListMap (ts, Tyvar.layout))]
+ | 1 => seq [Tyvar.layout (Vector.sub (ts, 0)), str " "]
+ | _ => seq [tuple (Vector.toListMap (ts, Tyvar.layout)), str " "]
fun layoutDec d =
case d of
Exception ca =>
seq [str "exception ", layoutConArg ca]
| Fun {decs, tyvars} =>
- align [seq [str "val rec", layoutTyvars tyvars, str " "],
+ align [seq [str "val rec ", layoutTyvars tyvars],
indent (align (Vector.toListMap
(decs, fn {lambda, ty, var} =>
align [seq [maybeConstrain (Var.layout var, ty),
@@ -232,13 +232,12 @@
maybeConstrain (Var.layout var, ty), str " = "],
indent (layoutPrimExp exp, 3)]
| PolyVal {exp, ty, tyvars, var} =>
- align [seq [str "val",
+ align [seq [str "val ",
if !Control.showTypes
then layoutTyvars tyvars
else empty,
- str " ",
- maybeConstrain (Var.layout var, ty),
- str " = "],
+ maybeConstrain (Var.layout var, ty),
+ str " = "],
indent (layoutExp exp, 3)]
and layoutExp (Exp {decs, result}) =
align [str "let",
@@ -844,7 +843,8 @@
let
open Layout
in
- seq [layoutTyvars tyvars, str " ", Tycon.layout tycon, str " = ",
+ seq [layoutTyvars tyvars,
+ Tycon.layout tycon, str " = ",
align
(separateLeft (Vector.toListMap (cons, layoutConArg),
"| "))]
@@ -865,13 +865,28 @@
let
open Layout
in
- align [seq [str "Overflow: ", Option.layout Var.layout overflow],
- str "Datatypes:",
+ align [str "\n\nDatatypes:",
align (Vector.toListMap (datatypes, Datatype.layout)),
- str "Body:",
+ seq [str "\n\nOverflow: ", Option.layout Var.layout overflow],
+ str "\n\nBody:",
Exp.layout body]
end
+ fun layouts (T {body, datatypes, overflow, ...}, output') =
+ let
+ open Layout
+ (* Layout includes an output function, so we need to rebind output
+ * to the one above.
+ *)
+ val output = output'
+ in
+ output (str "\n\nDatatypes:")
+ ; Vector.foreach (datatypes, output o Datatype.layout)
+ ; output (seq [str "\n\nOverflow: ", Option.layout Var.layout overflow])
+ ; output (str "\n\nBody:")
+ ; output (Exp.layout body)
+ end
+
fun clear (T {datatypes, body, ...}) =
(Vector.foreach (datatypes, fn {tycon, tyvars, cons} =>
(Tycon.clear tycon
Modified: mlton/trunk/mlton/xml/xml-tree.sig
===================================================================
--- mlton/trunk/mlton/xml/xml-tree.sig 2008-08-19 22:10:01 UTC (rev 6714)
+++ mlton/trunk/mlton/xml/xml-tree.sig 2008-08-19 22:10:09 UTC (rev 6715)
@@ -249,6 +249,7 @@
val clear: t -> unit (* clear all property lists *)
val layout: t -> Layout.t
+ val layouts: t * (Layout.t -> unit) -> unit
val layoutStats: t -> Layout.t
end
end
More information about the MLton-commit
mailing list