[implement CSE optimization in Grin.SSimplify
John Meacham <john@repetae.net>**20070603042335] hunk ./Grin/SSimplify.hs 5
+import qualified Data.Map as Map
hunk ./Grin/SSimplify.hs 7
+import Atom
hunk ./Grin/SSimplify.hs 29
-    envScope :: IM.IntMap Binding
+    envScope :: IM.IntMap Binding,
+    envCSE   :: Map.Map Exp (Atom,Exp)
hunk ./Grin/SSimplify.hs 47
-    mempty = SEnv { envScope = mempty, envSubst = mempty }
-    mappend sa sb = SEnv { envScope = envScope sa `IM.union` envScope sb, envSubst = envSubst sa `IM.union` envSubst sb }
+    mempty = SEnv {
+        envScope = mempty,
+        envSubst = mempty,
+        envCSE = mempty }
+    mappend sa sb = SEnv {
+        envScope = envScope sa `IM.union` envScope sb,
+        envSubst = envSubst sa `IM.union` envSubst sb,
+        envCSE = envCSE sa `Map.union` envCSE sb }
hunk ./Grin/SSimplify.hs 77
-simpBind :: ([Val],Exp) -> S (Maybe ([Val],Exp))
-simpBind (b,e) = f b e where
-    f b (Fetch (Const x)) = do
-        mtick "Grin.Simplify.fetch-const"
-        return $ Just (b,Return [x])
-    f b e = return $ Just (b,e)
+simpBind :: [Val] -> Exp -> S Exp -> S Exp
+simpBind p e cont = f p e where
+    cse name xs = do
+        z <- local (\s -> s { envCSE = Map.fromList [ (x,(toAtom name,y)) | (x,y) <- xs] `Map.union` envCSE s }) cont
+        cmap <- asks envCSE
+        case Map.lookup e cmap of
+            Nothing -> return $ e :>>= (p :-> z)
+            Just (n,e') -> do mtick n; return $ e' :>>= (p :-> z)
+    cse' name xs = cse name ((e,Return p):xs)
+    f p app@(App a [v] _) | a == funcEval =  cse' "Simplify.CSE.eval" [(Fetch v,Return p)]
+    f p (Fetch v@Var {}) =  cse' "Simplify.CSE.fetch" [(gEval v,Return p)]
+    f p (Return [v@NodeC {}]) =  cse' "Simplify.CSE.return-node" []
+    f [p] (Store v@Var {})  =  cse' "Simplify.CSE.demote" [(Fetch p,Return [v]),(gEval p,Return [v])]
+    f [p@Var {}] (Store v@(NodeC t _)) | tagIsWHNF t, not (isHoly v) = cse' "Simplify.CSE.store-whnf" [(Fetch p,Return [v]),(gEval p,Return [v])]
+    f [p@Var {}] (Store v@(NodeC t _)) | not (isHoly v) = cse' "Simplify.CSE.store" []
+    f _ _ = cse "Simplify.CSE.NOT" []
hunk ./Grin/SSimplify.hs 100
+
hunk ./Grin/SSimplify.hs 122
---    f (Store [v@Var {}]) ((senv,[Var vn _],b):rs) = do
---        v' <- applySubst v
---        local (\_ -> extScope vn (Demote v') senv) $ f b rs
---    f (Fetch [v@Var {}]) ((senv,[Var vn _],b):rs) = do
---        v' <- applySubst v
---        local (\_ -> extScope vn (Promote v') senv) $ f b rs
---    f (Store [v@(NodeC t _)]) ((senv,[Var vn _],b):rs) | tagIsWHNF t, not (isHoly v) = do
---        v' <- applySubst v
---        local (\_ -> extScope vn (Demote v') senv) $ f b rs
---    f (Return [v@(NodeC t _)]) ((senv,[Var vn _],b):rs) | tagIsWHNF t = fbind vn v senv b rs
hunk ./Grin/SSimplify.hs 143
-        x <- simpBind (p,a)
-        z <- local (const env'') $ f b xs
-        case x of
-            Just (p',a') -> do
-                return $ a' :>>= (p' :-> z)
-            Nothing -> do
-                return z
-    f x [] = g x
-
+        local (const env'') $ simpBind p a (f b xs)
+        --x <- simpBind (p,a)
+        --z <- local (const env'') $ f b xs
+--        case x of
+--            Just (p',a') -> do
+--                return $ a' :>>= (p' :-> z)
+--            Nothing -> do
+--                return z
+    f x [] = do
+        e <- g x
+        cmap <- asks envCSE
+        case Map.lookup e cmap of
+            Nothing -> return e
+            Just (n,e') -> do mtick n; return e'
hunk ./Grin/SSimplify.hs 166
-        ts <- mapM simpBind [([y],Return [x]) | x <- xs | y <- ys ]
+        ts <- mapM (return . Just) [([y],Return [x]) | x <- xs | y <- ys ]
hunk ./Grin/SSimplify.hs 256
-isHoly n = isHole n
+isHoly n = False