X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=fb7257739f6168482dbd46a6e90e205dd3b62de5;hb=8604da0136707cc14845d14a88c2272fe576b6d0;hp=e6013f3742f261c777d8eed4f3881195e466fd3f;hpb=c248518fe81b6d2807d3bcbb8a09ae14facce1ad;p=ghc-hetmet.git diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index e6013f3..fb72577 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -2,9 +2,9 @@ % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % %************************************************************************ -%* * +%* * \section[OccurAnal]{Occurrence analysis pass} -%* * +%* * %************************************************************************ The occurrence analyser re-typechecks a core expression, returning a new @@ -12,39 +12,37 @@ core expression with (hopefully) improved usage information. \begin{code} module OccurAnal ( - occurAnalysePgm, occurAnalyseExpr + occurAnalysePgm, occurAnalyseExpr ) where #include "HsVersions.h" import CoreSyn -import CoreFVs ( idRuleVars ) -import CoreUtils ( exprIsTrivial, isDefaultAlt ) -import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda, - idOccInfo, setIdOccInfo, isLocalId, - isExportedId, idArity, idHasRules, - idType, idUnique, Id - ) -import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt ) +import CoreFVs +import CoreUtils ( exprIsTrivial, isDefaultAlt ) +import Id +import IdInfo +import BasicTypes import VarSet import VarEnv -import Type ( isFunTy, dropForAlls ) -import Maybes ( orElse ) -import Digraph ( stronglyConnCompR, SCC(..) ) -import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) -import Unique ( Unique ) -import UniqFM ( keysUFM, lookupUFM_Directly ) -import Util ( zipWithEqual, mapAndUnzip ) +import Maybes ( orElse ) +import Digraph ( stronglyConnCompR, SCC(..) ) +import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey ) +import Unique ( Unique ) +import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly ) +import Util ( mapAndUnzip ) import Outputable + +import Data.List \end{code} %************************************************************************ -%* * +%* * \subsection[OccurAnal-main]{Counting occurrences: main function} -%* * +%* * %************************************************************************ Here's the externally-callable interface: @@ -55,177 +53,370 @@ occurAnalysePgm binds = snd (go initOccEnv binds) where go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind]) - go env [] - = (emptyDetails, []) - go env (bind:binds) - = (final_usage, bind' ++ binds') - where - (bs_usage, binds') = go env binds - (final_usage, bind') = occAnalBind env bind bs_usage + go _ [] + = (emptyDetails, []) + go env (bind:binds) + = (final_usage, bind' ++ binds') + where + (bs_usage, binds') = go env binds + (final_usage, bind') = occAnalBind env bind bs_usage occurAnalyseExpr :: CoreExpr -> CoreExpr - -- Do occurrence analysis, and discard occurence info returned + -- Do occurrence analysis, and discard occurence info returned occurAnalyseExpr expr = snd (occAnal initOccEnv expr) \end{code} %************************************************************************ -%* * +%* * \subsection[OccurAnal-main]{Counting occurrences: main function} -%* * +%* * %************************************************************************ Bindings ~~~~~~~~ \begin{code} -type IdWithOccInfo = Id -- An Id with fresh PragmaInfo attached - -type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique, - -- which is gotten from the Id. -type Details1 = (Id, UsageDetails, CoreExpr) -type Details2 = (IdWithOccInfo, CoreExpr) - - occAnalBind :: OccEnv - -> CoreBind - -> UsageDetails -- Usage details of scope - -> (UsageDetails, -- Of the whole let(rec) - [CoreBind]) + -> CoreBind + -> UsageDetails -- Usage details of scope + -> (UsageDetails, -- Of the whole let(rec) + [CoreBind]) occAnalBind env (NonRec binder rhs) body_usage - | not (binder `usedIn` body_usage) -- It's not mentioned + | not (binder `usedIn` body_usage) -- It's not mentioned = (body_usage, []) - | otherwise -- It's mentioned in the body - = (final_body_usage `combineUsageDetails` rhs_usage, + | otherwise -- It's mentioned in the body + = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs] [NonRec tagged_binder rhs']) - where - (final_body_usage, tagged_binder) = tagBinder body_usage binder - (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs + (body_usage', tagged_binder) = tagBinder body_usage binder + (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs \end{code} +Note [Dead code] +~~~~~~~~~~~~~~~~ Dropping dead code for recursive bindings is done in a very simple way: - the entire set of bindings is dropped if none of its binders are - mentioned in its body; otherwise none are. + the entire set of bindings is dropped if none of its binders are + mentioned in its body; otherwise none are. This seems to miss an obvious improvement. -@ - letrec f = ...g... - g = ...f... - in - ...g... + letrec f = ...g... + g = ...f... + in + ...g... ===> + letrec f = ...g... + g = ...(...g...)... + in + ...g... + +Now 'f' is unused! But it's OK! Dependency analysis will sort this +out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get +dropped. It isn't easy to do a perfect job in one blow. Consider + + letrec f = ...g... + g = ...h... + h = ...k... + k = ...m... + m = ...m... + in + ...m... + + +Note [Loop breaking and RULES] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Loop breaking is surprisingly subtle. First read the section 4 of +"Secrets of the GHC inliner". This describes our basic plan. + +However things are made quite a bit more complicated by RULES. Remember + + * Note [Rules are extra RHSs] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + A RULE for 'f' is like an extra RHS for 'f'. That way the "parent" + keeps the specialised "children" alive. If the parent dies + (because it isn't referenced any more), then the children will die + too (unless they are already referenced directly). + + To that end, we build a Rec group for each cyclic strongly + connected component, + *treating f's rules as extra RHSs for 'f'*. + + When we make the Rec groups we include variables free in *either* + LHS *or* RHS of the rule. The former might seems silly, but see + Note [Rule dependency info]. + + So in Example [eftInt], eftInt and eftIntFB will be put in the + same Rec, even though their 'main' RHSs are both non-recursive. + + * Note [Rules are visible in their own rec group] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We want the rules for 'f' to be visible in f's right-hand side. + And we'd like them to be visible in other functions in f's Rec + group. E.g. in Example [Specialisation rules] we want f' rule + to be visible in both f's RHS, and fs's RHS. + + This means that we must simplify the RULEs first, before looking + at any of the definitions. This is done by Simplify.simplRecBind, + when it calls addLetIdInfo. + + * Note [Choosing loop breakers] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ + We avoid infinite inlinings by choosing loop breakers, and + ensuring that a loop breaker cuts each loop. But what is a + "loop"? In particular, a RULES is like an equation for 'f' that + is *always* inlined if it are applicable. We do *not* disable + rules for loop-breakers. It's up to whoever makes the rules to + make sure that the rules themselves alwasys terminate. See Note + [Rules for recursive functions] in Simplify.lhs + + Hence, if + f's RHS mentions g, and + g has a RULE that mentions h, and + h has a RULE that mentions f + + then we *must* choose f to be a loop breaker. In general, take the + free variables of f's RHS, and augment it with all the variables + reachable by RULES from those starting points. That is the whole + reason for computing rule_fv_env in occAnalBind. (Of course we + only consider free vars that are also binders in this Rec group.) + + Note that when we compute this rule_fv_env, we only consider variables + free in the *RHS* of the rule, in contrast to the way we build the + Rec group in the first place (Note [Rule dependency info]) + + Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is + chosen as a loop breaker, because their RHSs don't mention each other. + And indeed both can be inlined safely. + + Note that the edges of the graph we use for computing loop breakers + are not the same as the edges we use for computing the Rec blocks. + That's why we compute + rec_edges for the Rec block analysis + loop_breaker_edges for the loop breaker analysis + + + * Note [Weak loop breakers] + ~~~~~~~~~~~~~~~~~~~~~~~~~ + There is a last nasty wrinkle. Suppose we have + + Rec { f = f_rhs + RULE f [] = g + + h = h_rhs + g = h + ...more... + } + + Remmber that we simplify the RULES before any RHS (see Note + [Rules are visible in their own rec group] above). + + So we must *not* postInlineUnconditionally 'g', even though + its RHS turns out to be trivial. (I'm assuming that 'g' is + not choosen as a loop breaker.) + + We "solve" this by making g a "weak" or "rules-only" loop breaker, + with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker + has IAmLoopBreaker False. So + + Inline postInlineUnconditinoally + IAmLoopBreaker False no no + IAmLoopBreaker True yes no + other yes yes + + The **sole** reason for this kind of loop breaker is so that + postInlineUnconditionally does not fire. Ugh. + + * Note [Rule dependency info] + ~~~~~~~~~~~~~~~~~~~~~~~~~~~ + The VarSet in a SpecInfo is used for dependency analysis in the + occurrence analyser. We must track free vars in *both* lhs and rhs. Why both? + Consider + x = y + RULE f x = 4 + Then if we substitute y for x, we'd better do so in the + rule's LHS too, so we'd better ensure the dependency is respected + - letrec f = ...g... - g = ...(...g...)... - in - ...g... -@ +Example [eftInt] +~~~~~~~~~~~~~~~ +Example (from GHC.Enum): -Now @f@ is unused. But dependency analysis will sort this out into a -@letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped. -It isn't easy to do a perfect job in one blow. Consider + eftInt :: Int# -> Int# -> [Int] + eftInt x y = ...(non-recursive)... + + {-# INLINE [0] eftIntFB #-} + eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r + eftIntFB c n x y = ...(non-recursive)... + + {-# RULES + "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y) + "eftIntList" [1] eftIntFB (:) [] = eftInt + #-} -@ - letrec f = ...g... - g = ...h... - h = ...k... - k = ...m... - m = ...m... - in - ...m... -@ +Example [Specialisation rules] +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +Consider this group, which is typical of what SpecConstr builds: + + fs a = ....f (C a).... + f x = ....f (C a).... + {-# RULE f (C a) = fs a #-} + +So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE). + +But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop: + - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify + - fs is inlined (say it's small) + - now there's another opportunity to apply the RULE + +This showed up when compiling Control.Concurrent.Chan.getChanContents. \begin{code} occAnalBind env (Rec pairs) body_usage - = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) 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 - analysed_pairs :: [Details1] - analysed_pairs = [ (bndr, rhs_usage, rhs') - | (bndr, rhs) <- pairs, - let (rhs_usage, rhs') = occAnalRhs env bndr rhs - ] - - sccs :: [SCC (Node Details1)] - sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges - - - ---- stuff for dependency analysis of binds ------------------------------- - edges :: [Node Details1] - edges = _scc_ "occAnalBind.assoc" - [ (details, idUnique id, edges_from rhs_usage) - | details@(id, rhs_usage, rhs) <- analysed_pairs - ] - - -- (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 -- - -- by just extracting the keys from the finite map. Grimy, but fast. - -- Previously we had this: - -- [ bndr | bndr <- bndrs, - -- maybeToBool (lookupVarEnv rhs_usage bndr)] - -- which has n**2 cost, and this meant that edges_from alone - -- consumed 10% of total runtime! - edges_from :: UsageDetails -> [Unique] - edges_from rhs_usage = _scc_ "occAnalBind.edges_from" - keysUFM rhs_usage - - ---- stuff to "re-constitute" bindings from dependency-analysis info ------ - - -- Non-recursive SCC - do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far) - | not (bndr `usedIn` body_usage) - = (body_usage, binds_so_far) -- Dead code - | otherwise - = (combined_usage, new_bind : binds_so_far) - where - total_usage = combineUsageDetails body_usage rhs_usage - (combined_usage, tagged_bndr) = tagBinder total_usage bndr - new_bind = NonRec tagged_bndr rhs' - - -- Recursive SCC - do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far) - | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage - = (body_usage, binds_so_far) -- Dead code - | otherwise - = (combined_usage, final_bind:binds_so_far) + -------------Dependency analysis ------------------------------ + bndr_set = mkVarSet (map fst pairs) + + sccs :: [SCC (Node Details)] + sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompR 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 -- + -- by just extracting the keys from the finite map. Grimy, but fast. + -- Previously we had this: + -- [ bndr | bndr <- bndrs, + -- maybeToBool (lookupVarEnv rhs_usage bndr)] + -- which has n**2 cost, and this meant that edges_from alone + -- consumed 10% of total runtime! + +----------------------------- +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 - details = [details | (details, _, _) <- cycle] - bndrs = [bndr | (bndr, _, _) <- details] - rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details] - total_usage = foldr combineUsageDetails body_usage rhs_usages - (combined_usage, tagged_bndrs) = tagBinders total_usage bndrs - final_bind = Rec (doReorder edges) - - -- Hopefully 'bndrs' is a relatively small group now - -- Now get ready for the loop-breaking phase, this time ignoring RulesOnly references - -- We've done dead-code elimination already, so no worries about un-referenced binders - edges :: [Node Details2] - edges = zipWithEqual "reorder" mk_edge tagged_bndrs details - keys = map idUnique bndrs - mk_edge tagged_bndr (_, rhs_usage, rhs') - = ((tagged_bndr, rhs'), idUnique tagged_bndr, used) - where - used = [key | key <- keys, used_outside_rule rhs_usage key ] - - used_outside_rule usage uniq = case lookupUFM_Directly usage uniq of - Nothing -> False - Just RulesOnly -> False -- Ignore rules - other -> True + 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 (stronglyConnCompR 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 + -- Domain is *subset* of bound vars (others have no rule fvs) + rule_fv_env = rule_loop init_rule_fvs + + no_rules = null init_rule_fvs + init_rule_fvs = [(b, rule_fvs) + | b <- bndrs + , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set + , not (isEmptyVarSet rule_fvs)] + + rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint + rule_loop fv_list + | no_change = env + | otherwise = rule_loop new_fv_list + where + env = mkVarEnv init_rule_fvs + (no_change, new_fv_list) = mapAccumL bump True fv_list + bump no_change (b,fvs) + | new_fvs `subVarSet` fvs = (no_change, (b,fvs)) + | otherwise = (False, (b,new_fvs `unionVarSet` fvs)) + where + new_fvs = extendFvs env emptyVarSet fvs + +idRuleRhsVars :: Id -> VarSet +-- Just the variables free on the *rhs* of a rule +-- See Note [Choosing loop breakers] +idRuleRhsVars id = foldr (unionVarSet . ruleRhsFreeVars) emptyVarSet (idCoreRules id) + +extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet +-- (extendFVs env fvs s) returns (fvs `union` env(s)) +extendFvs env fvs id_set + = foldUFM_Directly add fvs id_set + where + add uniq _ fvs + = case lookupVarEnv_Directly env uniq of + Just fvs' -> fvs' `unionVarSet` fvs + Nothing -> fvs \end{code} @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic strongly connected component (there's guaranteed to be a cycle). It returns the -same pairs, but - a) in a better order, - b) with some of the Ids having a IMustNotBeINLINEd pragma +same pairs, but + a) in a better order, + b) with some of the Ids having a IAmALoopBreaker pragma -The "no-inline" Ids are sufficient to break all cycles in the SCC. This means +The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means that the simplifier can guarantee not to loop provided it never records an inlining for these no-inline guys. @@ -235,16 +426,16 @@ that the simplifier will generally do a good job if it works from top bottom, recording inlinings for any Ids which aren't marked as "no-inline" as it goes. ============== -[June 98: I don't understand the following paragraphs, and I've - changed the a=b case again so that it isn't a special case any more.] +[June 98: I don't understand the following paragraphs, and I've + changed the a=b case again so that it isn't a special case any more.] Here's a case that bit me: - letrec - a = b - b = \x. BIG - in - ...a...a...a.... + letrec + a = b + b = \x. BIG + in + ...a...a...a.... Re-ordering doesn't change the order of bindings, but there was no loop-breaker. @@ -252,110 +443,162 @@ My solution was to make a=b bindings record b as Many, rather like INLINE bindin Perhaps something cleverer would suffice. =============== -You might think that you can prevent non-termination simply by making -sure that we simplify a recursive binding's RHS in an environment that -simply clones the recursive Id. But no. Consider - letrec f = \x -> let z = f x' in ... +\begin{code} +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 (ND bndr rhs _ _, _, _)) = [(bndr, rhs)] +reOrderRec (CyclicSCC cycle) = reOrderCycle cycle + +reOrderCycle :: [Node Details] -> [(Id,CoreExpr)] +reOrderCycle [] + = panic "reOrderCycle" +reOrderCycle [bind] -- Common case of simple self-recursion + = [(makeLoopBreaker False bndr, rhs)] + where + (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) ++ + [(makeLoopBreaker False bndr, rhs)] + + where + (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds + ND bndr rhs _ _ = chosen_bind - in - let n = f y - in - case n of { ... } + -- This loop looks for the bind with the lowest score + -- to pick as the loop breaker. The rest accumulate in + choose_loop_breaker (details,_,_) _loop_sc acc [] + = (details, acc) -- Done -We bind n to its *simplified* RHS, we then *re-simplify* it when -we inline n. Then we may well inline f; and then the same thing -happens with z! + choose_loop_breaker loop_bind loop_sc acc (bind : binds) + | sc < loop_sc -- Lower score so pick this new one + = choose_loop_breaker bind sc (loop_bind : acc) binds -I don't think it's possible to prevent non-termination by environment -manipulation in this way. Apart from anything else, successive -iterations of the simplifier may unroll recursive loops in cases like -that above. The idea of beaking every recursive loop with an -IMustNotBeINLINEd pragma is much much better. + | otherwise -- No lower so don't pick it + = choose_loop_breaker loop_bind loop_sc (bind : acc) binds + where + sc = score bind + score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker + score (ND bndr rhs _ _, _, _) + | workerExists (idWorkerInfo bndr) = 10 + -- Note [Worker inline loop] -\begin{code} -doReorder :: [Node Details2] -> [Details2] --- Sorted into a plausible order. Enough of the Ids have --- dontINLINE pragmas that there are no loops left. -doReorder nodes = concatMap reOrderRec (stronglyConnCompR nodes) + | exprIsTrivial rhs = 4 -- 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 -reOrderRec :: SCC (Node Details2) -> [Details2] + | is_con_app rhs = 2 -- Data types help with cases + -- Note [conapp] - -- Non-recursive case -reOrderRec (AcyclicSCC (bind, _, _)) = [bind] +-- 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 - -- Common case of simple self-recursion -reOrderRec (CyclicSCC []) - = panic "reOrderRec" + | inlineCandidate bndr rhs = 1 -- Likely to be inlined + -- Note [Inline candidates] -reOrderRec (CyclicSCC [bind]) - = [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)] - where - ((tagged_bndr, rhs), _, _) = bind + | otherwise = 0 -reOrderRec (CyclicSCC (bind : binds)) - = -- Choose a loop breaker, mark it no-inline, - -- do SCC analysis on the rest, and recursively sort them out - doReorder unchosen ++ - [(setIdOccInfo tagged_bndr IAmALoopBreaker, rhs)] + inlineCandidate :: Id -> CoreExpr -> Bool + inlineCandidate _ (Note InlineMe _) = True + inlineCandidate id _ = isOneOcc (idOccInfo id) + + -- Note [conapp] + -- + -- It's really really important to inline dictionaries. Real + -- example (the Enum Ordering instance from GHC.Base): + -- + -- rec f = \ x -> case d of (p,q,r) -> p x + -- g = \ x -> case d of (p,q,r) -> q x + -- d = (v, f, g) + -- + -- Here, f and g occur just once; but we can't inline them into d. + -- On the other hand we *could* simplify those case expressions if + -- we didn't stupidly choose d as the loop breaker. + -- But we won't because constructor args are marked "Many". + -- Inlining dictionaries is really essential to unravelling + -- the loops in static numeric dictionaries, see GHC.Float. + + -- Cheap and cheerful; the simplifer moves casts out of the way + -- The lambda case is important to spot x = /\a. C (f a) + -- which comes up when C is a dictionary constructor and + -- f is a default method. + -- Example: the instance for Show (ST s a) in GHC.ST + -- + -- However we *also* treat (\x. C p q) as a con-app-like thing, + -- Note [Closure conversion] + is_con_app (Var v) = isDataConWorkId v + is_con_app (App f _) = is_con_app f + is_con_app (Lam _ e) = is_con_app e + is_con_app (Note _ e) = is_con_app e + is_con_app _ = False + +makeLoopBreaker :: Bool -> Id -> Id +-- Set the loop-breaker flag +-- See Note [Weak loop breakers] +makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak) +\end{code} - where - (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds - (tagged_bndr, rhs) = chosen_pair +Note [Worker inline loop] +~~~~~~~~~~~~~~~~~~~~~~~~ +Never choose a wrapper as the loop breaker! Because +wrappers get auto-generated inlinings when importing, and +that can lead to an infinite inlining loop. For example: + rec { + $wfoo x = ....foo x.... - -- This loop looks for the bind with the lowest score - -- to pick as the loop breaker. The rest accumulate in - choose_loop_breaker (details,_,_) loop_sc acc [] - = (details, acc) -- Done + {-loop brk-} foo x = ...$wfoo x... + } - choose_loop_breaker loop_bind loop_sc acc (bind : binds) - | sc < loop_sc -- Lower score so pick this new one - = choose_loop_breaker bind sc (loop_bind : acc) binds +The interface file sees the unfolding for $wfoo, and sees that foo is +strict (and hence it gets an auto-generated wrapper). Result: an +infinite inlining in the importing scope. So be a bit careful if you +change this. A good example is Tree.repTree in +nofib/spectral/minimax. If the repTree wrapper is chosen as the loop +breaker then compiling Game.hs goes into an infinite loop (this +happened when we gave is_con_app a lower score than inline candidates). - | otherwise -- No lower so don't pick it - = choose_loop_breaker loop_bind loop_sc (bind : acc) binds - where - sc = score bind - - score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker - score ((bndr, rhs), _, _) - | exprIsTrivial rhs = 4 -- 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 - - | not_fun_ty (idType bndr) = 3 -- Data types help with cases - -- This used to have a lower score than inlineCandidate, but - -- it's *really* helpful if dictionaries get inlined fast, - -- so I'm experimenting with giving higher priority to data-typed things - - | inlineCandidate bndr rhs = 2 -- Likely to be inlined - - | idHasRules bndr = 1 - -- Avoid things with specialisations; we'd like - -- to take advantage of them in the subsequent bindings - - | otherwise = 0 +Note [Closure conversion] +~~~~~~~~~~~~~~~~~~~~~~~~~ +We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm. +The immediate motivation came from the result of a closure-conversion transformation +which generated code like this: + + data Clo a b = forall c. Clo (c -> a -> b) c + + ($:) :: Clo a b -> a -> b + Clo f env $: x = f env x + + rec { plus = Clo plus1 () + + ; plus1 _ n = Clo plus2 n + + ; plus2 Zero n = n + ; plus2 (Succ m) n = Succ (plus $: m $: n) } + +If we inline 'plus' and 'plus1', everything unravels nicely. But if +we choose 'plus1' as the loop breaker (which is entirely possible +otherwise), the loop does not unravel nicely. - inlineCandidate :: Id -> CoreExpr -> Bool - inlineCandidate id (Note InlineMe _) = True - inlineCandidate id rhs = isOneOcc (idOccInfo id) - - -- Real example (the Enum Ordering instance from PrelBase): - -- rec f = \ x -> case d of (p,q,r) -> p x - -- g = \ x -> case d of (p,q,r) -> q x - -- d = (v, f, g) - -- - -- Here, f and g occur just once; but we can't inline them into d. - -- On the other hand we *could* simplify those case expressions if - -- we didn't stupidly choose d as the loop breaker. - -- But we won't because constructor args are marked "Many". - - not_fun_ty ty = not (isFunTy (dropForAlls ty)) -\end{code} @occAnalRhs@ deals with the question of bindings where the Id is marked by an INLINE pragma. For these we record that anything which occurs @@ -370,67 +613,62 @@ ToDo: try using the occurrence info for the inline'd binder. \begin{code} occAnalRhs :: OccEnv - -> Id -> CoreExpr -- Binder and rhs - -- For non-recs the binder is alrady tagged - -- with occurrence info - -> (UsageDetails, CoreExpr) + -> Id -> CoreExpr -- Binder and rhs + -- For non-recs the binder is alrady tagged + -- with occurrence info + -> (UsageDetails, CoreExpr) occAnalRhs env id rhs - = (final_usage, rhs') + = occAnal ctxt rhs where - (rhs_usage, rhs') = occAnal ctxt rhs ctxt | certainly_inline id = env - | otherwise = rhsCtxt - -- Note that we generally use an rhsCtxt. This tells the occ anal n - -- that it's looking at an RHS, which has an effect in occAnalApp - -- - -- But there's a problem. Consider - -- x1 = a0 : [] - -- x2 = a1 : x1 - -- x3 = a2 : x2 - -- g = f x3 - -- First time round, it looks as if x1 and x2 occur as an arg of a - -- let-bound constructor ==> give them a many-occurrence. - -- But then x3 is inlined (unconditionally as it happens) and - -- next time round, x2 will be, and the next time round x1 will be - -- Result: multiple simplifier iterations. Sigh. - -- Crude solution: use rhsCtxt for things that occur just once... + | otherwise = rhsCtxt + -- Note that we generally use an rhsCtxt. This tells the occ anal n + -- that it's looking at an RHS, which has an effect in occAnalApp + -- + -- But there's a problem. Consider + -- x1 = a0 : [] + -- x2 = a1 : x1 + -- x3 = a2 : x2 + -- g = f x3 + -- First time round, it looks as if x1 and x2 occur as an arg of a + -- let-bound constructor ==> give them a many-occurrence. + -- But then x3 is inlined (unconditionally as it happens) and + -- next time round, x2 will be, and the next time round x1 will be + -- Result: multiple simplifier iterations. Sigh. + -- Crude solution: use rhsCtxt for things that occur just once... certainly_inline id = case idOccInfo id of - OneOcc in_lam one_br _ -> not in_lam && one_br - other -> False + OneOcc in_lam one_br _ -> not in_lam && one_br + _ -> False +\end{code} - -- [March 98] A new wrinkle is that if the binder has specialisations inside - -- it then we count the specialised Ids as "extra rhs's". That way - -- the "parent" keeps the specialised "children" alive. If the parent - -- dies (because it isn't referenced any more), then the children will - -- die too unless they are already referenced directly. - final_usage = addRuleUsage rhs_usage id +\begin{code} addRuleUsage :: UsageDetails -> Id -> UsageDetails -- Add the usage from RULES in Id to the usage addRuleUsage usage id = foldVarSet add usage (idRuleVars id) where - add v u = addOneOcc u v RulesOnly -- Give a non-committal binder info - -- (i.e manyOcc) because many copies - -- of the specialised thing can appear + add v u = addOneOcc u v NoOccInfo -- Give a non-committal binder info + -- (i.e manyOcc) because many copies + -- of the specialised thing can appear \end{code} Expressions ~~~~~~~~~~~ \begin{code} occAnal :: OccEnv - -> CoreExpr - -> (UsageDetails, -- Gives info only about the "interesting" Ids - CoreExpr) + -> CoreExpr + -> (UsageDetails, -- Gives info only about the "interesting" Ids + CoreExpr) -occAnal env (Type t) = (emptyDetails, Type t) +occAnal _ (Type t) = (emptyDetails, Type t) occAnal env (Var v) = (mkOneOcc env v False, Var v) -- At one stage, I gathered the idRuleVars for v here too, -- which in a way is the right thing to do. - -- Btu that went wrong right after specialisation, when + -- But that went wrong right after specialisation, when -- the *occurrences* of the overloaded function didn't have any -- rules in them, so the *specialised* versions looked as if they -- weren't used at all. @@ -440,8 +678,8 @@ We regard variables that occur as constructor arguments as "dangerousToDup": \begin{verbatim} module A where -f x = let y = expensive x in - let z = (True,y) in +f x = let y = expensive x in + let z = (True,y) in (case z of {(p,q)->q}, case z of {(p,q)->q}) \end{verbatim} @@ -452,16 +690,16 @@ If we aren't careful we duplicate the (expensive x) call! Constructors are rather like lambdas in this way. \begin{code} -occAnal env expr@(Lit lit) = (emptyDetails, expr) +occAnal _ expr@(Lit _) = (emptyDetails, expr) \end{code} \begin{code} occAnal env (Note InlineMe body) - = case occAnal env body of { (usage, body') -> + = case occAnal env body of { (usage, body') -> (mapVarEnv markMany usage, Note InlineMe body') } -occAnal env (Note note@(SCC cc) body) +occAnal env (Note note@(SCC _) body) = case occAnal env body of { (usage, body') -> (mapVarEnv markInsideSCC usage, Note note body') } @@ -473,25 +711,28 @@ occAnal env (Note note body) occAnal env (Cast expr co) = case occAnal env expr of { (usage, expr') -> - (usage, Cast expr' co) + (markRhsUds env True usage, Cast expr' co) + -- If we see let x = y `cast` co + -- then mark y as 'Many' so that we don't + -- immediately inline y again. } \end{code} \begin{code} -occAnal env app@(App fun arg) - = occAnalApp env (collectArgs app) False +occAnal env app@(App _ _) + = occAnalApp env (collectArgs app) -- Ignore type variables altogether -- (a) occurrences inside type lambdas only not marked as InsideLam -- (b) type variables not in environment -occAnal env expr@(Lam x body) | isTyVar x +occAnal env (Lam x body) | isTyVar x = case occAnal env body of { (body_usage, body') -> (body_usage, Lam x body') } -- For value lambdas we do a special hack. Consider --- (\x. \y. ...x...) +-- (\x. \y. ...x...) -- If we did nothing, x is used inside the \y, so would be marked -- as dangerous to dup. But in the common case where the abstraction -- is applied to two arguments this is over-pessimistic. @@ -503,64 +744,65 @@ occAnal env expr@(Lam _ _) = case occAnal env_body body of { (body_usage, body') -> let (final_usage, tagged_binders) = tagBinders body_usage binders - -- URGH! Sept 99: we don't seem to be able to use binders' here, because - -- we get linear-typed things in the resulting program that we can't handle yet. - -- (e.g. PrelShow) TODO - - really_final_usage = if linear then - final_usage - else - mapVarEnv markInsideLam final_usage + -- URGH! Sept 99: we don't seem to be able to use binders' here, because + -- we get linear-typed things in the resulting program that we can't handle yet. + -- (e.g. PrelShow) TODO + + really_final_usage = if linear then + final_usage + else + mapVarEnv markInsideLam final_usage in (really_final_usage, mkLams tagged_binders body') } where - env_body = vanillaCtxt -- Body is (no longer) an RhsContext + env_body = vanillaCtxt -- Body is (no longer) an RhsContext (binders, body) = collectBinders expr - binders' = oneShotGroup env binders - linear = all is_one_shot binders' + binders' = oneShotGroup env binders + linear = all is_one_shot binders' is_one_shot b = isId b && isOneShotBndr b occAnal env (Case scrut bndr ty alts) - = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> - case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') -> + = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') -> + case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') -> let - alts_usage = foldr1 combineAltsUsageDetails alts_usage_s - alts_usage' = addCaseBndrUsage alts_usage - (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr - total_usage = scrut_usage `combineUsageDetails` alts_usage1 + alts_usage = foldr1 combineAltsUsageDetails alts_usage_s + alts_usage' = addCaseBndrUsage alts_usage + (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr + total_usage = scrut_usage +++ alts_usage1 in total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} where - -- The case binder gets a usage of either "many" or "dead", never "one". - -- Reason: we like to inline single occurrences, to eliminate a binding, - -- but inlining a case binder *doesn't* eliminate a binding. - -- We *don't* want to transform - -- case x of w { (p,q) -> f w } - -- into - -- case x of w { (p,q) -> f (p,q) } + -- The case binder gets a usage of either "many" or "dead", never "one". + -- Reason: we like to inline single occurrences, to eliminate a binding, + -- but inlining a case binder *doesn't* eliminate a binding. + -- We *don't* want to transform + -- case x of w { (p,q) -> f w } + -- into + -- case x of w { (p,q) -> f (p,q) } addCaseBndrUsage usage = case lookupVarEnv usage bndr of - Nothing -> usage - Just occ -> extendVarEnv usage bndr (markMany occ) + Nothing -> usage + Just occ -> extendVarEnv usage bndr (markMany occ) alt_env = setVanillaCtxt env - -- Consider x = case v of { True -> (p,q); ... } - -- Then it's fine to inline p and q + -- Consider x = case v of { True -> (p,q); ... } + -- Then it's fine to inline p and q occ_anal_scrut (Var v) (alt1 : other_alts) - | not (null other_alts) || not (isDefaultAlt alt1) - = (mkOneOcc env v True, Var v) - occ_anal_scrut scrut alts = occAnal vanillaCtxt scrut - -- No need for rhsCtxt + | not (null other_alts) || not (isDefaultAlt alt1) + = (mkOneOcc env v True, Var v) + occ_anal_scrut scrut _alts = occAnal vanillaCtxt scrut + -- No need for rhsCtxt occAnal env (Let bind body) - = case occAnal env body of { (body_usage, body') -> + = case occAnal env body of { (body_usage, body') -> case occAnalBind env bind body_usage of { (final_usage, new_binds) -> (final_usage, mkLets new_binds body') }} -occAnalArgs env args - = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') -> - (foldr combineUsageDetails emptyDetails arg_uds_s, args')} +occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr]) +occAnalArgs _env args + = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') -> + (foldr (+++) emptyDetails arg_uds_s, args')} where arg_env = vanillaCtxt \end{code} @@ -569,104 +811,118 @@ Applications are dealt with specially because we want the "build hack" to work. \begin{code} -occAnalApp env (Var fun, args) is_rhs +occAnalApp :: OccEnv + -> (Expr CoreBndr, [Arg CoreBndr]) + -> (UsageDetails, Expr CoreBndr) +occAnalApp env (Var fun, args) = case args_stuff of { (args_uds, args') -> let - -- We mark the free vars of the argument of a constructor or PAP - -- as "many", if it is the RHS of a let(rec). - -- This means that nothing gets inlined into a constructor argument - -- position, which is what we want. Typically those constructor - -- arguments are just variables, or trivial expressions. - -- - -- This is the *whole point* of the isRhsEnv predicate - final_args_uds - | isRhsEnv env, - isDataConWorkId fun || valArgCount args < idArity fun - = mapVarEnv markMany args_uds - | otherwise = args_uds + final_args_uds = markRhsUds env is_pap args_uds in - (fun_uds `combineUsageDetails` final_args_uds, mkApps (Var fun) args') } + (fun_uds +++ final_args_uds, mkApps (Var fun) args') } where fun_uniq = idUnique fun fun_uds = mkOneOcc env fun (valArgCount args > 0) - - -- Hack for build, fold, runST - args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args - | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args - | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args - | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args - -- (foldr k z xs) may call k many times, but it never - -- shares a partial application of k; hence [False,True] - -- This means we can optimise - -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs - -- by floating in the v - - | otherwise = occAnalArgs env args - - -occAnalApp env (fun, args) is_rhs - = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') -> - -- The addAppCtxt is a bit cunning. One iteration of the simplifier - -- often leaves behind beta redexs like - -- (\x y -> e) a1 a2 - -- Here we would like to mark x,y as one-shot, and treat the whole - -- thing much like a let. We do this by pushing some True items - -- onto the context stack. - - case occAnalArgs env args of { (args_uds, args') -> + is_pap = isDataConWorkId fun || valArgCount args < idArity fun + + -- Hack for build, fold, runST + args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args + | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args + | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args + | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args + -- (foldr k z xs) may call k many times, but it never + -- shares a partial application of k; hence [False,True] + -- This means we can optimise + -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs + -- by floating in the v + + | otherwise = occAnalArgs env args + + +occAnalApp env (fun, args) + = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') -> + -- The addAppCtxt is a bit cunning. One iteration of the simplifier + -- often leaves behind beta redexs like + -- (\x y -> e) a1 a2 + -- Here we would like to mark x,y as one-shot, and treat the whole + -- thing much like a let. We do this by pushing some True items + -- onto the context stack. + + case occAnalArgs env args of { (args_uds, args') -> let - final_uds = fun_uds `combineUsageDetails` args_uds + final_uds = fun_uds +++ args_uds in (final_uds, mkApps fun' args') }} - -appSpecial :: OccEnv - -> Int -> CtxtTy -- Argument number, and context to use for it - -> [CoreExpr] - -> (UsageDetails, [CoreExpr]) + + +markRhsUds :: OccEnv -- Check if this is a RhsEnv + -> Bool -- and this is true + -> UsageDetails -- The do markMany on this + -> UsageDetails +-- We mark the free vars of the argument of a constructor or PAP +-- as "many", if it is the RHS of a let(rec). +-- This means that nothing gets inlined into a constructor argument +-- position, which is what we want. Typically those constructor +-- arguments are just variables, or trivial expressions. +-- +-- This is the *whole point* of the isRhsEnv predicate +markRhsUds env is_pap arg_uds + | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds + | otherwise = arg_uds + + +appSpecial :: OccEnv + -> Int -> CtxtTy -- Argument number, and context to use for it + -> [CoreExpr] + -> (UsageDetails, [CoreExpr]) appSpecial env n ctxt args = go n args where arg_env = vanillaCtxt - go n [] = (emptyDetails, []) -- Too few args + go _ [] = (emptyDetails, []) -- Too few args + + go 1 (arg:args) -- The magic arg + = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') -> + case occAnalArgs env args of { (args_uds, args') -> + (arg_uds +++ args_uds, arg':args') }} - go 1 (arg:args) -- The magic arg - = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') -> - case occAnalArgs env args of { (args_uds, args') -> - (combineUsageDetails arg_uds args_uds, arg':args') }} - go n (arg:args) - = case occAnal arg_env arg of { (arg_uds, arg') -> - case go (n-1) args of { (args_uds, args') -> - (combineUsageDetails arg_uds args_uds, arg':args') }} + = case occAnal arg_env arg of { (arg_uds, arg') -> + case go (n-1) args of { (args_uds, args') -> + (arg_uds +++ args_uds, arg':args') }} \end{code} - + Case alternatives ~~~~~~~~~~~~~~~~~ -If the case binder occurs at all, the other binders effectively do too. +If the case binder occurs at all, the other binders effectively do too. For example - case e of x { (a,b) -> rhs } + case e of x { (a,b) -> rhs } is rather like - let x = (a,b) in rhs + let x = (a,b) in rhs If e turns out to be (e1,e2) we indeed get something like - let a = e1; b = e2; x = (a,b) in rhs + let a = e1; b = e2; x = (a,b) in rhs Note [Aug 06]: I don't think this is necessary any more, and it helpe - to know when binders are unused. See esp the call to - isDeadBinder in Simplify.mkDupableAlt + to know when binders are unused. See esp the call to + isDeadBinder in Simplify.mkDupableAlt \begin{code} -occAnalAlt env case_bndr (con, bndrs, rhs) +occAnalAlt :: OccEnv + -> CoreBndr + -> CoreAlt + -> (UsageDetails, Alt IdWithOccInfo) +occAnalAlt env _case_bndr (con, bndrs, rhs) = case occAnal env rhs of { (rhs_usage, rhs') -> let (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs - final_bndrs = tagged_bndrs -- See Note [Aug06] above + final_bndrs = tagged_bndrs -- See Note [Aug06] above {- - final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs - | otherwise = tagged_bndrs - -- Leave the binders untagged if the case - -- binder occurs at all; see note above + final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs + | otherwise = tagged_bndrs + -- Leave the binders untagged if the case + -- binder occurs at all; see note above -} in (final_usage, (con, final_bndrs, rhs')) } @@ -674,92 +930,97 @@ occAnalAlt env case_bndr (con, bndrs, rhs) %************************************************************************ -%* * +%* * \subsection[OccurAnal-types]{OccEnv} -%* * +%* * %************************************************************************ \begin{code} data OccEnv - = OccEnv OccEncl -- Enclosing context information - CtxtTy -- Tells about linearity + = OccEnv OccEncl -- Enclosing context information + CtxtTy -- Tells about linearity -- OccEncl is used to control whether to inline into constructor arguments -- For example: --- x = (p,q) -- Don't inline p or q --- y = /\a -> (p a, q a) -- Still don't inline p or q --- z = f (p,q) -- Do inline p,q; it may make a rule fire +-- x = (p,q) -- Don't inline p or q +-- y = /\a -> (p a, q a) -- Still don't inline p or q +-- z = f (p,q) -- Do inline p,q; it may make a rule fire -- So OccEncl tells enought about the context to know what to do when -- we encounter a contructor application or PAP. data OccEncl - = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda - -- Don't inline into constructor args here - | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. - -- Do inline into constructor args here + = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda + -- Don't inline into constructor args here + | OccVanilla -- Argument of function, body of lambda, scruintee of case etc. + -- Do inline into constructor args here type CtxtTy = [Bool] - -- [] No info - -- - -- True:ctxt Analysing a function-valued expression that will be - -- applied just once - -- - -- False:ctxt Analysing a function-valued expression that may - -- be applied many times; but when it is, - -- the CtxtTy inside applies + -- [] No info + -- + -- True:ctxt Analysing a function-valued expression that will be + -- applied just once + -- + -- False:ctxt Analysing a function-valued expression that may + -- be applied many times; but when it is, + -- the CtxtTy inside applies initOccEnv :: OccEnv initOccEnv = OccEnv OccRhs [] +vanillaCtxt :: OccEnv vanillaCtxt = OccEnv OccVanilla [] + +rhsCtxt :: OccEnv rhsCtxt = OccEnv OccRhs [] +isRhsEnv :: OccEnv -> Bool isRhsEnv (OccEnv OccRhs _) = True isRhsEnv (OccEnv OccVanilla _) = False setVanillaCtxt :: OccEnv -> OccEnv setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty -setVanillaCtxt other_env = other_env +setVanillaCtxt other_env = other_env setCtxt :: OccEnv -> CtxtTy -> OccEnv setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr] - -- The result binders have one-shot-ness set that they might not have had originally. - -- This happens in (build (\cn -> e)). Here the occurrence analyser - -- linearity context knows that c,n are one-shot, and it records that fact in - -- the binder. This is useful to guide subsequent float-in/float-out tranformations + -- The result binders have one-shot-ness set that they might not have had originally. + -- This happens in (build (\cn -> e)). Here the occurrence analyser + -- linearity context knows that c,n are one-shot, and it records that fact in + -- the binder. This is useful to guide subsequent float-in/float-out tranformations -oneShotGroup (OccEnv encl ctxt) bndrs +oneShotGroup (OccEnv _encl ctxt) bndrs = go ctxt bndrs [] where - go ctxt [] rev_bndrs = reverse rev_bndrs + go _ [] rev_bndrs = reverse rev_bndrs go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs - | isId bndr = go ctxt bndrs (bndr':rev_bndrs) - where - bndr' | lin_ctxt = setOneShotLambda bndr - | otherwise = bndr + | isId bndr = go ctxt bndrs (bndr':rev_bndrs) + where + bndr' | lin_ctxt = setOneShotLambda bndr + | otherwise = bndr go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs) -addAppCtxt (OccEnv encl ctxt) args +addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv +addAppCtxt (OccEnv encl ctxt) args = OccEnv encl (replicate (valArgCount args) True ++ ctxt) \end{code} %************************************************************************ -%* * +%* * \subsection[OccurAnal-types]{OccEnv} -%* * +%* * %************************************************************************ \begin{code} -type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage +type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage -combineUsageDetails, combineAltsUsageDetails - :: UsageDetails -> UsageDetails -> UsageDetails +(+++), combineAltsUsageDetails + :: UsageDetails -> UsageDetails -> UsageDetails -combineUsageDetails usage1 usage2 +(+++) usage1 usage2 = plusVarEnv_C addOccInfo usage1 usage2 combineAltsUsageDetails usage1 usage2 @@ -768,17 +1029,20 @@ combineAltsUsageDetails usage1 usage2 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails addOneOcc usage id info = plusVarEnv_C addOccInfo usage (unitVarEnv id info) - -- ToDo: make this more efficient + -- ToDo: make this more efficient +emptyDetails :: UsageDetails emptyDetails = (emptyVarEnv :: UsageDetails) usedIn :: Id -> UsageDetails -> Bool v `usedIn` details = isExportedId v || v `elemVarEnv` details -tagBinders :: UsageDetails -- Of scope - -> [Id] -- Binders - -> (UsageDetails, -- Details with binders removed - [IdWithOccInfo]) -- Tagged binders +type IdWithOccInfo = Id + +tagBinders :: UsageDetails -- Of scope + -> [Id] -- Binders + -> (UsageDetails, -- Details with binders removed + [IdWithOccInfo]) -- Tagged binders tagBinders usage binders = let @@ -787,10 +1051,10 @@ tagBinders usage binders in usage' `seq` (usage', uss) -tagBinder :: UsageDetails -- Of scope - -> Id -- Binders - -> (UsageDetails, -- Details with binders removed - IdWithOccInfo) -- Tagged binders +tagBinder :: UsageDetails -- Of scope + -> Id -- Binders + -> (UsageDetails, -- Details with binders removed + IdWithOccInfo) -- Tagged binders tagBinder usage binder = let @@ -803,12 +1067,12 @@ setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr setBinderOcc usage bndr | isTyVar bndr = bndr | isExportedId bndr = case idOccInfo bndr of - NoOccInfo -> bndr - other -> setIdOccInfo bndr NoOccInfo - -- Don't use local usage info for visible-elsewhere things - -- BUT *do* erase any IAmALoopBreaker annotation, because we're - -- about to re-generate it and it shouldn't be "sticky" - + NoOccInfo -> bndr + _ -> setIdOccInfo bndr NoOccInfo + -- Don't use local usage info for visible-elsewhere things + -- BUT *do* erase any IAmALoopBreaker annotation, because we're + -- about to re-generate it and it shouldn't be "sticky" + | otherwise = setIdOccInfo bndr occ_info where occ_info = lookupVarEnv usage bndr `orElse` IAmDead @@ -816,44 +1080,42 @@ setBinderOcc usage bndr %************************************************************************ -%* * +%* * \subsection{Operations over OccInfo} -%* * +%* * %************************************************************************ \begin{code} mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails -mkOneOcc env id int_cxt +mkOneOcc _env id int_cxt | isLocalId id = unitVarEnv id (OneOcc False True int_cxt) | otherwise = emptyDetails markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo markMany IAmDead = IAmDead -markMany other = NoOccInfo +markMany _ = NoOccInfo markInsideSCC occ = markMany occ markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt -markInsideLam occ = occ +markInsideLam occ = occ addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo addOccInfo IAmDead info2 = info2 addOccInfo info1 IAmDead = info1 -addOccInfo RulesOnly RulesOnly = RulesOnly -addOccInfo info1 info2 = NoOccInfo +addOccInfo _ _ = NoOccInfo -- (orOccInfo orig new) is used -- when combining occurrence info from branches of a case orOccInfo IAmDead info2 = info2 orOccInfo info1 IAmDead = info1 -orOccInfo RulesOnly RulesOnly = RulesOnly -orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1) - (OneOcc in_lam2 one_branch2 int_cxt2) +orOccInfo (OneOcc in_lam1 _ int_cxt1) + (OneOcc in_lam2 _ int_cxt2) = OneOcc (in_lam1 || in_lam2) - False -- False, because it occurs in both branches - (int_cxt1 && int_cxt2) -orOccInfo info1 info2 = NoOccInfo + False -- False, because it occurs in both branches + (int_cxt1 && int_cxt2) +orOccInfo _ _ = NoOccInfo \end{code}