[MLton] Faster dominators for MLton

[Vesa Karvonen]

I was reading up on compiler optimizations and got interested in the
computation of dominators.  So, looking for dominator algorithms, I
stumbled upon the following paper:

   A Simple, Fast Dominance Algorithm.
   Keith Cooper and Timothy Harvey and Ken Kennedy.
   Software Practice and Experience, 2001.
   http://citeseer.ist.psu.edu/cooper01simple.html
   http://www.cs.rice.edu/~keith/EMBED/dom.pdf

The algorithm described in the paper is O(N^2), but the paper reports that
it runs faster, in practice, than the classic Lengauer-Tarjan algorithm.
I was a bit worried by the O(N^2) bound, because, I assume, MLton computes
dominators for the whole program, but decided to try to implement it
anyway.  To my delight, it turns out that the implementation seems to run
in less than half the time (on a self compile as reported with -verbose 3
for the contify{1,2,3} passes) as the previous Lengauer-Tarjan
implementation used in MLton and took about half the amount of code to
implement.  Much of the speed up probably comes from less memory being
used and the use of (faster) arrays rather than (slower) property lists.  All
regressions seem to pass.

So, although the computation of dominators is hardly a bottleneck, it
probably makes sense to use the simpler and faster algorithm.  If you want
to try the algorithm, try the below patch.  If this seems reasonable, I'll
reformat the code to fit MLton's conventions and remove the previous
implementation (you can always find it from the SVN) before committing.

-Vesa Karvonen

Index: directed-graph.sml
===================================================================
--- directed-graph.sml	(revision 6609)
+++ directed-graph.sml	(working copy)
@@ -313,24 +313,6 @@
 (*                    Dominators                          *)
 (*--------------------------------------------------------*)

-(* This is an implementation of the Lengauer/Tarjan dominator algorithm, as
- * described on p. 185-191 of Muchnick's "Advanced Compiler Design and
- * Implementation"
- *)
-structure NodeInfo =
-   struct
-      type t = {ancestor: Node.t ref,
-                bucket: Node.t list ref,
-                child: Node.t ref,
-                dfn: int ref, (* depth first number *)
-                idom: Node.t ref,
-                label: Node.t ref,
-                parent: Node.t ref,
-                preds: Node.t list ref,
-                sdno: int ref, (* semidominator dfn *)
-                size: int ref}
-   end
-
 fun validDominators (graph,
                      {root: Node.t,
                       idom: Node.t -> Node.t}): bool =
@@ -360,10 +342,120 @@

 datatype 'a idomRes =
    Idom of Node.t
-  | Root
-  | Unreachable
+ | Root
+ | Unreachable

-fun dominators (graph, {root}) =
+(* This is an implementation of the simple and fast dominance algorithm
+ * described in
+ *
+ *   A Simple, Fast Dominance Algorithm.
+ *   Keith Cooper and Timothy Harvey and Ken Kennedy.
+ *   Software Practice and Experience, 2001.
+ *   http://citeseer.ist.psu.edu/cooper01simple.html
+ *   http://www.cs.rice.edu/~keith/EMBED/dom.pdf
+ *
+ * This implementation replaced the previous implementation based on the
+ * Lengauer/Tarjan algorithm, as described on p. 185-191 of Muchnick's
+ * "Advanced Compiler Design and Implementation", and appears to run in
+ * less than half the time on a self compile and took about half the
+ * amount of code to implement.
+ *)
+fun dominators (graph, {root}) = let
+   val unknown = ~2
+   val visiting = ~1
+
+   val {get = getNum, set = setNum, rem = remNum, ...} =
+       Property.getSet (Node.plist, Property.initConst unknown)
+
+   val numNodes = numNodes graph
+
+   val nodes = Array.array (numNodes, root)
+   fun getNode i = Array.sub (nodes, i)
+   fun setNode (i, n) = Array.update (nodes, i, n)
+
+   val counter = ref 0
+   fun dfs v =
+       (setNum (v, visiting)
+      ; List.foreach
+         (Node.successors v,
+          fn Edge.Edge {to, ...} =>
+             if getNum to = unknown then dfs to else ())
+      ; case !counter
+         of i => (counter := i+1 ; setNum (v, i) ; setNode (i, v)))
+   val () = dfs root
+   val numNodes = !counter
+
+   val preds = Array.array (numNodes, [])
+   fun addPred (to, from) =
+       Array.update (preds, to, from :: Array.sub (preds, to))
+   fun getPreds i = Array.sub (preds, i)
+
+   val () = Int.for (0, numNodes, fn i =>
+            List.foreach (Node.successors (getNode i), fn Edge.Edge
{to, ...} =>
+            addPred (getNum to, i)))
+
+   val () = Array.foreach (nodes, remNum)
+
+   val idom = Array.array (numNodes, unknown)
+   fun getIdom i = Array.sub (idom, i)
+   fun setIdom (i, d) = Array.update (idom, i, d)
+   val () = setIdom (numNodes-1, numNodes-1)
+
+   fun intersect n1 n2 =
+       if n1 = n2 then n1 else let
+          fun up from to = if from < to then up (getIdom from) to else from
+          val n1 = up n1 n2
+          val n2 = up n2 n1
+       in
+          intersect n1 n2
+       end
+
+   fun iterate () = let
+      val changed = ref false
+   in
+      Int.forDown (0, numNodes-1, fn i => let
+         val new = case getPreds i
+                    of [] => raise Fail "bug"
+                     | p::ps =>
+                       List.fold (ps, p, fn (j, new) =>
+                       if getIdom j <> unknown then intersect new j else new)
+      in
+         if getIdom i <> new
+         then (setIdom (i, new) ; changed := true)
+         else ()
+      end)
+    ; if !changed then iterate () else ()
+   end
+   val () = iterate ()
+
+   val {get = idomFinal, set = setIdom, ...} =
+       Property.getSetOnce (Node.plist, Property.initConst Unreachable)
+   val () = setIdom (root, Root)
+   val () = Int.for (0, numNodes-1, fn i =>
+            setIdom (getNode i, Idom (getNode (getIdom i))))
+in
+   {idom = idomFinal}
+end
+
+(* This is an implementation of the Lengauer/Tarjan dominator algorithm, as
+ * described on p. 185-191 of Muchnick's "Advanced Compiler Design and
+ * Implementation"
+ *)
+structure NodeInfo =
+   struct
+      type t = {ancestor: Node.t ref,
+                bucket: Node.t list ref,
+                child: Node.t ref,
+                dfn: int ref, (* depth first number *)
+                idom: Node.t ref,
+                label: Node.t ref,
+                parent: Node.t ref,
+                preds: Node.t list ref,
+                sdno: int ref, (* semidominator dfn *)
+                size: int ref}
+   end
+
+fun dominators' (graph, {root}) =
    let
       val n0 = Node.new ()
       fun newNode (n: Node.t): NodeInfo.t =