[modify grinPush to not flip around values on case, rearrange grin optimizations fix Grin.Lint
John Meacham <john@repetae.net>**20070517043953] hunk ./Grin/Lint.hs 31
-    let errs = [  (err ++ "\n" ++ render (prettyFun a) ) | (a,Left err) <-  [ (a,typecheck (grinTypeEnv grin) c:: Either String Ty)   | a@(_,(_ :-> c)) <-  grinFuncs grin ]]
+    let env = TcEnv { envTyEnv = grinTypeEnv grin, envInScope = fromList (fsts $ grinCafs grin) }
+    let errs = [  (err ++ "\n" ++ render (prettyFun a) ) | (a,Left err) <-  [ (a,runTc env (tcLam Nothing c))  | a@(_,c) <-  grinFuncs grin ]]
hunk ./Grin/Lint.hs 89
-            dumpGrin ("lint-after-" ++ name) prog
+            dumpGrin ("lint-after-" ++ name) grin'
hunk ./Grin/Optimize.hs 16
+import Support.Tuple
hunk ./Grin/Optimize.hs 48
-grinPush stats lam = ans where
+grinPush stats (l :-> e) = ans where
hunk ./Grin/Optimize.hs 50
-        (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
+--        putStrLn "@@@ grinPush"
+        e' <- evalStateT (f e) (1,[])
+        return (l :-> e')
+    f (exp :>>= v :-> e2) | isOmittable exp = do
hunk ./Grin/Optimize.hs 57
-        return Nothing
-    doexp (v, exp) = do
+        f e2
+    f (exp :>>= v :-> e2) = do
hunk ./Grin/Optimize.hs 60
-        exp' <- dropAny exp
-        return $ Just (v,exp')
-    finalExp (exp::Exp) = do
+        (v',exp') <- dropAny (Just v) exp
+        e2' <- f e2
+        return $ exp' :>>= v' :-> e2'
+    f exp = do
hunk ./Grin/Optimize.hs 65
-        exp' <- dropAny exp
-        return (exp'::Exp)
+        (_,exp') <- dropAny Nothing exp
+        return exp'
+
hunk ./Grin/Optimize.hs 76
-    dropAny (exp::Exp) = do
+    dropAny mv (exp::Exp) = do
hunk ./Grin/Optimize.hs 81
-            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) ])
-        return (foldr ff exp dropped :: Exp)
-    dropAll exp fvs = do
-        (nn,xs) <- get
-        let graph = newGraph xs pexpUniq pexpDeps
-            deps = justDeps xs fvs
-            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
hunk ./Grin/Optimize.hs 86
+            ebinds = [ Var v t | (v,t) <- Set.toList $ freeVars (map pexpBind dropped) ]
+            (exp',mv') | Just vv <- mv = let mv' = tuple $ fromTuple vv ++ ebinds in (exp :>>= vv :-> Return mv',mv')
+                       | otherwise = (exp,unit)
hunk ./Grin/Optimize.hs 90
-        return (foldr ff exp dropped :: Exp)
+--        when (not $ null dropped) $ lift $ do
+--            putStrLn "@@@ dropped"
+--            mapM_ Prelude.print dropped
+        return (mv',foldr ff exp' dropped :: Exp)
hunk ./Grin/Optimize.hs 106
+--grinPush :: Stats -> Lam -> IO Lam
+--grinPush stats lam = ans where
+--    ans = do
+--        putStrLn "@@@ grinPush"
+--        (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 <- fixupLet exp
+--        (v',exp') <- dropAny (Just v) exp
+--        return $ Just (v',exp')
+--    finalExp (exp::Exp) = do
+--        exp <- fixupLet exp
+--        (_,exp') <- dropAny Nothing exp
+--        return (exp'::Exp)
+--    fixupLet lt@Let { expDefs = defs, expBody = b } = do
+--        let def = (Set.fromList $ map funcDefName defs)
+--            f (e :>>= l :-> r) | Set.null (freeVars e `Set.intersection` def) = do
+--                exp <- f r
+--                return (e :>>= l :-> exp)
+--            f r = return $ updateLetProps lt {  expBody = r }
+--        f b
+--    fixupLet exp = return exp
+--    dropAny mv (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
+--            dropped =  reverse $ topSort $ newGraph reached pexpUniq pexpDeps
+--            ff pexp exp = pexpExp pexp :>>= pexpBind pexp :-> exp
+--            ebinds = [ Var v t | (v,t) <- Set.toList $ freeVars (map pexpBind dropped) ]
+--            (exp',mv') | Just vv <- mv = let mv' = tuple $ fromTuple vv ++ ebinds in (exp :>>= vv :-> Return mv',mv')
+--                       | otherwise = (exp,unit)
+--        put (nn,[ x | x <- xs, pexpUniq x `notElem` (map pexpUniq reached) ])
+--        when (not $ null dropped) $ lift $ do
+--            putStrLn "@@@ dropped"
+--            mapM_ Prelude.print dropped
+--        return (mv',foldr ff exp' dropped :: Exp)
+--    -- | preferentially pull definitons of the variable this returns right next to it as it admits a peephole optimization
+--    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 (App fn [v@Var {}] _)  | fn == funcApply = return v
+--    prefer (Update _ v@Var {}) = return v
+--    prefer (Update v@Var {} _) = return v
+--    prefer _ = fail "no preference"
+--    prefered pexps exp = do
+--        v <- prefer exp
+--        return [ p | p <- pexps, v == pexpBind p]
+
hunk ./Main.hs 533
-    putStrLn "Type analyzed methods"
-    flip mapM_ (programDs prog) $ \ (t,e) -> do
-        let (_,ts) = fromLam e
-            ts' = takeWhile (sortKindLike . getType) ts
-        when (not (null ts')) $ putStrLn $ (pprint t) ++ " \\" ++ concat [ "(" ++ show  (Info.fetch (tvrInfo t) :: Typ) ++ ")" | t <- ts' ]
+--    putStrLn "Type analyzed methods"
+--    flip mapM_ (programDs prog) $ \ (t,e) -> do
+--        let (_,ts) = fromLam e
+--            ts' = takeWhile (sortKindLike . getType) ts
+--        when (not (null ts')) $ putStrLn $ (pprint t) ++ " \\" ++ concat [ "(" ++ show  (Info.fetch (tvrInfo t) :: Typ) ++ ")" | t <- ts' ]
hunk ./Main.hs 695
-    let opt s  x = do
-        stats' <- Stats.new
-        nf <- mapMsnd (grinPush stats') (grinFuncs x)
-        x <- return $ setGrinFunctions nf x
-        wdump FD.GrinPass $ printGrin x
-        x <- Grin.Simplify.simplify stats' x
-        t' <- Stats.getTicks stats'
-        wdump FD.Progress $ Stats.print s stats'
-        Stats.combine stats stats'
-        lintCheckGrin x
-        case t' of
-            0 -> return x
-            _ -> opt s x
+    let opt' s  x = do
+            stats' <- Stats.new
+            nf <- mapMsnd (grinPush stats') (grinFuncs x)
+            x <- return $ setGrinFunctions nf x
+            wdump FD.GrinPass $ printGrin x
+            x <- Grin.Simplify.simplify stats' x
+            t' <- Stats.getTicks stats'
+            wdump FD.Progress $ Stats.print s stats'
+            Stats.combine stats stats'
+            lintCheckGrin x
+            case t' of
+                0 -> return x
+                _ -> opt s x
+        pushGrin grin = do
+            grin <- return $ normalizeGrin grin
+            nf   <- mapMsnd (grinPush undefined) (grinFuncs grin)
+            return $ setGrinFunctions nf grin
+
+        opt s grin = do
+            stats' <- Stats.new
+            let fop grin = do Grin.Simplify.simplify stats' grin
+                tparms = transformParms {
+                    transformDumpProgress = True,
+                    transformCategory = s,
+                    transformPass = "Grin",
+                    transformOperation = fop
+                    }
+            grin <- transformGrin tparms grin
+            t' <- Stats.getTicks stats'
+            wdump FD.Progress $ Stats.print s stats'
+            Stats.combine stats stats'
+            case t' of
+                0 -> return grin
+                _ -> opt s grin
hunk ./Main.hs 731
+    x <- pushGrin x