[dom] Dominance tree computation

Note: not complete right now. Skeleton and part of the meat is there though.

src/Makefile

@@ -5,6 +5,7 @@ MLS= \
 		 SSA.ml \
 		 CPS.ml \
 		 CPS_diff.ml \
+		 dom.ml \
 		 SSA2CPS.ml \
 		 difftest.ml
 
@@ -17,8 +18,9 @@ MLIS=$(MLS:.ml=.mli)
 CMIS=$(MLS:.ml=.cmi)
 
 
-LIBXS=
+LIBXS=$(shell ocamlfind query ocamlgraph)/graph.cmxa
 LIBS=$(LIBXS:.cmxa=.cma)
+LIBDIRS=$(shell ocamlfind query ocamlgraph)
 
 
 BINNAME=run
@@ -58,11 +60,11 @@ depend: $(MLS) $(MLIS)
 -include .depend
 
 %.cmo: %.ml
-	$(OCAMLC) -c $<
+	$(OCAMLC) -I $(LIBDIRS) -c $<
 
 %.cmi: %.mli
-	$(OCAMLC) -c $<
+	$(OCAMLC) -I $(LIBDIRS) -c $<
 
 %.cmx: %.ml
-	$(OCAMLOPT) -c $<
+	$(OCAMLOPT) -I $(LIBDIRS) -c $<
 

src/SSA2CPS.ml

@@ -16,23 +16,12 @@
   * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    *
   * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  *
   * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           *
-  *                                                                          *)
-
+  * }}}                                                                      *)
 
 let block_of_label bs l =
   List.find (fun b -> b.SSA.b_label = l) bs
 
-let immediate_dominatees bs b =
-  (* /!\ WARNING /!\ temp version causes infinite loops on non-DAG graphs /!\ *)
-  (* /!\ WARNING /!\ really! *will* cause loops in the translation! *)
-
-  match b.SSA.b_jump with
-  | SSA.Jgoto l -> [block_of_label bs l]
-  | SSA.Jreturn _ | SSA.Jtail _ -> []
-  | SSA.Jcond (_, l1, l2) -> [block_of_label bs l1; block_of_label bs l2]
-
-
-let rec block return bs ({SSA.b_label; b_phis; b_assigns; b_jump;} as b) =
+let rec block idom return bs ({SSA.b_label; b_phis; b_assigns; b_jump;} as b) =
 
   let args_of_label l =
     List.map
@@ -43,7 +32,7 @@ let rec block return bs ({SSA.b_label; b_phis; b_assigns; b_jump;} as b) =
   let rec aux = function
     | SSA.Aexpr (x, e)     :: l -> CPS.Mlet (x, e,  aux l)
     | SSA.Acall (x, f, es) :: l -> CPS.Mapp (f, es, CPS.C (x, aux l))
-    | [] -> match b_jump with
+    | [] -> match b_jump with (*somehow ugly*)
       | SSA.Jgoto l ->
           CPS.Mcont ((Prim.var_of_label l), (args_of_label l))
       | SSA.Jreturn e ->
@@ -57,42 +46,42 @@ let rec block return bs ({SSA.b_label; b_phis; b_assigns; b_jump;} as b) =
           )
   in
 
-  match immediate_dominatees bs b with
+  match Dom.G.pred idom b with
   | [] -> aux b_assigns
   | l  ->
     let l =
       List.map
-        (fun b ->
+        (fun b -> (*terminates bc dominator tree is a DAG*)
+          let lbl = Prim.var_of_label b.SSA.b_label in
           let vs = List.map fst b.SSA.b_phis in
-          (Prim.var_of_label b.SSA.b_label,
-           CPS.Ljump (vs, block return bs b) (*terminates bc dominator tree is a DAG*)
-          )
+          let lambda = CPS.Ljump (vs, block idom return bs b) in
+          (lbl, lambda)
         )
         l
     in
     CPS.Mrec (l, aux b_assigns)
 
 
 
-and proc {SSA.p_args; p_blocks;} =
+and proc idom {SSA.p_args; p_blocks;} =
   match p_blocks with
   | [] -> failwith "Can't translate empty ssa procedure into cps"
   | h::_ ->
     let return = Prim.fresh_var () in
-    CPS.Lproc (p_args, return, block return p_blocks h)
+    CPS.Lproc (p_args, return, block idom return p_blocks h)
 
 and prog proclist cont =
-  match proclist with
-  | [] -> failwith "Can't translate empty ssa program into cps"
-  | _ ->
+  if proclist = [] then
+    failwith "Can't translate empty ssa program into cps"
+  else
+    (* we need immediate dominatees for the translation *)
+    let idom = Dom.dom_of_graph (Dom.graph_of_ssa proclist) in
     let lambdas =
       List.map
        (fun p ->
-         let l = proc p in
-         (
-           (Prim.var_of_label (List.hd p.SSA.p_blocks).SSA.b_label),
-            l
-         )
+         let lambda = proc idom p in
+         let lbl= Prim.var_of_label (List.hd p.SSA.p_blocks).SSA.b_label in
+         (lbl, lambda)
        )
        proclist
     in

src/SSA2CPS.mli

@@ -18,6 +18,6 @@
   * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           *
   * }}}                                                                      *)
 
-val block : Prim.var -> SSA.block list -> SSA.block -> CPS.m
-val proc : SSA.proc -> CPS.lambda
+val block : Dom.G.t -> Prim.var -> SSA.block list -> SSA.block -> CPS.m
+val proc : Dom.G.t -> SSA.proc -> CPS.lambda
 val prog : SSA.proc list -> CPS.cont -> CPS.m

src/dom.ml

@@ -0,0 +1,72 @@
+ (* {{{ LICENSE                                                              *
+  * vi: set fdm=marker fdl=0:                                                *
+  *                                                                          *
+  * Copyright (c) 2012 Raphaël Proust <raphlalou@gmail.com>                  *
+  * Copyright (c) 2012 INRIA - Raphaël Proust <raphlalou@gmail.com>          *
+  * Copyright (c) 2012 ENS - Raphaël Proust <raphlalou@gmail.com>            *
+  *                                                                          *
+  * Permission to use, copy, modify, and distribute this software for any    *
+  * purpose with or without fee is hereby granted, provided that the above   *
+  * copyright notice and this permission notice appear in all copies.        *
+  *                                                                          *
+  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES *
+  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         *
+  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  *
+  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   *
+  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    *
+  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  *
+  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           *
+  * }}}                                                                      *)
+
+module Vertex = struct
+  type t = SSA.block
+  let compare = Pervasives.compare
+  let hash    = Hashtbl.hash
+  let equal   = (=)
+end
+
+module G = Graph.Persistent.Digraph.ConcreteBidirectional(Vertex)
+
+(* *VERY* inefficient! *)
+let block_of_label_proc proc label =
+  List.find (fun p -> p.SSA.b_label = label) proc.SSA.p_blocks
+
+let block_of_label prog label =
+  let rec aux = function
+    | [] -> raise Not_found
+    | h::t ->
+      try
+        block_of_label_proc h label
+      with
+        | Not_found -> aux t
+  in
+  aux prog
+
+(*TODO? how to handle inter-procedure calls *)
+
+let vertices_of_block prog proc b =
+  match b.SSA.b_jump with
+  | SSA.Jreturn _ | SSA.Jtail _ -> []
+  | SSA.Jgoto label -> [G.E.create b () (block_of_label_proc proc label)]
+  | SSA.Jcond (_, label1, label2) ->
+    [G.E.create b () (block_of_label_proc proc label1);
+     G.E.create b () (block_of_label_proc proc label2);
+    ]
+
+let graph_of_ssa prog =
+  List.fold_left
+    (fun g proc ->
+      List.fold_left
+        (fun g block ->
+          List.fold_left
+            G.add_edge_e
+            g
+            (vertices_of_block prog proc block)
+        )
+        g
+        proc.SSA.p_blocks
+    )
+    G.empty
+    prog
+
+let dom_of_graph g = failwith "TODO"

src/dom.mli

@@ -0,0 +1,31 @@
+ (* {{{ LICENSE                                                              *
+  * vi: set fdm=marker fdl=0:                                                *
+  *                                                                          *
+  * Copyright (c) 2012 Raphaël Proust <raphlalou@gmail.com>                  *
+  * Copyright (c) 2012 INRIA - Raphaël Proust <raphlalou@gmail.com>          *
+  * Copyright (c) 2012 ENS - Raphaël Proust <raphlalou@gmail.com>            *
+  *                                                                          *
+  * Permission to use, copy, modify, and distribute this software for any    *
+  * purpose with or without fee is hereby granted, provided that the above   *
+  * copyright notice and this permission notice appear in all copies.        *
+  *                                                                          *
+  * THE SOFTWARE IS PROVIDED "AS IS" AND THE AUTHOR DISCLAIMS ALL WARRANTIES *
+  * WITH REGARD TO THIS SOFTWARE INCLUDING ALL IMPLIED WARRANTIES OF         *
+  * MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR  *
+  * ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES   *
+  * WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR PROFITS, WHETHER IN AN    *
+  * ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS ACTION, ARISING OUT OF  *
+  * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE.           *
+  * }}}                                                                      *)
+
+module G : Graph.Sig.P with type V.t = SSA.block
+                        and type V.label = SSA.block
+                        and type E.t = SSA.block * SSA.block
+                        and type E.label = unit
+
+(* Changes the representation of an SSA [prog]ram to a "proper" graph. *)
+val graph_of_ssa: SSA.prog -> G.t
+
+(* Computes the dominator tree of a graph. It uses the "Simple, Fast Dominace
+ * Algorithm" of Cooper, Harvey and Kennedy. *)
+val dom_of_graph: G.t -> G.t