Initial import of l5c

[snipe.git] / optimize / constfold.sml

diff --git a/optimize/constfold.sml b/optimize/constfold.sml
new file mode 100644 (file)
index 0000000..43e9d38
--- /dev/null
+++ b/optimize/constfold.sml
@@ -0,0 +1,69 @@
+structure ConstantFold :> OPTIMIZATION =
+struct
+  structure T = Tree
+
+(*  fun isconstret (T.FUNCTION (id, stml)) = foldr (fn (l,(b)) => noeffect l andalso ) true stml *)
+
+  fun operate (T.ADD)    a b = a + b
+    | operate (T.SUB)    a b = a - b
+    | operate (T.MUL)    a b = a * b
+    | operate (T.DIV)    a b = Word32Signed.adiv (a,b)
+    | operate (T.MOD)    a b = Word32Signed.amod (a,b)
+    | operate (T.LSH)    a b = Suq.Word32_lsh (a, Word32.mod (b, 0w32))
+    | operate (T.RSH)    a b = Suq.Word32_rsh (a, Word32.mod (b, 0w32))
+    | operate (T.BITOR)  a b = Word32.orb (a,b)
+    | operate (T.BITAND) a b = Word32.andb (a,b)
+    | operate (T.BITXOR) a b = Word32.xorb (a,b)
+    | operate (T.LOGOR)  a b = if (a <> 0w0 orelse b <> 0w0) then 0w1 else 0w0
+    | operate (T.LOGAND) a b = if (a <> 0w0 andalso b <> 0w0) then 0w1 else 0w0
+    | operate (T.NEQ)    a b = if (a <> b) then 0w1 else 0w0
+    | operate (T.EQ)     a b = if (a = b) then 0w1 else 0w0
+    | operate (T.LT)     a b = if (Word32Signed.lt (a,b)) then 0w1 else 0w0
+    | operate (T.GT)     a b = if (Word32Signed.gt (a,b)) then 0w1 else 0w0
+    | operate (T.LE)     a b = if (Word32Signed.le (a,b)) then 0w1 else 0w0
+    | operate (T.GE)     a b = if (Word32Signed.ge (a,b)) then 0w1 else 0w0
+    | operate (T.BE)     a b = if (Word32.>= (a,b)) then 0w1 else 0w0
+
+  fun operate_unop (T.NEG)    a = 0w0 - a
+    | operate_unop (T.BITNOT) a = Word32.notb a
+    | operate_unop (T.BANG)   a = if (a = 0w0) then 0w1 else 0w0
+
+  fun foldexp (T.BINOP(oper, e1, e2)) =
+        let
+          val f1 = foldexp e1
+          val f2 = foldexp e2
+        in
+          case f1
+          of T.CONST n1 => (case f2
+                            of T.CONST n2 => (T.CONST (operate oper n1 n2) handle _ (* Might be either 'div' on smlnj or 'overflow' on mlton *) => T.BINOP(oper, T.CONST n1, T.CONST n2))
+                             | _ => T.BINOP(oper, T.CONST n1, f2))
+           | _ => T.BINOP (oper, f1, f2)
+        end
+    | foldexp (T.UNOP(oper, e)) = (case foldexp e of T.CONST n => T.CONST (operate_unop oper n) | a => T.UNOP(oper, a))
+    | foldexp (T.CONST(n)) = T.CONST n
+    | foldexp (T.TEMP(t)) = T.TEMP t
+    | foldexp (T.ARG(n)) = T.ARG n
+    | foldexp (T.CALL(id, l, n)) = T.CALL (id, List.map (fn (a,n) => (foldexp a, n)) l, n)
+    | foldexp (T.MEMORY (e, s)) = T.MEMORY (foldexp e, s)
+    | foldexp (T.ALLOC (e)) = T.ALLOC (foldexp e)
+    | foldexp (T.STMVAR (sl, e)) = T.STMVAR (List.map foldstm sl, foldexp e)
+    | foldexp (T.COND (c, e1, e2)) =
+        let
+          val f1 = foldexp e1
+          val f2 = foldexp e2
+        in
+          case foldexp c
+          of T.CONST n => if n <> 0w0 then f1 else f2
+           | a => T.COND (a, f1, f2)
+        end
+    | foldexp (T.NULLPTR) = T.NULLPTR
+
+  and foldstm (T.MOVE (e1, e2)) = T.MOVE (foldexp e1, foldexp e2)
+    | foldstm (T.RETURN (e, s)) = T.RETURN (foldexp e, s)
+    | foldstm (T.EFFECT e) = T.EFFECT (foldexp e)
+    | foldstm (a as T.LABEL _) = a
+    | foldstm (T.JUMPIFN (e, l)) = T.JUMPIFN (foldexp e, l)
+    | foldstm (a as T.JUMP _) = a
+
+  val optimizer = { shortname = "constant-fold", description = "Folds constant expressions into constants", func = Optimizer.IREXP foldexp }
+end