From 323302c6e590aad2e63958789a5a31c9edf490de Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Th=C3=A9ophile=20Bastian?= 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