[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