optimize/constfold.sml

   1 structure ConstantFold :> OPTIMIZATION =
   2 struct
   3   structure T = Tree
   4
   5 (*  fun isconstret (T.FUNCTION (id, stml)) = foldr (fn (l,(b)) => noeffect l andalso ) true stml *)
   6
   7   fun operate (T.ADD)    a b = a + b
   8     | operate (T.SUB)    a b = a - b
   9     | operate (T.MUL)    a b = a * b
  10     | operate (T.DIV)    a b = Word32Signed.adiv (a,b)
  11     | operate (T.MOD)    a b = Word32Signed.amod (a,b)
  12     | operate (T.LSH)    a b = Suq.Word32_lsh (a, Word32.mod (b, 0w32))
  13     | operate (T.RSH)    a b = Suq.Word32_rsh (a, Word32.mod (b, 0w32))
  14     | operate (T.BITOR)  a b = Word32.orb (a,b)
  15     | operate (T.BITAND) a b = Word32.andb (a,b)
  16     | operate (T.BITXOR) a b = Word32.xorb (a,b)
  17     | operate (T.LOGOR)  a b = if (a <> 0w0 orelse b <> 0w0) then 0w1 else 0w0
  18     | operate (T.LOGAND) a b = if (a <> 0w0 andalso b <> 0w0) then 0w1 else 0w0
  19     | operate (T.NEQ)    a b = if (a <> b) then 0w1 else 0w0
  20     | operate (T.EQ)     a b = if (a = b) then 0w1 else 0w0
  21     | operate (T.LT)     a b = if (Word32Signed.lt (a,b)) then 0w1 else 0w0
  22     | operate (T.GT)     a b = if (Word32Signed.gt (a,b)) then 0w1 else 0w0
  23     | operate (T.LE)     a b = if (Word32Signed.le (a,b)) then 0w1 else 0w0
  24     | operate (T.GE)     a b = if (Word32Signed.ge (a,b)) then 0w1 else 0w0
  25     | operate (T.BE)     a b = if (Word32.>= (a,b)) then 0w1 else 0w0
  26
  27   fun operate_unop (T.NEG)    a = 0w0 - a
  28     | operate_unop (T.BITNOT) a = Word32.notb a
  29     | operate_unop (T.BANG)   a = if (a = 0w0) then 0w1 else 0w0
  30
  31   fun foldexp (T.BINOP(oper, e1, e2)) =
  32         let
  33           val f1 = foldexp e1
  34           val f2 = foldexp e2
  35         in
  36           case f1
  37           of T.CONST n1 => (case f2
  38                             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))
  39                              | _ => T.BINOP(oper, T.CONST n1, f2))
  40            | _ => T.BINOP (oper, f1, f2)
  41         end
  42     | foldexp (T.UNOP(oper, e)) = (case foldexp e of T.CONST n => T.CONST (operate_unop oper n) | a => T.UNOP(oper, a))
  43     | foldexp (T.CONST(n)) = T.CONST n
  44     | foldexp (T.TEMP(t)) = T.TEMP t
  45     | foldexp (T.ARG(n)) = T.ARG n
  46     | foldexp (T.CALL(id, l, n)) = T.CALL (id, List.map (fn (a,n) => (foldexp a, n)) l, n)
  47     | foldexp (T.MEMORY (e, s)) = T.MEMORY (foldexp e, s)
  48     | foldexp (T.ALLOC (e)) = T.ALLOC (foldexp e)
  49     | foldexp (T.STMVAR (sl, e)) = T.STMVAR (List.map foldstm sl, foldexp e)
  50     | foldexp (T.COND (c, e1, e2)) =
  51         let
  52           val f1 = foldexp e1
  53           val f2 = foldexp e2
  54         in
  55           case foldexp c
  56           of T.CONST n => if n <> 0w0 then f1 else f2
  57            | a => T.COND (a, f1, f2)
  58         end
  59     | foldexp (T.NULLPTR) = T.NULLPTR
  60
  61   and foldstm (T.MOVE (e1, e2)) = T.MOVE (foldexp e1, foldexp e2)
  62     | foldstm (T.RETURN (e, s)) = T.RETURN (foldexp e, s)
  63     | foldstm (T.EFFECT e) = T.EFFECT (foldexp e)
  64     | foldstm (a as T.LABEL _) = a
  65     | foldstm (T.JUMPIFN (e, l)) = T.JUMPIFN (foldexp e, l)
  66     | foldstm (a as T.JUMP _) = a
  67
  68   val optimizer = { shortname = "constant-fold", description = "Folds constant expressions into constants", func = Optimizer.IREXP foldexp }
  69 end