[add pushing inward optimization for Grin
John Meacham <john@repetae.net>**20060405052023] addfile ./Grin/Optimize.hs
hunk ./Grin/Optimize.hs 1
+
+module Grin.Optimize(grinPush) where
+
+import qualified Data.Set as Set
+import Control.Monad.State
+import List
+import Data.Monoid
+
+import Grin.Grin
+import Grin.Whiz
+import C.Prims
+import Support.FreeVars
+import Stats
+import Util.Graph
+
+
+data PExp = PExp {
+    pexpUniq :: Int,
+    pexpBind :: Val,
+    pexpExp  :: Exp,
+    pexpProvides :: [Var],
+    pexpDeps :: [Int]
+    } deriving(Show)
+
+instance Eq PExp where
+    a == b = pexpUniq a == pexpUniq b
+
+makeDeps :: [PExp] -> PExp -> PExp
+makeDeps cs pexp = pexp { pexpProvides = freeVars (pexpBind pexp), pexpDeps = deps } where
+    deps = [ pexpUniq c | c <- cs, not $ null $ fvs `intersect` pexpProvides c ]
+    fvs = freeVars (pexpExp pexp)
+
+justDeps :: [PExp] -> [Var] -> [Int]
+justDeps cs fs = deps where
+    deps = [ pexpUniq c | c <- cs, not $ null $ fs `intersect` pexpProvides c ]
+
+grinPush :: Stats -> Lam -> IO Lam
+grinPush stats lam = ans where
+    ans = do
+        (ans,_) <- evalStateT (whiz subBlock doexp finalExp whizState lam) (1,[])
+        return ans
+    subBlock _ action = do
+        (nn,x) <- get
+        put (nn,mempty)
+        r <- action
+        (nn,_) <- get
+        put (nn,x)
+        return r
+    doexp (v, exp) | isOmittable exp = do
+        (nn,cv) <- get
+        let npexp = makeDeps cv PExp { pexpUniq = nn, pexpBind = v, pexpExp = exp, pexpDeps = undefined, pexpProvides = undefined }
+        put (nn+1,npexp:cv)
+        return Nothing
+    doexp (v, exp) = do
+        exp' <- dropAny exp
+        return $ Just (v,exp')
+    finalExp (exp::Exp) = do
+        exp' <- dropAny exp
+        return (exp'::Exp)
+    dropAny (exp::Exp) = do
+        (nn,xs) <- get
+        let graph = newGraph xs pexpUniq pexpDeps
+            deps = justDeps xs (freeVars exp)
+            reached = reachable graph deps
+            dropped = case prefered reached exp of
+                Just (x:_) | [] <- [ r | r <- reached, pexpUniq x `elem` pexpDeps r ] -> (reverse $ topSort $ newGraph (filter (/= x) reached) pexpUniq pexpDeps) ++ [x]
+                _ -> reverse $ topSort $ newGraph reached pexpUniq pexpDeps
+            ff pexp exp = pexpExp pexp :>>= pexpBind pexp :-> exp
+        put (nn,[ x | x <- xs, pexpUniq x `notElem` (map pexpUniq reached) ])
+        --case  (prefered reached exp :: Maybe [PExp]) of
+        --    Just [x] -> lift $ Prelude.print  (x,[ r | r <- reached, pexpUniq x `elem` pexpDeps r ])
+        --    _ -> return ()
+        return (foldr ff exp dropped :: Exp)
+    prefer (Store v@Var {}) = return v
+    prefer (App fn [v@Var {}] _)  | fn == funcEval = return v
+    prefer (App fn [v@Var {},_] _)  | fn == funcApply = return v
+    prefer _ = fail "no preference"
+    prefered pexps exp = do
+        v <- prefer exp
+        return [ p | p <- pexps, v == pexpBind p]
+
+isOmittable (Fetch {}) = True
+isOmittable (Return {}) = True
+isOmittable (Store {}) = True
+isOmittable (Cast {}) = True
+isOmittable Prim { expPrimitive = Primitive { primAPrim = aprim } } = aprimIsCheap aprim
+isOmittable (Case x ds) = all isOmittable [ e | _ :-> e <- ds ]
+isOmittable (e1 :>>= _ :-> e2) = isOmittable e1 && isOmittable e2
+isOmittable _ = False
hunk ./Main.hs 48
+import Grin.Optimize
hunk ./Main.hs 622
-    --wdump FD.Grin $ printGrin x
hunk ./Main.hs 623
+    wdump FD.Grin $ printGrin x
hunk ./Main.hs 627
-        x <- Grin.Simplify.simplify stats' x
+        nf <- mapMsnd (grinPush stats') (grinFunctions x)
+        x <- return x { grinFunctions = nf }
hunk ./Main.hs 630
-        x <- deadCode stats' [funcMain] x  -- XXX
-        wdump FD.Tags $ do
-            dumpTyEnv (grinTypeEnv x)
+        x <- Grin.Simplify.simplify stats' x
hunk ./Main.hs 638
+    x <- deadCode stats (grinEntryPoints x) x  -- XXX
+    lintCheckGrin x
hunk ./Main.hs 641
-    wdump FD.OptimizationStats $ Stats.print "Optimization" stats
+    lintCheckGrin x
+    x <- deadCode stats (grinEntryPoints x) x  -- XXX
+    lintCheckGrin x
+    x <- opt "Optimization" x
+    lintCheckGrin x
hunk ./Main.hs 648
+    wdump FD.OptimizationStats $ Stats.print "Optimization" stats
+