Initial import of l5c

[snipe.git] / optimize / stupidfunc.sml

structure StupidFunctionElim :> OPTIMIZATION =
struct
  structure T = Tree
  structure TU = TreeUtils

  datatype rval = Any | Const of Word32.word

  fun stmhit NONE _ = NONE
    | stmhit _ (T.JUMPIFN _) = NONE
    | stmhit (SOME(Any)) (T.RETURN (T.CONST n, s)) = SOME(Const(n))
    | stmhit (SOME(Const(n))) (T.RETURN (T.CONST n',s)) = if n' = n then SOME(Const(n)) else NONE
    | stmhit _ (T.RETURN _) = NONE
    | stmhit opt s = if TU.effect_stm s then NONE else opt

  fun stupid (T.FUNCTION (id, fl)) = (foldr (fn (a,b) => stmhit b a) (SOME(Any)) fl, id)

  fun findstupids prog = foldr (fn ((SOME(Const(n)),id),b) => Symbol.bind b (id, SOME(n))
                                 | ((SOME(Any), id),b) => raise ErrorMsg.InternalError "wtf, this function no return"
                                 | ((NONE, id),b) => Symbol.bind b (id, NONE))
                               Symbol.empty
                               (List.map stupid prog)

  fun ds_exp t (T.CALL(id, l, s)) =
        let
          val effecting = List.mapPartial (fn (a,_) => if TU.effect a then SOME(ds_exp t a) else NONE) l
        in
          (case Symbol.look' t id
            of SOME(n) => T.STMVAR(List.map T.EFFECT effecting, T.CONST n)
            |  NONE => T.CALL(id, List.map (fn (a,i) => (ds_exp t a, i)) l, s))
          handle Option => T.CALL(id, List.map (fn (a,i) => (ds_exp t a, i)) l, s)
        end
    | ds_exp t (T.BINOP(oper, e1, e2)) = T.BINOP(oper, ds_exp t e1, ds_exp t e2)
    | ds_exp t (T.UNOP(oper, e)) = T.UNOP(oper, ds_exp t e)
    | ds_exp t (T.MEMORY (e,s)) = T.MEMORY (ds_exp t e, s)
    | ds_exp t (T.COND (c, e1, e2)) = T.COND (ds_exp t c, ds_exp t e1, ds_exp t e2)
    | ds_exp t (T.ALLOC e) = T.ALLOC (ds_exp t e)
    | ds_exp t (T.STMVAR (sl, e)) = T.STMVAR (List.map (ds_stm t) sl, ds_exp t e)
    | ds_exp t a = a

  and ds_stm t (T.MOVE (e1, e2)) = T.MOVE (ds_exp t e1, ds_exp t e2)
    | ds_stm t (T.RETURN (e, s)) = T.RETURN (ds_exp t e, s)
    | ds_stm t (T.EFFECT e) = T.EFFECT (ds_exp t e)
    | ds_stm t (a as T.LABEL _) = a
    | ds_stm t (T.JUMPIFN (e, l)) = T.JUMPIFN (ds_exp t e, l)
    | ds_stm t (a as T.JUMP _) = a

  fun diestupids prog =
    let
      val stupids = findstupids prog
      fun kill (T.FUNCTION (id, sl)) = T.FUNCTION (id, List.map (ds_stm stupids) sl)
    in
      List.map kill prog
    end

  val optimizer = { shortname = "stupidfn",
                    description = "Turns stupid functions with constant return and no side effect into constant",
                    func = Optimizer.IRPROG diestupids }
end