[code cleanups, fix finding free variables of rules to use binding info, move stuff into E.Inline from other places
John Meacham <john@repetae.net>**20060211023743] hunk ./E/Inline.hs 1
-module E.Inline(inlineDecompose, basicDecompose, emapE, emapE',emapEG, app, emapE_, bindingFreeVars) where
+module E.Inline(
+    basicDecompose,
+    emapE,
+    emapE',
+    emapEG,
+    app,
+    emapE_,
+    programMapRecGroups,
+    forceInline,
+    forceSuperInline,
+    forceNoinline,
+    baseInlinability,
+    decomposeDs
+    ) where
hunk ./E/Inline.hs 19
+import qualified Data.Set as Set
hunk ./E/Inline.hs 23
+import E.Program
hunk ./E/Inline.hs 27
-import Support.FreeVars
hunk ./E/Inline.hs 29
+import Info.Types
+import Options
+import qualified Data.Graph as G
+import qualified FlagOpts as FO
hunk ./E/Inline.hs 34
+import Support.FreeVars
hunk ./E/Inline.hs 40
--- To decide whether to inline, we take a few things into account
-
-bindingFreeVars t e = freeVars (tvrType t) `mappend` freeVars e `mappend` freeVars (Info.fetch (tvrInfo t) :: ARules)
hunk ./E/Inline.hs 42
-baseInlinability e
-    | isAtomic e = 5
+-- | higher numbers mean we want to inline it more
+baseInlinability t e
+    | forceNoinline t = -15
+    | forceSuperInline t = 10
+    | forceInline t = 7
+    | isAtomic e = 6
hunk ./E/Inline.hs 72
-inlineDecompose ::
-    Maybe [Int]  -- ^ Just a set of values not to prune or nothing to not prune at all.
-    -> E             -- ^ body for pruning info
-    -> [(TVr,E)]     -- ^ incoming bindings
-    -> [(TVr,E)]     -- ^ bindings pruned and ordered by inlinability value
-inlineDecompose prune body ds = ans where
-    zs = [ ((t,e), tvrNum t, freeVars e, inlinability e) |  (t,e) <- ds ]
-    cg zs =  newGraph zs (\ (_,x,_,_) -> x) ( \ (_,_,x,_) -> x)
-    tg = cg zs
-    scc' = scc tg
-    scc'' = case prune of
-        Nothing -> scc'
-        Just s -> scc $ cg $ reachable tg (freeVars body ++ s )
-    inlinability e = baseInlinability e - size (fst $ fromLam e)
-    ans = f scc'' []
-    f (Left (v,_,_,_):ds) xs = f ds (v:xs)
-    f (Right ms:ds) xs = f (scc' ++ ds) xs where
-        scc' = scc (cg [ (a,b,filter (/= i) c,d) | (a,b,c,d) <- ms])
-        (_,i,_,_) = minimumUnder (\ (_,_,_,x) -> x) ms
-    f [] xs = reverse xs
+
+-- NOINLINE must take precidence because it is sometimes needed for correctness, while INLINE is surely an optimization.
+forceInline x
+    | forceNoinline x = False
+    | not (fopts FO.InlinePragmas) = False
+    | Properties p <- Info.fetch (tvrInfo x) = Set.member prop_INLINE p  || Set.member prop_WRAPPER p || Set.member prop_SUPERINLINE p
+
+forceSuperInline x
+    | forceNoinline x = False
+    | not (fopts FO.InlinePragmas) = False
+    | Properties p <- Info.fetch (tvrInfo x) =  Set.member prop_SUPERINLINE p
+
+forceNoinline x
+    | Just (_x :: ARules) <- Info.lookup (tvrInfo x) = True
+    | Properties p <- Info.fetch (tvrInfo x) = Set.member prop_NOINLINE p || Set.member prop_PLACEHOLDER p
hunk ./E/Inline.hs 115
+programMapRecGroups :: Monad m =>
+    ((Bool,[(TVr,E)]) -> m [(TVr,E)])  -- ^ bool is true if group is recursive.
+    -> Program
+    -> m Program
+programMapRecGroups f prog = do
+    let g (Left d) = f (False,[d])
+        g (Right ds) = f (True,ds)
+    nds <- mapM g $ decomposeDs (programDs prog)
+    return $ programSetDs (concat nds) prog
hunk ./E/Inline.hs 125
-{-
-inlineDecompose prune body ds = ans where
-    zs = [ ((t,e), tvrNum t, freeVars e, inlinability e) |  (t,e) <- ds ]
-    --tg = newGraph zs (\ (_,x,_,_) -> x) ( \ (_,_,x,_) -> x)
-    scc = stronglyConnComp [ (x,a,b) | x@(_,a,b,_) <- zs ]
-    inlinability e = baseInlinability e - size (fst $ fromLam e)
-    ans = f scc []
-    f (AcyclicSCC (v,_,_,_):ds) xs = f ds (v:xs)
-    f (CyclicSCC ms:ds) xs = f (scc' ++ ds) xs where
-        scc' = stronglyConnComp [ (x,a,filter (/= i) b) | x@(_,a,b,_) <- ms ]
-        (_,i,_,_) = minimumUnder (\ (_,_,_,x) -> x) ms
-    f [] xs = reverse xs
-
-emapE f (EAp aa ab) = do aa <- f aa;ab <- f ab; return $ EAp aa ab
-emapE f (ELam aa ab) = do aa <- mapmTvr f aa; ab <- f ab; return $ ELam aa ab
-emapE f (EPi aa ab) = do aa <- mapmTvr f aa; ab <- f ab; return $ EPi aa ab
---emapE f (EVar aa) = do aa <- mapmTvr f aa; return $ EVar aa
-emapE f (EVar aa) = do return $ EVar aa
-emapE f (Unknown) = do return $ Unknown
-emapE f (ESort aa) = do return $ ESort aa
-emapE f (ELit aa) = do aa <- litSMapM f aa; return $ ELit aa
-emapE f (ELetRec aa ab) = do aa <- mapM (\x -> do x <- (do (aa,ab) <- return x; aa <- mapmTvr f aa;ab <- f ab;return (aa,ab)); return x) aa;ab <- f ab; return $ ELetRec aa ab
-emapE f (ECase e b as d) = do
-    e' <- f e
-    b' <- fmapM f b
-    as' <- mapmAlt as
-    d' <- fmapM f d
-    return (ECase e' b' as' d')
---    aa ab) = do aa <- f aa;ab <- mapM (\(x,y) -> do x <- fmapM f x; y <- f y; return (x,y)) ab; return $ ECase aa ab
-emapE f (EPrim aa ab ac) = do ab <- mapM f ab;ac <- f ac; return $ EPrim aa ab ac
-emapE f (EError aa ab) = do ab <- f ab; return $ EError aa ab
-
-
--- do not traverse into types
-emapE' f (EAp aa ab) = do aa <- f aa;ab <- f ab; return $ EAp aa ab
-emapE' f (ELam aa ab) = do ab <- f ab; return $ ELam aa ab
-emapE' f (EPi aa ab) = do aa <- mapmTvr f aa; ab <- f ab; return $ EPi aa ab
---emapE' f (EPi aa ab) = do  ab <- f ab; return $ EPi aa ab
-emapE' f (EVar aa) = do return $ EVar aa
-emapE' f (Unknown) = do return $ Unknown
-emapE' f (ESort aa) = do return $ ESort aa
-emapE' f (ELit (LitCons a es e)) = do es <- mapM f es;  return $ ELit (LitCons a es e)
-emapE' f (ELit aa) = do aa <- fmapM f aa; return $ ELit aa
-emapE' f (ELetRec aa ab) = do aa <- mapM (\x -> do x <- (do (aa,ab) <- return x; ab <- f ab;return (aa,ab)); return x) aa;ab <- f ab; return $ ELetRec aa ab
-emapE' f (ECase e b as d) = do
-    e' <- f e
-    as' <- mapmAlt' as
-    d' <- fmapM f d
-    return (ECase e' b as' d')
---emapE' f (ECase aa ab) = do aa <- f aa;ab <- mapM (\(x,y) -> do x <- patFmap' f x; y <- f y; return (x,y)) ab; return $ ECase aa ab
-emapE' f (EPrim aa ab ac) = do ab <- mapM f ab; return $ EPrim aa ab ac
-emapE' f (EError aa ab) =  return $ EError aa ab
-
-mapmTvr f (TVr x e) = f e >>= return . TVr x
-mapmAlt f (Alt l e) = do
-    e' <- f e
-    l' <- litSMapM f l
-    return (Alt l' e')
-mapmAlt' f (Alt l e) = do
-    e' <- f e
-    return (Alt l e')
-
-
---patFmap' f PatWildCard = return PatWildCard
---patFmap' f (PatLit l) = litFmap' f l >>= return . PatLit
-litFmap' f (LitCons a es e) = do es <- mapM f es; return $ (LitCons a es e)
-litFmap' _ l = return l
+decomposeDs :: [(TVr, E)] -> [Either (TVr, E) [(TVr,E)]]
+decomposeDs bs = map f mp where
+    mp = G.stronglyConnComp [ (v,i,bindingFreeVars t e) | v@(t@TVr { tvrIdent = i },e) <- bs]
+    f (G.AcyclicSCC v) = Left v
+    f (G.CyclicSCC vs) = Right vs
hunk ./E/Inline.hs 131
--}
hunk ./E/Program.hs 71
+
+programMapDs_ f prog = mapM_ f (programDs prog)
+
+{-
+programMapRecGroups :: Monad m => ([(TVr,E)] -> m [(TVr,E)]) -> Program -> m Program
+programMapRecGroups f prog = do
+    let pds = programDs prog
+-}
hunk ./E/Rules.hs 2
-    Rules,
+    ARules,
hunk ./E/Rules.hs 4
-    ruleFreeVars,
-    ruleAllFreeVars,
-    ruleFreeVars',
-    fromRules,
+    Rules,
+    applyRules,
+    arules,
+    bindingFreeVars,
+    builtinRule,
hunk ./E/Rules.hs 10
-    printRule,
-    printRules,
-    mapBodies,
-    mapABodies,
-    hasBuiltinRule,
+    fromRules,
hunk ./E/Rules.hs 12
-    arules,
+    hasBuiltinRule,
hunk ./E/Rules.hs 14
-    ARules,
-    applyRules,
-    builtinRule
+    mapABodies,
+    mapBodies,
+    printRule,
+    printRules,
+    ruleAllFreeVars,
+    ruleFreeVars',
+    ruleFreeVars
hunk ./E/Rules.hs 46
+import qualified Info.Info as Info
hunk ./E/Rules.hs 117
-    freeVars rule = freeVars (ruleBody rule) Set.\\ freeVars (ruleArgs rule)
+    freeVars rule = freeVars (ruleBody rule) Set.\\ Set.fromList (ruleBinds rule)
hunk ./E/Rules.hs 120
-    freeVars rule = freeVars (ruleBody rule) Set.\\ freeVars (ruleArgs rule)
+    freeVars rule = freeVars (ruleBody rule) Set.\\ Set.fromList (map tvrIdent $ ruleBinds rule)
hunk ./E/Rules.hs 216
+-- | this determines all free variables of a definition taking rules into account
+bindingFreeVars t e = freeVars (tvrType t) `mappend` freeVars e `mappend` freeVars (Info.fetch (tvrInfo t) :: ARules)
+
hunk ./E/SSimplify.hs 96
-            (lb,ds'') = findLoopBreakers (\ (_,(e,_,_)) -> loopFunc e) (const True) gr'
+            (lb,ds'') = findLoopBreakers (\ (t,(e,_,_)) -> loopFunc e) (const True) gr'
hunk ./E/SSimplify.hs 450
-    -- NOINLINE must take precidence because it is sometimes needed for correctness, while INLINE is surely an optimization.
-    forceInline x
-        | forceNoinline x = False
-        | not (fopts FO.InlinePragmas) = False
-        | Properties p <- Info.fetch (tvrInfo x) = Set.member prop_INLINE p  || Set.member prop_WRAPPER p || Set.member prop_SUPERINLINE p
-
-    forceSuperInline x
-        | forceNoinline x = False
-        | not (fopts FO.InlinePragmas) = False
-        | Properties p <- Info.fetch (tvrInfo x) =  Set.member prop_SUPERINLINE p
-
-    forceNoinline x
-        | Just (_x :: ARules) <- Info.lookup (tvrInfo x) = True
-        | Properties p <- Info.fetch (tvrInfo x) = Set.member prop_NOINLINE p || Set.member prop_PLACEHOLDER p
hunk ./Main.hs 195
-    let allRules = hoRules ho `mappend` rules `mappend` hoRules ho'
+    let allRules = hoRules allHo `mappend` rules
+
+    let prog = program { progClassHierarchy = hoClassHierarchy allHo, progDataTable = fullDataTable }
hunk ./Main.hs 216
+    prog <- return $ programSetDs [ (t,e) | (_,t,e) <- ds] prog
+    let entries = execWriter $ programMapDs_ (\ (t,_) -> when (getProperty prop_EXPORTED t) (tell [t])) prog
+    prog <- return $ prog { progEntryPoints = entries }
+
hunk ./Main.hs 300
-    let ds' = reachable (newGraph ds (\ (_,b,_) -> tvrIdent b) (\ (_,b,c) -> bindingFreeVars b c)) [ tvrIdent b | (n,b,_) <- ds, getProperty prop_EXPORTED b]
+    prog <- return $ programSetDs [ (t,e) | (_,t,e) <- ds] prog
+    prog <- return $ programPruneUnreachable prog
+    printProgram prog
+
+
+    --let ds' = reachable (newGraph ds (\ (_,b,_) -> tvrIdent b) (\ (_,b,c) -> bindingFreeVars b c)) [ tvrIdent b | (n,b,_) <- ds, getProperty prop_EXPORTED b]
hunk ./Main.hs 308
-    return ho' { hoDataTable = dataTable, hoEs = Map.fromList [ (x,(y,z)) | (x,y,z) <- ds'], hoRules = hoRules ho' `mappend` rules, hoUsedIds = collectIds (ELetRec [ (b,c) | (_,b,c) <- ds'] Unknown) }
+    return ho' { hoDataTable = dataTable, hoEs = programEsMap prog , hoRules = hoRules ho' `mappend` rules, hoUsedIds = collectIds (ELetRec [ (b,c) | (_,b,c) <- ds'] Unknown) }
hunk ./Main.hs 676
-    putErrLn $ "Entry: " ++ pprint (progMainEntry prog)
+    when (progMainEntry prog /= tvr) $
+        putErrLn $ "MainEntry: " ++ pprint (progMainEntry prog)
+    when (progEntryPoints prog /= [progMainEntry prog]) $
+        putErrLn $ "EntryPoints: " ++ hsep (map pprint (progEntryPoints prog))
+