From 032fe693ef3041292d9f302d1bd0c4359112a12f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= <cedric.pasteur@ens.fr>
Date: Thu, 21 Apr 2011 11:24:04 +0200
Subject: [PATCH] Deadcode removal pass

---
 compiler/obc/control.ml                  | 11 -----
 compiler/obc/main/obc_compiler.ml        |  3 ++
 compiler/obc/obc_compare.ml              | 60 ++++++++++++++++++++++++
 compiler/obc/transformations/deadcode.ml | 29 ++++++++++++
 4 files changed, 92 insertions(+), 11 deletions(-)
 create mode 100644 compiler/obc/obc_compare.ml
 create mode 100644 compiler/obc/transformations/deadcode.ml

diff --git a/compiler/obc/control.ml b/compiler/obc/control.ml
index 9fe3dfc..3f18218 100644
--- a/compiler/obc/control.ml
+++ b/compiler/obc/control.ml
@@ -25,18 +25,7 @@ let rec find c = function
   | (c1, s1) :: h  ->
       if c = c1 then s1, h else let s, h = find c h in s, (c1, s1) :: h
 
-let is_deadcode = function
-    | Aassgn (lhs, e) ->
-        (match e.e_desc with
-           | Epattern l -> l = lhs
-           | _ -> false
-        )
-    | Acase (_, []) -> true
-    | Afor(_, _, _, { b_body = [] }) -> true
-    | _ -> false
-
 let rec joinlist l =
-  let l = List.filter (fun a -> not (is_deadcode a)) l in
     match l with
       | [] -> []
       | [s1] -> [s1]
diff --git a/compiler/obc/main/obc_compiler.ml b/compiler/obc/main/obc_compiler.ml
index 333c3c0..e1fc3b4 100644
--- a/compiler/obc/main/obc_compiler.ml
+++ b/compiler/obc/main/obc_compiler.ml
@@ -20,4 +20,7 @@ let compile_program p =
   (* Memory allocation application *)
   let p = pass "Application of Memory Allocation" !do_mem_alloc Memalloc_apply.program p pp in
 
+  (*Dead code removal*)
+  let p = pass "Dead code removal" !do_mem_alloc Deadcode.program p pp in
+
   p
diff --git a/compiler/obc/obc_compare.ml b/compiler/obc/obc_compare.ml
new file mode 100644
index 0000000..f0048ef
--- /dev/null
+++ b/compiler/obc/obc_compare.ml
@@ -0,0 +1,60 @@
+open Obc
+open Idents
+open Global_compare
+open Misc
+
+let rec pat_compare pat1 pat2 =
+  let cr = type_compare pat1.pat_ty pat2.pat_ty in
+  if cr <> 0 then cr
+  else
+    match pat1.pat_desc, pat2.pat_desc with
+      | Lvar x1, Lvar x2 -> ident_compare x1 x2
+      | Lmem x1, Lmem x2 -> ident_compare x1 x2
+      | Lfield(r1, f1), Lfield(r2, f2) ->
+          let cr = compare f1 f2 in
+            if cr <> 0 then cr else pat_compare r1 r2
+      | Larray(l1, e1), Larray(l2, e2) ->
+          let cr = pat_compare l1 l2 in
+            if cr <> 0 then cr else exp_compare e1 e2
+      | Lvar _, _ -> 1
+
+      | Lmem _, Lvar _ -> -1
+      | Lmem _, _ -> 1
+
+      | Lfield _, (Lvar _ | Lmem _) -> -1
+      | Lfield _, _ -> 1
+
+      | Larray _, _ -> -1
+
+
+and exp_compare e1 e2 =
+  let cr = type_compare e1.e_ty e2.e_ty in
+  if cr <> 0 then cr
+  else
+    match e1.e_desc, e2.e_desc with
+      | Epattern pat1, Epattern pat2 -> pat_compare pat1 pat2
+      | Econst se1, Econst se2 -> static_exp_compare se1 se2
+      | Eop(op1, el1), Eop(op2, el2) ->
+          let cr = compare op1 op2 in
+            if cr <> 0 then cr else list_compare exp_compare el1 el2
+      | Estruct(_, fnel1), Estruct (_, fnel2) ->
+          let compare_fne (fn1, e1) (fn2, e2) =
+            let cr = compare fn1 fn2 in
+              if cr <> 0 then cr else exp_compare e1 e2
+          in
+            list_compare compare_fne fnel1 fnel2
+      | Earray el1, Earray el2 ->
+          list_compare exp_compare el1 el2
+
+      | Epattern _, _ -> 1
+
+      | Econst _, Epattern _ -> -1
+      | Econst _, _ -> 1
+
+      | Eop _, (Epattern _ | Econst _) -> -1
+      | Eop _, _ -> 1
+
+      | Estruct _, (Epattern _ | Econst _ | Eop _) -> -1
+      | Estruct _, _ -> 1
+
+      | Earray _, _ -> -1
diff --git a/compiler/obc/transformations/deadcode.ml b/compiler/obc/transformations/deadcode.ml
new file mode 100644
index 0000000..b73bdf0
--- /dev/null
+++ b/compiler/obc/transformations/deadcode.ml
@@ -0,0 +1,29 @@
+open Obc
+open Obc_mapfold
+
+let is_deadcode = function
+    | Aassgn (lhs, e) ->
+        (match e.e_desc with
+           | Epattern l -> Obc_compare.pat_compare l lhs = 0
+           | _ -> false
+        )
+    | Acase (_, []) -> true
+    | Afor(_, _, _, { b_body = [] }) -> true
+    | _ -> false
+
+let act funs act_list a =
+  let a, _ = Obc_mapfold.act funs [] a in
+    if is_deadcode a then
+      a, act_list
+    else
+      a, a::act_list
+
+let block funs acc b =
+  let _, act_list = Obc_mapfold.block funs [] b in
+    { b with b_body = List.rev act_list }, acc
+
+let program p =
+  let funs = { Obc_mapfold.defaults with block = block; act = act } in
+  let p, _ = Obc_mapfold.program_it funs [] p in
+    p
+