Initial import of l5c

[snipe.git] / optimize / stupidfunc.sml

diff --git a/optimize/stupidfunc.sml b/optimize/stupidfunc.sml
new file mode 100644 (file)
index 0000000..99bd6b0
--- /dev/null
+++ b/optimize/stupidfunc.sml
@@ -0,0 +1,58 @@
+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