[add partial application optimization in Grin.SSimplify
John Meacham <john@repetae.net>**20070605004344] hunk ./Grin/NodeAnalyze.hs 290
-                putStrLn $ "NA-EVAL-WHNF-" ++ show fn
+                --putStrLn $ "NA-EVAL-WHNF-" ++ show fn
hunk ./Grin/SSimplify.hs 6
+import qualified Data.Set as Set
hunk ./Grin/SSimplify.hs 31
-    envCSE   :: Map.Map Exp (Atom,Exp)
+    envCSE   :: Map.Map Exp (Atom,Exp),
+    envPapp  :: IM.IntMap (Atom,[Val])
hunk ./Grin/SSimplify.hs 34
+    {-! derive: Monoid !-}
hunk ./Grin/SSimplify.hs 38
+data SCol = SCol {
+    colStats :: Stats.Stat,
+    colFreeVars :: Set.Set Var
+    }
+    {-! derive: Monoid !-}
+
hunk ./Grin/SSimplify.hs 55
-instance Monoid SEnv where
-    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 76
+simpDone :: Exp -> S Exp
+simpDone e = do
+    pmap <- asks envPapp
+    case e of
+        (App fap (Var (V vn) _:fs) ty) | fap == funcApply, Just (tl,gs) <- IM.lookup vn pmap -> do
+            (cl,fn) <- tagUnfunction tl
+            let ne = if cl == 1 then App fn (gs ++ fs) ty else Return [NodeC (partialTag fn (cl - 1)) (gs ++ fs)]
+            mtick $ if cl == 1 then "Simplify.Apply.Papp.{" ++ show tl  else ("Simplify.Apply.App.{" ++ show fn)
+            return ne
+        _ -> do
+            cmap <- asks envCSE
+            case Map.lookup e cmap of
+                Just (n,e') -> do mtick n; return e'
+                Nothing -> return e
hunk ./Grin/SSimplify.hs 95
-        cmap <- asks envCSE
-        case Map.lookup e cmap of
-            Nothing -> return $ e :>>= (p :-> z)
-            Just (n,e') -> do mtick n; return $ e' :>>= (p :-> z)
+        e <- simpDone e
+        return $ e :>>= (p :-> z)
hunk ./Grin/SSimplify.hs 100
-    f p (Return [v@NodeC {}]) =  cse' "Simplify.CSE.return-node" []
+    f [p@(Var (V vn) _)] (Return [v@(NodeC t vs)]) | not (isHoly v) = case tagUnfunction t of
+        Nothing -> cse' "Simplify.CSE.return-node" []
+        Just (n,fn) -> local (\s -> s { envPapp = IM.insert vn (t,vs) (envPapp s) }) $ cse' "Simplify.CSE.return-node" []
hunk ./Grin/SSimplify.hs 104
-    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 [p@(Var (V vn) _)] (Store v@(NodeC t vs)) | not (isHoly v) = case tagIsWHNF t of
+        True -> cse' "Simplify.CSE.store-whnf" [(Fetch p,Return [v]),(gEval p,Return [v])]
+        False -> cse' "Simplify.CSE.store" []
hunk ./Grin/SSimplify.hs 168
-        cmap <- asks envCSE
-        case Map.lookup e cmap of
-            Nothing -> return e
-            Just (n,e') -> do mtick n; return e'
+        simpDone e