From 323302c6e590aad2e63958789a5a31c9edf490de Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Th=C3=A9ophile=20Bastian?= <contact@tobast.fr>
Date: Fri, 16 Feb 2018 20:53:43 +0100
Subject: [PATCH] Add a naive constant propagation pass

---
 src/ConstantPropag.ml  | 64 ++++++++++++++++++++++++++++++++++++++++++
 src/ConstantPropag.mli |  1 +
 src/Main.ml            | 16 ++++++++++-
 3 files changed, 80 insertions(+), 1 deletion(-)
 create mode 100644 src/ConstantPropag.ml
 create mode 100644 src/ConstantPropag.mli

diff --git a/src/ConstantPropag.ml b/src/ConstantPropag.ml
new file mode 100644
index 0000000..bffb702
--- /dev/null
+++ b/src/ConstantPropag.ml
@@ -0,0 +1,64 @@
+module S = Top
+
+type consts_env = int Atom.Map.t
+
+type reduced_value = IntRed of int | ValRed of S.value
+let rec reduce_val env (v: S.value) = match v with
+| S.VVar var ->
+        (try IntRed (Atom.Map.find var env)
+        with Not_found -> ValRed (S.VVar var))
+| S.VLit x -> IntRed x
+| S.VBinOp (left, op, right) ->
+        let op_func = function
+            | S.OpAdd -> (+)
+            | S.OpSub -> (-)
+            | S.OpMul -> ( * )
+            | S.OpDiv -> (/)
+        in
+        let apply op l r = match (l, r) with
+        | IntRed l, IntRed r -> IntRed ((op_func op) l r)
+        | IntRed l, ValRed r -> ValRed (S.VBinOp (S.VLit l, op, r))
+        | ValRed l, IntRed r -> ValRed (S.VBinOp (l, op, S.VLit r))
+        | ValRed l, ValRed r -> ValRed (S.VBinOp (l, op, r))
+        in
+
+        let lVal = reduce_val env left
+        and rVal = reduce_val env right in
+        apply op lVal rVal
+
+let do_value env value = match reduce_val env value with
+| IntRed x -> S.VLit x
+| ValRed exp -> exp
+
+let do_block env (S.Con(tag, args)) =
+    S.Con (tag, List.map (do_value env) args)
+
+let rec do_term (env: consts_env) (t: S.term) = match t with
+| S.Exit -> S.Exit
+| S.TailCall (func, args) ->
+        S.TailCall (
+            func,
+            List.map (do_value env) args)
+| S.Print (value, next) ->
+        S.Print (
+            do_value env value,
+            do_term env next)
+| S.LetVal (var, value, next) ->
+        (match do_value env value with
+        | S.VLit x -> do_term (Atom.Map.add var x env) next
+        | value -> S.LetVal (var, value, do_term env next))
+| S.LetBlo (var, block, next) ->
+        S.LetBlo (var, do_block env block, do_term env next)
+| S.IfZero (cond, tIf, tElse) ->
+        S.IfZero (do_value env cond, do_term env tIf, do_term env tElse)
+| S.Swi (tag, branches) ->
+        S.Swi(tag, List.map (do_branch env) branches)
+
+and do_branch env (S.Branch (tag, args, body)) =
+    S.Branch (tag, args, do_term env body)
+
+let do_func (S.Fun (name, args, body)) =
+    S.Fun (name, args, do_term Atom.Map.empty body)
+
+let constant_propagation (S.Prog (funcs, body)) =
+    S.Prog (List.map do_func funcs, do_term Atom.Map.empty body)
diff --git a/src/ConstantPropag.mli b/src/ConstantPropag.mli
new file mode 100644
index 0000000..60517bd
--- /dev/null
+++ b/src/ConstantPropag.mli
@@ -0,0 +1 @@
+val constant_propagation: Top.program -> Top.program
diff --git a/src/Main.ml b/src/Main.ml
index 57a100c..1efc319 100644
--- a/src/Main.ml
+++ b/src/Main.ml
@@ -8,6 +8,9 @@ let debug =
 let light_debug =
     ref false
 
+let no_varvarbind = ref false
+let no_const_propagation = ref false
+
 let filenames =
   ref []
 
@@ -18,6 +21,10 @@ let options =
   Arg.align [
     "--debug", Arg.Set debug, " Enable debugging output";
     "--light-debug", Arg.Set light_debug, " Enable debugging output";
+    "--no-var-var-bind", Arg.Set no_varvarbind,
+        "Disable var/var bind suppression";
+    "--no-const-propagation", Arg.Set no_const_propagation,
+        "Disable constants propagation";
   ]
 
 let usage =
@@ -31,6 +38,9 @@ let debug =
 let light_debug =
   !light_debug
 
+let no_varvarbind = !no_varvarbind
+let no_const_propagation = !no_const_propagation
+
 let filenames =
   List.rev !filenames
 
@@ -85,6 +95,8 @@ let output (p : C.program) : unit =
 
 (* The complete processing pipeline. Beautiful, isn't it? *)
 
+let skip x = x
+
 let process filename =
   filename
   |> read
@@ -95,7 +107,9 @@ let process filename =
   |> dump "Tail" Tail.show_term false
   |> dump "PrettyTail" PrettyTail.show true
   |> Defun.defun_term
-  |> VarVarBind.clean_var_var_bind
+  |> (if no_varvarbind then skip else VarVarBind.clean_var_var_bind)
+  |> (if no_const_propagation then skip else
+      ConstantPropag.constant_propagation)
   |> dump "Top" Top.show_program false
   |> dump "PrettyTop" PrettyTop.show true
   |> Finish.finish_program