[MLton-commit] r5778

[Matthew Fluet]

Also put RSSA program into canonical order
----------------------------------------------------------------------

U   mlton/trunk/mlton/backend/backend.fun
U   mlton/trunk/mlton/backend/rssa.fun
U   mlton/trunk/mlton/backend/rssa.sig

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

Modified: mlton/trunk/mlton/backend/backend.fun
===================================================================
--- mlton/trunk/mlton/backend/backend.fun	2007-07-17 16:08:42 UTC (rev 5777)
+++ mlton/trunk/mlton/backend/backend.fun	2007-07-17 16:09:08 UTC (rev 5778)
@@ -176,6 +176,8 @@
                 suffix = "rssa",
                 thunk = fn () => Profile.profile program,
                 typeCheck = R.Program.typeCheck o #1}
+            val program =
+               maybePass ("rssaOrderFunctions", Rssa.Program.orderFunctions, program)
          in
             (program, makeProfileInfo)
          end

Modified: mlton/trunk/mlton/backend/rssa.fun
===================================================================
--- mlton/trunk/mlton/backend/rssa.fun	2007-07-17 16:08:42 UTC (rev 5777)
+++ mlton/trunk/mlton/backend/rssa.fun	2007-07-17 16:09:08 UTC (rev 5778)
@@ -422,6 +422,11 @@
                 func = Type.BuiltInCFunction.bug (),
                 return = NONE}
 
+      fun foreachFunc (t, f : Func.t -> unit) : unit =
+         case t of
+            Call {func, ...} => f func
+          | _ => ()
+
       fun 'a foldDefLabelUse (t, a: 'a,
                               {def: Var.t * Type.t * 'a -> 'a,
                                label: Label.t * 'a -> 'a,
@@ -907,6 +912,79 @@
       (* quell unused warning *)
       val _ = dropProfile
 
+      fun dfs (p, v) =
+         let
+            val T {functions, main, ...} = p
+            val functions = Vector.fromList (main::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 (Function.name main)
+            val _ = Vector.foreach (functions, rem o Function.name)
+         in
+            ()
+         end
+
+      fun orderFunctions (p as T {handlesSignals, objectTypes, ...}) =
+         let
+            val functions = ref []
+            val () =
+               dfs
+               (p, fn f =>
+                let
+                   val {args, 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),
+                                         name = name,
+                                         raises = raises,
+                                         returns = returns,
+                                         start = start}
+                in
+                   List.push (functions, f)
+                   ; fn () => ()
+                end)
+            val (main, functions) =
+               case List.rev (!functions) of
+                  main::functions => (main, functions)
+                | _ => Error.bug "Rssa.orderFunctions: main/functions"
+         in
+            T {functions = functions,
+               handlesSignals = handlesSignals,
+               main = main,
+               objectTypes = objectTypes}
+         end
+
       fun copyProp (T {functions, handlesSignals, main, objectTypes, ...}): t =
          let
             val tracePrimApply =

Modified: mlton/trunk/mlton/backend/rssa.sig
===================================================================
--- mlton/trunk/mlton/backend/rssa.sig	2007-07-17 16:08:42 UTC (rev 5777)
+++ mlton/trunk/mlton/backend/rssa.sig	2007-07-17 16:09:08 UTC (rev 5778)
@@ -152,6 +152,7 @@
             val foreachDefLabelUse: t * {def: Var.t * Type.t -> unit,
                                          label: Label.t -> unit,
                                          use: Var.t -> unit} -> unit
+            val foreachFunc: t * (Func.t -> unit) -> unit
             val foreachLabel: t * (Label.t -> unit) -> unit
             val foreachUse: t * (Var.t -> unit) -> unit
             val ifBool: Operand.t * {falsee: Label.t, truee: Label.t} -> t
@@ -225,8 +226,14 @@
 
             val clear: t -> unit
             val checkHandlers: t -> unit
+            (* dfs (p, v) visits the functions in depth-first order, applying v f
+             * for function f to yield v', then visiting b's descendents,
+             * then applying v' ().
+             *)
+            val dfs: t * (Function.t -> unit -> unit) -> unit
             val dropProfile: t -> t
             val layouts: t * (Layout.t -> unit) -> unit
+            val orderFunctions: t -> t
             val shrink: t -> t
             val typeCheck: t -> unit
          end