[new grin simplifier and inliner
John Meacham <john@repetae.net>**20051024140927] hunk ./Grin/DeadFunctions.hs 91
-    let (graph,lv,kv) = graphFromEdges [ (gf, functionName gf, functionCalls gf) |  gf <- map (getFunctionInfo (grinCafs grin) indirect ) $ grinFunctions grin ]
-        reach = [ x|  (x,_,_) <- map lv $ snub $ concatMap (reachable graph) (map la keeps)]
-        rs = Set.fromList (map functionName reach)
+    let -- (graph,lv,kv) = graphFromEdges [ (gf, functionName gf, functionCalls gf) |  gf <- map (getFunctionInfo (grinCafs grin) indirect ) $ grinFunctions grin ]
+        -- reach = [ x|  (x,_,_) <- map lv $ snub $ concatMap (reachable graph) (map la keeps)]
+        -- rs = Set.fromList (map functionName reach)
hunk ./Grin/DeadFunctions.hs 96
-        la a = case kv a  of
-            Just n -> n
-            Nothing -> error $ "DeadFunctions, CannotFind: " ++ show a
-        fs =  [ f | f@(a,_) <- grinFunctions grin, a `Set.member` rs ]
-        cu = Set.fromList $ concatMap functionCafsUsed reach
-        (nc,uuc) = List.partition ((`Set.member` cu) . fst)  (grinCafs grin)
-    ticks stats (length (grinFunctions grin) - length reach) (toAtom "Optimize.dead.function")
-    ticks stats (length uuc) (toAtom "Optimize.dead.caf")
-    reach <- findDeadCode stats  reach
+        -- la a = case kv a  of
+        --    Just n -> n
+        --    Nothing -> error $ "DeadFunctions, CannotFind: " ++ show a
+        fs = map (getFunctionInfo (grinCafs grin) indirect ) $ grinFunctions grin
+        -- fs =  [ f | f@(a,_) <- grinFunctions grin, a `Set.member` rs ]
+        --cu = Set.fromList $ concatMap functionCafsUsed fs
+        --(nc,uuc) = List.partition ((`Set.member` cu) . fst)  (grinCafs grin)
+    -- ticks stats (length (grinFunctions grin) - length reach) (toAtom "Optimize.dead.function")
+    --ticks stats (length uuc) (toAtom "Optimize.dead.caf")
+    fs <- findDeadCode stats  fs
hunk ./Grin/DeadFunctions.hs 107
-    fs <- mapM (removeDeadArgs stats reach) fs
-    return $ grin { grinFunctions = fs, grinCafs = nc }
+    fs <- mapM (removeDeadArgs stats fs) [ (functionName f, functionBody f) |  f <- fs]
+    return $ grin { grinFunctions = fs }
hunk ./Grin/Simplify.hs 3
-import Control.Monad.Identity
hunk ./Grin/Simplify.hs 11
+import CharIO
+import GenUtil hiding(putErrLn)
hunk ./Grin/Simplify.hs 14
+import Doc.Pretty
+import Doc.PPrint
hunk ./Grin/Simplify.hs 18
+import Grin.Show
hunk ./Grin/Simplify.hs 20
-import Util.Inst()
hunk ./Grin/Simplify.hs 21
+import Util.Graph
+import Util.Inst()
+import Util.Seq as Seq
+import Util.Histogram as Hist
hunk ./Grin/Simplify.hs 40
+-- contains functions that should be inlined
+type SimpEnv = Map.Map Atom (Atom,Lam)
hunk ./Grin/Simplify.hs 43
-simplify :: Stats -> Grin -> IO Grin
-simplify stats grin = do
-    gfn <- sequence [  do (x,_) <- (evalStateT (whiz fn gv f whizState l) mempty ); return (n,x) |  (n,l) <- grinFunctions grin]
-    deadVars stats  grin { grinFunctions = gfn }
+simplify1 :: Stats -> SimpEnv -> (Atom,Lam) -> IO (Atom,Lam)
+simplify1 stats env (n,l) = do
+    (l,_) <- evalStateT (whiz fn gv f whizState l) mempty
+    return (n,l)
hunk ./Grin/Simplify.hs 81
-            Return v | Just n <- varBind grin p v -> do
+            Return v | Just n <- varBind p v -> do
hunk ./Grin/Simplify.hs 90
-    funcMap = Map.fromList $ [  fn | fn <- grinFunctions grin, doInline fn]
+    -- funcMap = Map.fromList $ [  fn | fn <- grinFunctions grin, doInline fn]
hunk ./Grin/Simplify.hs 98
-        | Just l <- Map.lookup fn funcMap = do
-            lift $ tick stats at_OptSimplifyInline -- (toAtom $ fromAtom at_OptSimplifyInline ++ "." ++ fromAtom fn)
+        | Just (itype,l) <- Map.lookup fn env = do
+            lift $ tick stats itype
hunk ./Grin/Simplify.hs 127
-varBind :: Monad m => Grin -> Val -> Val -> m (Map Var Val)
-varBind _ (Var v t) nv@(Var v' t') | t == t' = return $ Map.singleton v nv
-varBind _ (Lit i t) (Lit i' t') | i == i' && t == t' = return mempty
---varBind _ Unit Unit = return mempty
-varBind grin (Tup xs) (Tup ys) | length xs == length ys  = liftM mconcat $ sequence $  zipWith (varBind grin) xs ys
-varBind _ (Tag i) (Tag i') | i == i' = return mempty
---varBind (NodeV v vs) (NodeV t vs') = do
---    be <- sequence $  zipWith varBind vs vs'
---    b <- varBind v t
---    return (mconcat $ b:be)
-varBind grin (NodeC t vs) (NodeC t' vs') | t == t' = do
-    liftM mconcat $ sequence $  zipWith (varBind grin) vs vs'
-varBind grin v r  | runIdentity (typecheck (grinTypeEnv grin) v) == runIdentity (typecheck (grinTypeEnv grin) r)  = fail "unvarBindable"    -- check type to be sure
-varBind _ x y = error $ "varBind: " ++ show (x,y)
+varBind :: Monad m => Val -> Val -> m (Map Var Val)
+varBind (Var v t) nv@(Var v' t') | t == t' = 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 "unvarBindable"    -- check type to be sure
+varBind x y = error $ "varBind: " ++ show (x,y)
hunk ./Grin/Simplify.hs 138
-isSimple (fn,x) = f (3::Int) x where
+isSimple (fn,x) = f (2::Int) x where
hunk ./Grin/Simplify.hs 142
-    f _ (_ :-> App { expFunction = fn' }) | fn == fn' = False
hunk ./Grin/Simplify.hs 169
-deadVars :: Stats -> Grin -> IO Grin
-deadVars stats grin = do
-    gfn <- sequence [  do (x,_) <- (evalStateT (fizz (grinTypeEnv grin) fn gv f whizState l) (mempty :: Set.Set Var) ); return (n,x) |  (n,l) <- grinFunctions grin]
-    return $ grin { grinFunctions =  gfn }
+deadVars :: Stats -> (Atom,Lam) -> IO (Atom,Lam)
+deadVars stats (n,l) = do
+    (x,_) <- (evalStateT (fizz fn gv f whizState l) (mempty :: Set.Set Var) );
+    return (n,x)
hunk ./Grin/Simplify.hs 197
+
+
+simplify ::
+    Stats     -- ^ stats to update
+    -> Grin   -- ^ input grin
+    -> IO Grin
+simplify stats grin = do
+    let postEval = phaseEvalInlined (grinPhase grin)
+        fs = grinFunctions grin
+        uf = [ ((a,l),collectUsedFuncs l) | (a,l) <- fs ]
+        graph = newGraph uf (\ ((a,_),_) -> a) (\ (_,(fi,fd)) -> (if postEval then [] else fi) ++ fd)
+        rf = reachable graph (grinEntryPoints grin)
+        reached = Set.fromList $ Prelude.map  (\ ((a,_),_) -> a) rf
+        graph' = if postEval then graph else newGraph rf (\ ((a,_),_) -> a) (\ (_,(_,fd)) -> fd)
+        (lb,os) = findLoopBreakers ( fromEnum . not . isSimple . fst) (const True) graph'
+        loopBreakers = Set.fromList [ a | ((a,_),_) <- lb ]
+        indirectFuncs = if postEval then Set.empty else Set.fromList (concat [ fi | (_,(fi,_)) <- rf ])
+        hist =  Hist.fromList $ concat [ fd | (_,(_,fd)) <- rf ]
+    let opt env a n l = do
+                (_,nl) <- deadVars stats (a,l)
+                (_,nl) <- simplify1 stats env (a,nl)
+                return nl
+                {-
+        opt env a n l = do
+            stats' <- Stats.new
+            (_,nl) <- deadVars stats (a,l)  -- if the deadVars did not enable any other transformations we don't need to iterate as deadVars is idempotent
+            (_,nl) <- simplify1 stats' env (a,nl)
+            t <- Stats.getTicks stats'
+            case t of
+                0 -> return nl
+                _ -> do
+                    -- when (n > 2) $ Stats.print (show a) stats'
+                    Stats.combine stats stats'
+                    -- tick stats $ "Optimize.repeat.{" ++ show a ++ "}"
+                    opt env a (n + 1 :: Int) nl
+                    -}
+        procF (out,env) ((a,_),_) | False <- a `Set.member` reached = do
+            tick stats (toAtom "Optimize.dead.function")
+            return (out,env)
+        procF (out,env) ((a,l),_) = do
+            nl <- opt env a 0 l
+            let iname t = toAtom $ "Optimize.simplify.inline." ++ t ++ ".{" ++ fromAtom a  ++ "}"
+                inline
+                    | a `Set.member` loopBreakers = Map.empty
+                    | Hist.find a hist == 1 = Map.singleton a (iname "once",nl)
+                    | a `Set.member` indirectFuncs = Map.empty
+                    | isSimple (a,nl) = Map.singleton a (iname "simple",nl)
+                    | otherwise = Map.empty
+            return ((a,nl):out , inline `Map.union` env)
+
+    (nf,_) <- foldM procF ([],mempty) os
+    return grin { grinFunctions = nf }
+
+
+
+-- TODO have this collect CAF info ignoring updates.
+
+collectUsedFuncs :: Lam -> ([Atom],[Atom])
+collectUsedFuncs (Tup as :-> exp) = (snub $ concatMap tagToFunction (Seq.toList iu),sort $ Seq.toList du) where
+    (iu,du) =  f exp
+    f (e1 :>>= _ :-> e2) = f e1 `mappend` f e2
+    f (App a vs _) =  (Seq.fromList (freeVars vs), Seq.singleton a)
+    f (Case e alts) =  mconcat ((Seq.fromList (freeVars e) , Seq.empty):[ f e | _ :-> e <- alts])
+    f e = (Seq.fromList [ v | v <- freeVars e ],Seq.empty)
+
+
hunk ./Grin/Whiz.hs 28
-        (Identity (lm',set')) = fizz (grinTypeEnv grin) (\_ x -> x) (return . Just) return set lm
+        (Identity (lm',set')) = fizz  (\_ x -> x) (return . Just) return set lm
hunk ./Grin/Whiz.hs 108
-    TyEnv ->
hunk ./Grin/Whiz.hs 114
-fizz tyEnv sub te tf inState start = res where
+fizz sub te tf inState start = res where
hunk ./Main.hs 425
+    stats <- Stats.new