X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=2b2c058194aabcfba31ca6ed282f6065c1c93eb0;hb=8e3b990169fc33f1924b4e4faa53a5c6fd43268b;hp=87444e024d9db7b9231561bc8d3ea8c0209dbdda;hpb=b4696d8ac6c34ccb4e3ed833831ba8166dcce578;p=ghc-hetmet.git diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index 87444e0..2b2c058 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -15,8 +15,6 @@ module OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where --- XXX This define is a bit of a hack, and should be done more nicely -#define FAST_STRING_NOT_NEEDED 1 #include "HsVersions.h" import CoreSyn @@ -30,7 +28,7 @@ import VarSet import VarEnv import Maybes ( orElse ) -import Digraph ( stronglyConnCompR, SCC(..) ) +import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR ) import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) import Unique ( Unique ) import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly ) @@ -86,7 +84,10 @@ occAnalBind :: OccEnv [CoreBind]) occAnalBind env (NonRec binder rhs) body_usage - | not (binder `usedIn` body_usage) -- It's not mentioned + | isTyVar binder -- A type let; we don't gather usage info + = (body_usage, [NonRec binder rhs]) + + | not (binder `usedIn` body_usage) -- It's not mentioned = (body_usage, []) | otherwise -- It's mentioned in the body @@ -279,51 +280,27 @@ This showed up when compiling Control.Concurrent.Chan.getChanContents. \begin{code} occAnalBind env (Rec pairs) body_usage - | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage - = (body_usage, []) -- Dead code - | otherwise - = (final_usage, map ({-# SCC "occAnalBind.dofinal" #-} do_final_bind) sccs) + = foldr occAnalRec (body_usage, []) sccs + -- For a recursive group, we + -- * occ-analyse all the RHSs + -- * compute strongly-connected components + -- * feed those components to occAnalRec where - bndrs = map fst pairs - bndr_set = mkVarSet bndrs - - --------------------------------------- - -- See Note [Loop breaking] - --------------------------------------- - -------------Dependency analysis ------------------------------ - occ_anald :: [(Id, (UsageDetails, CoreExpr))] - -- The UsageDetails here are strictly those arising from the RHS - -- *not* from any rules in the Id - occ_anald = [(bndr, occAnalRhs env bndr rhs) | (bndr,rhs) <- pairs] - - total_usage = foldl add_usage body_usage occ_anald - add_usage body_usage (bndr, (rhs_usage, _)) - = body_usage +++ addRuleUsage rhs_usage bndr - - (final_usage, tagged_bndrs) = tagBinders total_usage bndrs - final_bndrs | isEmptyVarSet all_rule_fvs = tagged_bndrs - | otherwise = map tag_rule_var tagged_bndrs - - tag_rule_var bndr | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr - | otherwise = bndr - all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars) emptyVarSet bndrs - -- Mark the binder with OccInfo saying "no preInlineUnconditionally" if - -- it is used in any rule (lhs or rhs) of the recursive group - - ---- stuff for dependency analysis of binds ------------------------------- - sccs :: [SCC (Node Details)] - sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR rec_edges - - rec_edges :: [Node Details] -- The binders are tagged with correct occ-info - rec_edges = {-# SCC "occAnalBind.assoc" #-} zipWith make_node final_bndrs occ_anald - make_node tagged_bndr (_bndr, (rhs_usage, rhs)) - = ((tagged_bndr, rhs, rhs_fvs), idUnique tagged_bndr, out_edges) - where - rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage - out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars tagged_bndr) - + bndr_set = mkVarSet (map fst pairs) + sccs :: [SCC (Node Details)] + sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR rec_edges + + rec_edges :: [Node Details] + rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs + + make_node (bndr, rhs) + = (ND bndr rhs' rhs_usage rhs_fvs, idUnique bndr, out_edges) + where + (rhs_usage, rhs') = occAnalRhs env bndr rhs + rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage + out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr) -- (a -> b) means a mentions b -- Given the usage details (a UFM that gives occ info for each free var of -- the RHS) we can get the list of free vars -- or rather their Int keys -- @@ -334,17 +311,67 @@ occAnalBind env (Rec pairs) body_usage -- which has n**2 cost, and this meant that edges_from alone -- consumed 10% of total runtime! - ---- Stuff to "re-constitute" bindings from dependency-analysis info ------ - do_final_bind (AcyclicSCC ((bndr, rhs, _), _, _)) = NonRec bndr rhs - do_final_bind (CyclicSCC cycle) - | no_rules = Rec (reOrderCycle cycle) - | otherwise = Rec (concatMap reOrderRec (stronglyConnCompR loop_breaker_edges)) - where -- See Note [Choosing loop breakers] for looop_breker_edges - loop_breaker_edges = map mk_node cycle - mk_node (details@(_bndr, _rhs, rhs_fvs), k, _) = (details, k, new_ks) - where - new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs) +----------------------------- +occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind]) + -> (UsageDetails, [CoreBind]) + -- The NonRec case is just like a Let (NonRec ...) above +occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds) + | not (bndr `usedIn` body_usage) + = (body_usage, binds) + + | otherwise -- It's mentioned in the body + = (body_usage' +++ addRuleUsage rhs_usage bndr, -- Note [Rules are extra RHSs] + NonRec tagged_bndr rhs : binds) + where + (body_usage', tagged_bndr) = tagBinder body_usage bndr + + + -- The Rec case is the interesting one + -- See Note [Loop breaking] +occAnalRec (CyclicSCC nodes) (body_usage, binds) + | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage + = (body_usage, binds) -- Dead code + + | otherwise -- At this point we always build a single Rec + = (final_usage, Rec pairs : binds) + + where + bndrs = [b | (ND b _ _ _, _, _) <- nodes] + bndr_set = mkVarSet bndrs + + ---------------------------- + -- Tag the binders with their occurrence info + total_usage = foldl add_usage body_usage nodes + add_usage body_usage (ND bndr _ rhs_usage _, _, _) + = body_usage +++ addRuleUsage rhs_usage bndr + (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes + + tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details) + -- (a) Tag the binders in the details with occ info + -- (b) Mark the binder with "weak loop-breaker" OccInfo + -- saying "no preInlineUnconditionally" if it is used + -- in any rule (lhs or rhs) of the recursive group + -- See Note [Weak loop breakers] + tag_node usage (ND bndr rhs rhs_usage rhs_fvs, k, ks) + = (usage `delVarEnv` bndr, (ND bndr2 rhs rhs_usage rhs_fvs, k, ks)) + where + bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1 + | otherwise = bndr1 + bndr1 = setBinderOcc usage bndr + all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars) + emptyVarSet bndrs + + ---------------------------- + -- Now reconstruct the cycle + pairs | no_rules = reOrderCycle tagged_nodes + | otherwise = concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR loop_breaker_edges) + + -- See Note [Choosing loop breakers] for looop_breaker_edges + loop_breaker_edges = map mk_node tagged_nodes + mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks) + where + new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs) ------------------------------------ rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules @@ -421,18 +448,20 @@ Perhaps something cleverer would suffice. \begin{code} -type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, - -- which is gotten from the Id. -type Details = (Id, -- Binder - CoreExpr, -- RHS - IdSet) -- RHS free vars (*not* include rules) +type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, + -- which is gotten from the Id. +data Details = ND Id -- Binder + CoreExpr -- RHS + UsageDetails -- Full usage from RHS (*not* including rules) + IdSet -- Other binders from this Rec group mentioned on RHS + -- (derivable from UsageDetails but cached here) reOrderRec :: SCC (Node Details) -> [(Id,CoreExpr)] -- Sorted into a plausible order. Enough of the Ids have -- IAmALoopBreaker pragmas that there are no loops left. -reOrderRec (AcyclicSCC ((bndr, rhs, _), _, _)) = [(bndr, rhs)] -reOrderRec (CyclicSCC cycle) = reOrderCycle cycle +reOrderRec (AcyclicSCC (ND bndr rhs _ _, _, _)) = [(bndr, rhs)] +reOrderRec (CyclicSCC cycle) = reOrderCycle cycle reOrderCycle :: [Node Details] -> [(Id,CoreExpr)] reOrderCycle [] @@ -440,17 +469,17 @@ reOrderCycle [] reOrderCycle [bind] -- Common case of simple self-recursion = [(makeLoopBreaker False bndr, rhs)] where - ((bndr, rhs, _), _, _) = bind + (ND bndr rhs _ _, _, _) = bind reOrderCycle (bind : binds) = -- Choose a loop breaker, mark it no-inline, -- do SCC analysis on the rest, and recursively sort them out - concatMap reOrderRec (stronglyConnCompR unchosen) ++ + concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR unchosen) ++ [(makeLoopBreaker False bndr, rhs)] where (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds - (bndr, rhs, _) = chosen_bind + ND bndr rhs _ _ = chosen_bind -- This loop looks for the bind with the lowest score -- to pick as the loop breaker. The rest accumulate in @@ -467,23 +496,32 @@ reOrderCycle (bind : binds) sc = score bind score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker - score ((bndr, rhs, _), _, _) + score (ND bndr rhs _ _, _, _) | workerExists (idWorkerInfo bndr) = 10 -- Note [Worker inline loop] - | exprIsTrivial rhs = 4 -- Practically certain to be inlined + | exprIsTrivial rhs = 5 -- Practically certain to be inlined -- Used to have also: && not (isExportedId bndr) -- But I found this sometimes cost an extra iteration when we have -- rec { d = (a,b); a = ...df...; b = ...df...; df = d } -- where df is the exported dictionary. Then df makes a really -- bad choice for loop breaker - | is_con_app rhs = 2 -- Data types help with cases + | is_con_app rhs = 3 -- Data types help with cases -- Note [conapp] - | inlineCandidate bndr rhs = 1 -- Likely to be inlined +-- If an Id is marked "never inline" then it makes a great loop breaker +-- The only reason for not checking that here is that it is rare +-- and I've never seen a situation where it makes a difference, +-- so it probably isn't worth the time to test on every binder +-- | isNeverActive (idInlinePragma bndr) = -10 + + | inlineCandidate bndr rhs = 2 -- Likely to be inlined -- Note [Inline candidates] + | not (neverUnfold (idUnfolding bndr)) = 1 + -- the Id has some kind of unfolding + | otherwise = 0 inlineCandidate :: Id -> CoreExpr -> Bool