Initial import of l5c

[snipe.git] / optimize / constfold.sml

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