--- /dev/null
+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