X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2FsimplCore%2FOccurAnal.lhs;h=ba302ff1410d5fe2aac4d11020cd9ffa5cca8439;hb=ebd091d5cd703b249838baaa125e6c0fa0fe0e45;hp=de16aace195b5ba7995c0c3b88f3ee688923dcc1;hpb=a35f75aa20bf0a329be0b782986c3e12155b4d49;p=ghc-hetmet.git diff --git a/compiler/simplCore/OccurAnal.lhs b/compiler/simplCore/OccurAnal.lhs index de16aac..ba302ff 100644 --- a/compiler/simplCore/OccurAnal.lhs +++ b/compiler/simplCore/OccurAnal.lhs @@ -11,6 +11,13 @@ The occurrence analyser re-typechecks a core expression, returning a new core expression with (hopefully) improved usage information. \begin{code} +{-# OPTIONS -w #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details + module OccurAnal ( occurAnalysePgm, occurAnalyseExpr ) where @@ -20,24 +27,22 @@ module OccurAnal ( import CoreSyn import CoreFVs ( idRuleVars ) import CoreUtils ( exprIsTrivial, isDefaultAlt ) -import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda, - idOccInfo, setIdOccInfo, isLocalId, - isExportedId, idArity, idHasRules, - idType, idUnique, Id - ) +import Id +import IdInfo import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt ) 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 ) -import Util ( zipWithEqual, mapAndUnzip ) +import UniqFM ( keysUFM, intersectsUFM, intersectUFM_C, foldUFM_Directly ) +import Util ( mapAndUnzip ) import Outputable + +import Data.List \end{code} @@ -90,39 +95,36 @@ occAnalBind env (NonRec binder rhs) body_usage = (body_usage, []) | otherwise -- It's mentioned in the body - = (final_body_usage `combineUsageDetails` rhs_usage, + = (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. This seems to miss an obvious improvement. -@ + letrec f = ...g... g = ...f... in ...g... - ===> - letrec f = ...g... g = ...(...g...)... in ...g... -@ -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 +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... @@ -130,29 +132,180 @@ It isn't easy to do a perfect job in one blow. Consider 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'*. + + 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 function 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 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* postInlineUnconditinoally '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 + postInlineUnconditioanlly does not fire. Ugh. + + +Example [eftInt] +~~~~~~~~~~~~~~~ +Example (from GHC.Enum): + + 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 + #-} + +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 + | 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) where - analysed_pairs :: [Details1] - analysed_pairs = [ (bndr, rhs_usage, rhs') - | (bndr, rhs) <- pairs, - let (rhs_usage, rhs') = occAnalRhs env bndr rhs - ] + bndrs = map fst pairs + bndr_set = mkVarSet bndrs - sccs :: [SCC (Node Details1)] - sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges + --------------------------------------- + -- 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 | no_rules = tagged_bndrs + | otherwise = map tag_rule_var tagged_bndrs + tag_rule_var bndr | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr + | otherwise = bndr ---- 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 - ] + 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) + -- (a -> b) means a mentions b -- Given the usage details (a UFM that gives occ info for each free var of @@ -163,58 +316,53 @@ occAnalBind env (Rec pairs) body_usage -- 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) - where - details = [details | (details, _, _) <- cycle] - bndrs = [bndr | (bndr, _, _) <- details] - rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details] - rhs_usage = foldr1 combineUsageDetails rhs_usages - total_usage = rhs_usage `combineUsageDetails` body_usage - (combined_usage, tagged_bndrs) = tagBinders total_usage bndrs - - new_cycle :: [Node Details2] - new_cycle = zipWithEqual "reorder" mk_node tagged_bndrs cycle - final_bind = Rec (reOrderCycle rhs_usage new_cycle) - mk_node tagged_bndr ((_, _, rhs'), key, keys) = ((tagged_bndr, rhs'), key, keys) - -{- An alternative; rebuild the edges. No semantic difference, but perf might change - - -- 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 - keys = map idUnique bndrs - mk_node 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 --} + + ---- 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 [Loop breaking for reason 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) + + + ------------------------------------ + 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 + all_rule_fvs = foldr (unionVarSet . snd) emptyVarSet init_rule_fvs + init_rule_fvs = [(b, rule_fvs) + | b <- bndrs + , let rule_fvs = idRuleVars 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 + +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 @@ -252,36 +400,36 @@ Perhaps something cleverer would suffice. \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) +type Details = (Id, -- Binder + CoreExpr, -- RHS + IdSet) -- RHS free vars (*not* include rules) -reOrderRec :: UsageDetails -> SCC (Node Details2) -> [Details2] +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 rhs_usg (AcyclicSCC (bind, _, _)) = [bind] -reOrderRec rhs_usg (CyclicSCC cycle) = reOrderCycle rhs_usg cycle +reOrderRec (AcyclicSCC ((bndr, rhs, _), _, _)) = [(bndr, rhs)] +reOrderRec (CyclicSCC cycle) = reOrderCycle cycle -reOrderCycle :: UsageDetails -> [Node Details2] -> [Details2] -reOrderCycle rhs_usg [] +reOrderCycle :: [Node Details] -> [(Id,CoreExpr)] +reOrderCycle [] = panic "reOrderCycle" -reOrderCycle rhs_usg [bind] -- Common case of simple self-recursion - = [(makeLoopBreaker rhs_usg tagged_bndr, rhs)] +reOrderCycle [bind] -- Common case of simple self-recursion + = [(makeLoopBreaker False bndr, rhs)] where - ((tagged_bndr, rhs), _, _) = bind + ((bndr, rhs, _), _, _) = bind -reOrderCycle rhs_usg (bind : binds) +reOrderCycle (bind : binds) = -- Choose a loop breaker, mark it no-inline, -- do SCC analysis on the rest, and recursively sort them out - concatMap (reOrderRec rhs_usg) (stronglyConnCompR unchosen) ++ - [(makeLoopBreaker rhs_usg tagged_bndr, rhs)] + concatMap reOrderRec (stronglyConnCompR unchosen) ++ + [(makeLoopBreaker False bndr, rhs)] where - (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds - (tagged_bndr, rhs) = chosen_pair + (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds + (bndr, rhs, _) = chosen_bind -- This loop looks for the bind with the lowest score -- to pick as the loop breaker. The rest accumulate in @@ -297,8 +445,11 @@ reOrderCycle rhs_usg (bind : binds) where sc = score bind - score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker - score ((bndr, rhs), _, _) + score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker + score ((bndr, rhs, _), _, _) + | workerExists (idWorkerInfo bndr) = 10 + -- Note [Worker inline loop] + | 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 @@ -306,16 +457,11 @@ reOrderCycle rhs_usg (bind : binds) -- 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 + | is_con_app rhs = 2 -- Data types help with cases + -- Note [conapp] - | 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 + | inlineCandidate bndr rhs = 1 -- Likely to be inlined + -- Note [Inline candidates] | otherwise = 0 @@ -323,7 +469,11 @@ reOrderCycle rhs_usg (bind : binds) inlineCandidate id (Note InlineMe _) = True inlineCandidate id rhs = isOneOcc (idOccInfo id) - -- Real example (the Enum Ordering instance from PrelBase): + -- 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) @@ -332,19 +482,70 @@ reOrderCycle rhs_usg (bind : binds) -- 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 b e) = is_con_app e + is_con_app (Note _ e) = is_con_app e + is_con_app other = False + +makeLoopBreaker :: Bool -> Id -> Id +-- Set the loop-breaker flag +-- See Note [Weak loop breakers] +makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak) +\end{code} - not_fun_ty ty = not (isFunTy (dropForAlls ty)) +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.... + + {-loop brk-} foo x = ...$wfoo x... + } + +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). + +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. -makeLoopBreaker :: UsageDetails -> Id -> Id --- Set the loop-breaker flag, recording whether the thing occurs only in --- the RHS of a RULE (in this recursive group) -makeLoopBreaker rhs_usg bndr - = setIdOccInfo bndr (IAmALoopBreaker rules_only) - where - rules_only = case lookupVarEnv rhs_usg bndr of - Just RulesOnly -> True - other -> False -\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 @@ -365,9 +566,8 @@ occAnalRhs :: OccEnv -> (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 @@ -388,21 +588,17 @@ occAnalRhs env id rhs certainly_inline id = case idOccInfo id of OneOcc in_lam one_br _ -> not in_lam && one_br other -> 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 + 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} @@ -462,7 +658,10 @@ 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} @@ -517,7 +716,7 @@ occAnal env (Case scrut bndr ty alts) 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 + total_usage = scrut_usage +++ alts_usage1 in total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }} where @@ -549,7 +748,7 @@ occAnal env (Let bind body) occAnalArgs env args = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') -> - (foldr combineUsageDetails emptyDetails arg_uds_s, args')} + (foldr (+++) emptyDetails arg_uds_s, args')} where arg_env = vanillaCtxt \end{code} @@ -561,23 +760,13 @@ the "build hack" to work. occAnalApp env (Var fun, args) is_rhs = 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) + is_pap = isDataConWorkId fun || valArgCount args < idArity fun -- Hack for build, fold, runST args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args @@ -604,10 +793,27 @@ occAnalApp env (fun, args) is_rhs 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') }} + +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] @@ -622,12 +828,12 @@ appSpecial env n ctxt 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') }} + (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') }} + (arg_uds +++ args_uds, arg':args') }} \end{code} @@ -745,10 +951,10 @@ addAppCtxt (OccEnv encl ctxt) args \begin{code} type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage -combineUsageDetails, combineAltsUsageDetails +(+++), combineAltsUsageDetails :: UsageDetails -> UsageDetails -> UsageDetails -combineUsageDetails usage1 usage2 +(+++) usage1 usage2 = plusVarEnv_C addOccInfo usage1 usage2 combineAltsUsageDetails usage1 usage2 @@ -764,6 +970,8 @@ emptyDetails = (emptyVarEnv :: UsageDetails) usedIn :: Id -> UsageDetails -> Bool v `usedIn` details = isExportedId v || v `elemVarEnv` details +type IdWithOccInfo = Id + tagBinders :: UsageDetails -- Of scope -> [Id] -- Binders -> (UsageDetails, -- Details with binders removed @@ -830,7 +1038,6 @@ addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo addOccInfo IAmDead info2 = info2 addOccInfo info1 IAmDead = info1 -addOccInfo RulesOnly RulesOnly = RulesOnly addOccInfo info1 info2 = NoOccInfo -- (orOccInfo orig new) is used @@ -838,7 +1045,6 @@ addOccInfo info1 info2 = NoOccInfo 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) = OneOcc (in_lam1 || in_lam2)