[MLton-commit] r6058

[Matthew Fluet]

An expert control to enable the CPS transform
----------------------------------------------------------------------

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/xml/sxml-simplify.fun

----------------------------------------------------------------------

Modified: mlton/trunk/mlton/control/control-flags.sig
===================================================================
--- mlton/trunk/mlton/control/control-flags.sig	2007-09-29 13:45:53 UTC (rev 6057)
+++ mlton/trunk/mlton/control/control-flags.sig	2007-09-29 16:04:31 UTC (rev 6058)
@@ -52,6 +52,8 @@
 
       val contifyIntoMain: bool ref
 
+      val cpsTransform: bool ref
+
       (* Generate an executable with debugging info. *)
       val debug: bool ref
 

Modified: mlton/trunk/mlton/control/control-flags.sml
===================================================================
--- mlton/trunk/mlton/control/control-flags.sml	2007-09-29 13:45:53 UTC (rev 6057)
+++ mlton/trunk/mlton/control/control-flags.sml	2007-09-29 16:04:31 UTC (rev 6058)
@@ -81,6 +81,10 @@
                                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}

Modified: mlton/trunk/mlton/main/main.fun
===================================================================
--- mlton/trunk/mlton/main/main.fun	2007-09-29 13:45:53 UTC (rev 6057)
+++ mlton/trunk/mlton/main/main.fun	2007-09-29 16:04:31 UTC (rev 6058)
@@ -256,6 +256,9 @@
        (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))),

Modified: mlton/trunk/mlton/xml/sxml-simplify.fun
===================================================================
--- mlton/trunk/mlton/xml/sxml-simplify.fun	2007-09-29 13:45:53 UTC (rev 6057)
+++ mlton/trunk/mlton/xml/sxml-simplify.fun	2007-09-29 16:04:31 UTC (rev 6058)
@@ -24,25 +24,41 @@
     fn () => Polyvariance.duplicate p)
 
 type pass = {name: string,
+             enable: unit -> bool,
              doit: Program.t -> Program.t}
 
 val sxmlPassesDefault =
-   {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 = "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", doit = Uncurry.uncurry} ::
-   {name = "sxmlShrink4", doit = S.shrink} ::
+   {name = "uncurry", 
+    enable = fn () => true, doit = Uncurry.uncurry} ::
+   {name = "sxmlShrink4", 
+    enable = fn () => true, doit = S.shrink} ::
 *)
-   {name = "polyvariance", doit = Polyvariance.duplicate} ::
+   {name = "cpsTransform", 
+    enable = fn () => !Control.cpsTransform, doit = CPSTransform.doit} ::
+   {name = "sxmlShrink4", 
+    enable = fn () => !Control.cpsTransform, doit = S.shrink} ::
+   {name = "polyvariance", 
+    enable = fn () => true, doit = Polyvariance.duplicate} ::
    nil
 
 val sxmlPassesMinimal =
-   {name = "implementSuffix", doit = ImplementSuffix.doit} ::
-   {name = "sxmlShrink2", doit = S.shrink} ::
-   {name = "implementExceptions", doit = ImplementExceptions.doit} ::
+   {name = "implementSuffix", 
+    enable = fn () => true, doit = ImplementSuffix.doit} ::
+   {name = "sxmlShrink2", 
+    enable = fn () => true, doit = S.shrink} ::
+   {name = "implementExceptions", 
+    enable = fn () => true, doit = ImplementExceptions.doit} ::
    nil
 
 val sxmlPasses : pass list ref = ref sxmlPassesDefault
@@ -55,6 +71,7 @@
       in fn s => if s = name
                     then SOME {name = name ^ "#" ^ 
                                (Int.toString (Counter.next count)),
+                               enable = fn () => true,
                                doit = doit}
                     else NONE
       end
@@ -89,6 +106,7 @@
                                             Int.toString small, ",",
                                             Int.toString product, ")#",
                                             Int.toString (Counter.next count)],
+                             enable = fn () => true,
                              doit = polyvariance (rounds, small, product)}
                     val s = String.dropPrefix (s, String.size "polyvariance")
                  in
@@ -142,9 +160,10 @@
 fun simplify p =
    (stats p
     ; (List.fold
-       (!sxmlPasses, p, fn ({name, doit}, p) =>
+       (!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