[add peephole optimizations to grin optimizer, clean up code somewhat. always propegate grin constants
John Meacham <john@repetae.net>**20060124072015] hunk ./Grin/Simplify.hs 38
+at_OptSimplifyCopyPropConst  = toAtom "Optimize.simplify.copy-propagate-const"
hunk ./Grin/Simplify.hs 41
+at_OptSimplifyConstApply  = toAtom "Optimize.simplify.const-apply"
+at_OptSimplifyConstEval  = toAtom "Optimize.simplify.const-eval"
hunk ./Grin/Simplify.hs 45
+at_OptSimplifyConstStore  = toAtom "Optimize.simplify.const-store"
hunk ./Grin/Simplify.hs 60
+
hunk ./Grin/Simplify.hs 69
+        x <- gs x
hunk ./Grin/Simplify.hs 71
+    gs (Store n) | valIsNF n = do
+        lift $ tick stats at_OptSimplifyConstStore
+        gs (Return (Const n))
+    gs (App a [n@NodeC {},v] typ) | a == funcApply = do
+        lift $ tick stats at_OptSimplifyConstApply
+        gs (doApply n v typ)
+    gs (App a [Const n] typ) | a == funcEval = do
+        lift $ tick stats at_OptSimplifyConstEval
+        gs (Return n)
+    gs x = return x
hunk ./Grin/Simplify.hs 99
+        e <- gs e
hunk ./Grin/Simplify.hs 101
+            Return v | valIsNF v, Just n <- varBind' p v -> do
+                lift $ tick stats at_OptSimplifyCopyPropConst
+                modify (`mappend` (n,mempty))
+                return Nothing
hunk ./Grin/Simplify.hs 151
+doApply (NodeC t xs) y typ
+    | n == 1 = (App v (xs ++ [y]) typ)
+    | n > 1 = Return (NodeC (partialTag v (n - 1)) (xs ++ [y]))
+        where
+        Just (n,v) = tagUnfunction t
+doApply n y typ = error $ show ("doApply", n,y,typ)
+
+-- This only binds variables to variables
hunk ./Grin/Simplify.hs 169
+-- This binds variables to anything
+varBind' :: Monad m => Val -> Val -> m (Map Var Val)
+varBind' (Var v t) nv | t == getType nv = return $ Map.singleton v nv
+varBind' (Lit i t) (Lit i' t') | i == i' && t == t' = return mempty
+varBind' (Tup xs) (Tup ys) | length xs == length ys  = liftM mconcat $ sequence $  zipWith varBind' xs ys
+varBind' (Tag i) (Tag i') | i == i' = return mempty
+varBind' (NodeC t vs) (NodeC t' vs') | t == t' = do
+    liftM mconcat $ sequence $  zipWith varBind' vs vs'
+varBind' v r | (getType v) == (getType r)  = fail "unvarBind'able"    -- check type to be sure
+varBind' x y = error $ "varBind': " ++ show (x,y)
+
hunk ./Grin/Simplify.hs 207
+    --f (Case v [v2@(Var {} :-> _)]) = do
+    --    f (Return v :>>= v2)
+    --f (Case v [v2@(Var {} :-> _)] :>>= lr) = do
+    --    f ((Return v :>>= v2) :>>= lr)
+    f (Case n@NodeC {} as) = do
+        kc <- knownCase n as
+        f kc
+    f (Case n@NodeC {} as :>>= lr) = do
+        kc <- knownCase n as
+        f (kc :>>= lr)
hunk ./Grin/Simplify.hs 357
-            nl <- opt env a 0 l
+            nl <- opt env a (0::Int) l
hunk ./Grin/Simplify.hs 382
+
+