[MLton-commit] r5776

Matthew Fluet fluet at mlton.org
Tue Jul 17 08:17:23 PDT 2007


Put SSA and SSA2 programs into a canonical order (based on a DFS walk)
at the end of the optimization sequences.  This should help reduce
variation in codegen behavior due to the order of functions/blocks.
Since most SSA{,2} optimizations end up reversing the order of
functions, an otherwise idempotent optimization can still yield
different execution times.  This was annoying with benchmarking
different inlining threshholds; using
  -inline-leaf (40;40;0)
and
  -inline-leaf (40;40;40)
would yield different execution times, even if there were no functions
below the threshold, because the former would recognize that a 0
threshhold implies no inlining (and so returns the SSA program
unchanged) while the later would process the program, but only end up
reversing the function order.


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

U   mlton/trunk/mlton/ssa/prepasses.fun
U   mlton/trunk/mlton/ssa/prepasses.sig
U   mlton/trunk/mlton/ssa/prepasses2.fun
U   mlton/trunk/mlton/ssa/prepasses2.sig
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-tree.sig
U   mlton/trunk/mlton/ssa/ssa-tree2.fun
U   mlton/trunk/mlton/ssa/ssa-tree2.sig

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

Modified: mlton/trunk/mlton/ssa/prepasses.fun
===================================================================
--- mlton/trunk/mlton/ssa/prepasses.fun	2007-07-14 18:01:57 UTC (rev 5775)
+++ mlton/trunk/mlton/ssa/prepasses.fun	2007-07-17 15:17:21 UTC (rev 5776)
@@ -159,8 +159,6 @@
 (* quell unused warning *)
 val _ = breakCriticalEdgesFunction
 val breakCriticalEdges = CriticalEdges.break
-(* quell unused warning *)
-val _ = breakCriticalEdges
 
 structure DeadBlocks =
 struct
@@ -207,6 +205,47 @@
 val eliminateDeadBlocks = DeadBlocks.eliminate
 
 
+structure Order =
+struct
+
+fun orderFunctions (p as Program.T {globals, datatypes, functions, main}) =
+   let
+      val functions = ref []
+      val () =
+         Program.dfs
+         (p, fn f =>
+          let
+             val {args, mayInline, name, raises, returns, start, ...} =
+                Function.dest f
+             val blocks = ref []
+             val () =
+                Function.dfs
+                (f, fn b =>
+                 (List.push (blocks, b)
+                  ; fn () => ()))
+             val f = Function.new {args = args,
+                                   blocks = Vector.fromListRev (!blocks),
+                                   mayInline = mayInline,
+                                   name = name,
+                                   raises = raises,
+                                   returns = returns,
+                                   start = start}
+          in
+             List.push (functions, f)
+             ; fn () => ()
+          end)
+   in
+      Program.T {datatypes = datatypes,
+                 globals = globals,
+                 functions = List.rev (!functions),
+                 main = main}
+   end
+
+end
+
+val orderFunctions = Order.orderFunctions
+
+
 structure Reverse =
 struct
 

Modified: mlton/trunk/mlton/ssa/prepasses.sig
===================================================================
--- mlton/trunk/mlton/ssa/prepasses.sig	2007-07-14 18:01:57 UTC (rev 5775)
+++ mlton/trunk/mlton/ssa/prepasses.sig	2007-07-17 15:17:21 UTC (rev 5776)
@@ -33,5 +33,6 @@
       val dropProfile: Program.t -> Program.t
       val eliminateDeadBlocksFunction: Function.t -> Function.t
       val eliminateDeadBlocks: Program.t -> Program.t
+      val orderFunctions: Program.t -> Program.t
       val reverseFunctions: Program.t -> Program.t
    end

Modified: mlton/trunk/mlton/ssa/prepasses2.fun
===================================================================
--- mlton/trunk/mlton/ssa/prepasses2.fun	2007-07-14 18:01:57 UTC (rev 5775)
+++ mlton/trunk/mlton/ssa/prepasses2.fun	2007-07-17 15:17:21 UTC (rev 5776)
@@ -55,9 +55,49 @@
 (* quell unused warning *)
 val _ = eliminateDeadBlocksFunction
 val eliminateDeadBlocks = DeadBlocks.eliminate
-(* quell unused warning *)
-val _ = eliminateDeadBlocks
 
+
+structure Order = 
+struct
+
+fun orderFunctions (p as Program.T {globals, datatypes, functions, main}) =
+   let
+      val functions = ref []
+      val () =
+         Program.dfs
+         (p, fn f =>
+          let
+             val {args, mayInline, name, raises, returns, start, ...} =
+                Function.dest f
+             val blocks = ref []
+             val () =
+                Function.dfs
+                (f, fn b =>
+                 (List.push (blocks, b)
+                  ; fn () => ()))
+             val f = Function.new {args = args,
+                                   blocks = Vector.fromListRev (!blocks),
+                                   mayInline = mayInline,
+                                   name = name,
+                                   raises = raises,
+                                   returns = returns,
+                                   start = start}
+          in
+             List.push (functions, f)
+             ; fn () => ()
+          end)
+   in
+      Program.T {datatypes = datatypes,
+                 globals = globals,
+                 functions = List.rev (!functions),
+                 main = main}
+   end
+
+end
+
+val orderFunctions = Order.orderFunctions
+
+
 structure Reverse =
 struct
 

Modified: mlton/trunk/mlton/ssa/prepasses2.sig
===================================================================
--- mlton/trunk/mlton/ssa/prepasses2.sig	2007-07-14 18:01:57 UTC (rev 5775)
+++ mlton/trunk/mlton/ssa/prepasses2.sig	2007-07-17 15:17:21 UTC (rev 5776)
@@ -17,5 +17,6 @@
       val dropProfile: Program.t -> Program.t
       val eliminateDeadBlocksFunction: Function.t -> Function.t
       val eliminateDeadBlocks: Program.t -> Program.t
+      val orderFunctions: Program.t -> Program.t
       val reverseFunctions: Program.t -> Program.t
    end

Modified: mlton/trunk/mlton/ssa/simplify.fun
===================================================================
--- mlton/trunk/mlton/ssa/simplify.fun	2007-07-14 18:01:57 UTC (rev 5775)
+++ mlton/trunk/mlton/ssa/simplify.fun	2007-07-17 15:17:21 UTC (rev 5776)
@@ -86,6 +86,7 @@
    {name = "redundant", doit = Redundant.redundant} ::
    {name = "knownCase", doit = KnownCase.simplify} ::
    {name = "removeUnused4", doit = RemoveUnused.remove} ::
+   {name = "orderFunctions1", doit = S.orderFunctions} ::
    nil
 
 val ssaPassesMinimal =
@@ -200,6 +201,7 @@
                  ("breakCriticalEdges",fn p => 
                   S.breakCriticalEdges (p, {codeMotion = true})),
                  ("eliminateDeadBlocks",S.eliminateDeadBlocks),
+                 ("orderFunctions",S.orderFunctions),
                  ("reverseFunctions",S.reverseFunctions),
                  ("shrink", S.shrink)], 
                 mkSimplePassGen))

Modified: mlton/trunk/mlton/ssa/simplify2.fun
===================================================================
--- mlton/trunk/mlton/ssa/simplify2.fun	2007-07-14 18:01:57 UTC (rev 5775)
+++ mlton/trunk/mlton/ssa/simplify2.fun	2007-07-17 15:17:21 UTC (rev 5776)
@@ -40,8 +40,8 @@
    {name = "deepFlatten", doit = DeepFlatten.flatten} ::
    {name = "refFlatten", doit = RefFlatten.flatten} ::
    {name = "removeUnused5", doit = RemoveUnused2.remove} ::
-   {name = "removeUnused5Shrink", doit = S.shrink} ::
    {name = "zone", doit = Zone.zone} ::
+   {name = "orderFunctions2", doit = S.orderFunctions} ::
    nil
 
 val ssa2PassesMinimal =
@@ -69,6 +69,7 @@
                 ("removeUnused", RemoveUnused2.remove), 
                 ("zone", Zone.zone),
                 ("eliminateDeadBlocks",S.eliminateDeadBlocks),
+                ("orderFunctions",S.orderFunctions),
                 ("reverseFunctions",S.reverseFunctions),
                 ("shrink", S.shrink)],
                mkSimplePassGen)

Modified: mlton/trunk/mlton/ssa/ssa-tree.fun
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree.fun	2007-07-14 18:01:57 UTC (rev 5775)
+++ mlton/trunk/mlton/ssa/ssa-tree.fun	2007-07-17 15:17:21 UTC (rev 5776)
@@ -1692,6 +1692,43 @@
             NONE => Error.bug "SsaTree.Program.mainFunction: no main function"
           | SOME f => f
 
+      fun dfs (p, v) =
+         let
+            val T {functions, main, ...} = p
+            val functions = Vector.fromList functions
+            val numFunctions = Vector.length functions
+            val {get = funcIndex, set = setFuncIndex, rem, ...} =
+               Property.getSetOnce (Func.plist,
+                                    Property.initRaise ("index", Func.layout))
+            val _ = Vector.foreachi (functions, fn (i, f) =>
+                                     setFuncIndex (#name (Function.dest f), i))
+            val visited = Array.array (numFunctions, false)
+            fun visit (f: Func.t): unit =
+               let
+                  val i = funcIndex f
+               in
+                  if Array.sub (visited, i)
+                     then ()
+                  else
+                     let
+                        val _ = Array.update (visited, i, true)
+                        val f = Vector.sub (functions, i)
+                        val v' = v f
+                        val _ = Function.dfs 
+                                (f, fn Block.T {transfer, ...} =>
+                                 (Transfer.foreachFunc (transfer, visit)
+                                  ; fn () => ()))
+                        val _ = v' ()
+                     in
+                        ()
+                     end
+               end
+            val _ = visit main
+            val _ = Vector.foreach (functions, rem o Function.name)
+         in
+            ()
+         end
+
       fun profile (T {datatypes, functions, globals, main}) =
          let
             val functions =

Modified: mlton/trunk/mlton/ssa/ssa-tree.sig
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree.sig	2007-07-14 18:01:57 UTC (rev 5775)
+++ mlton/trunk/mlton/ssa/ssa-tree.sig	2007-07-17 15:17:21 UTC (rev 5776)
@@ -252,6 +252,11 @@
 
             val clear: t -> unit
             val clearTop: t -> unit
+            (* dfs (p, v) visits the functions in depth-first order, applying v f
+             * for function f to yield v', then visiting f's descendents,
+             * then applying v' ().
+             *)
+            val dfs: t * (Function.t -> unit -> unit) -> unit
             val foreachPrim: t * (Type.t Prim.t -> unit) -> unit
             val foreachVar: t * (Var.t * Type.t -> unit) -> unit
             val hasPrim: t * (Type.t Prim.t -> bool) -> bool

Modified: mlton/trunk/mlton/ssa/ssa-tree2.fun
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree2.fun	2007-07-14 18:01:57 UTC (rev 5775)
+++ mlton/trunk/mlton/ssa/ssa-tree2.fun	2007-07-17 15:17:21 UTC (rev 5776)
@@ -2138,6 +2138,43 @@
                            if f prim then escape true else ())
            ; false))
 
+      fun dfs (p, v) =
+         let
+            val T {functions, main, ...} = p
+            val functions = Vector.fromList functions
+            val numFunctions = Vector.length functions
+            val {get = funcIndex, set = setFuncIndex, rem, ...} =
+               Property.getSetOnce (Func.plist,
+                                    Property.initRaise ("index", Func.layout))
+            val _ = Vector.foreachi (functions, fn (i, f) =>
+                                     setFuncIndex (#name (Function.dest f), i))
+            val visited = Array.array (numFunctions, false)
+            fun visit (f: Func.t): unit =
+               let
+                  val i = funcIndex f
+               in
+                  if Array.sub (visited, i)
+                     then ()
+                  else
+                     let
+                        val _ = Array.update (visited, i, true)
+                        val f = Vector.sub (functions, i)
+                        val v' = v f
+                        val _ = Function.dfs 
+                                (f, fn Block.T {transfer, ...} =>
+                                 (Transfer.foreachFunc (transfer, visit)
+                                  ; fn () => ()))
+                        val _ = v' ()
+                     in
+                        ()
+                     end
+               end
+            val _ = visit main
+            val _ = Vector.foreach (functions, rem o Function.name)
+         in
+            ()
+         end
+
       fun profile (T {datatypes, functions, globals, main}) =
          let
             val functions =

Modified: mlton/trunk/mlton/ssa/ssa-tree2.sig
===================================================================
--- mlton/trunk/mlton/ssa/ssa-tree2.sig	2007-07-14 18:01:57 UTC (rev 5775)
+++ mlton/trunk/mlton/ssa/ssa-tree2.sig	2007-07-17 15:17:21 UTC (rev 5776)
@@ -280,6 +280,11 @@
 
             val clear: t -> unit
             val clearTop: t -> unit
+            (* dfs (p, v) visits the functions in depth-first order, applying v f
+             * for function f to yield v', then visiting f's descendents,
+             * then applying v' ().
+             *)
+            val dfs: t * (Function.t -> unit -> unit) -> unit
             val foreachPrimApp:
                t * ({args: Var.t vector, prim: Type.t Prim.t} -> unit) -> unit
             val foreachVar: t * (Var.t * Type.t -> unit) -> unit




More information about the MLton-commit mailing list