2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 %************************************************************************
6 \section[OccurAnal]{Occurrence analysis pass}
8 %************************************************************************
10 The occurrence analyser re-typechecks a core expression, returning a new
11 core expression with (hopefully) improved usage information.
15 occurAnalysePgm, occurAnalyseExpr
18 #include "HsVersions.h"
22 import CoreUtils ( exprIsTrivial, isDefaultAlt )
23 import Coercion ( mkSymCoercion )
30 import Maybes ( orElse )
31 import Digraph ( SCC(..), stronglyConnCompFromEdgedVerticesR )
32 import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
33 import Unique ( Unique )
34 import UniqFM ( keysUFM, intersectUFM_C, foldUFM_Directly )
35 import Util ( mapAndUnzip )
42 %************************************************************************
44 \subsection[OccurAnal-main]{Counting occurrences: main function}
46 %************************************************************************
48 Here's the externally-callable interface:
51 occurAnalysePgm :: [CoreBind] -> [CoreBind]
53 = snd (go initOccEnv binds)
55 go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
59 = (final_usage, bind' ++ binds')
61 (bs_usage, binds') = go env binds
62 (final_usage, bind') = occAnalBind env bind bs_usage
64 occurAnalyseExpr :: CoreExpr -> CoreExpr
65 -- Do occurrence analysis, and discard occurence info returned
66 occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
70 %************************************************************************
72 \subsection[OccurAnal-main]{Counting occurrences: main function}
74 %************************************************************************
82 -> UsageDetails -- Usage details of scope
83 -> (UsageDetails, -- Of the whole let(rec)
86 occAnalBind env (NonRec binder rhs) body_usage
87 | isTyVar binder -- A type let; we don't gather usage info
88 = (body_usage, [NonRec binder rhs])
90 | not (binder `usedIn` body_usage) -- It's not mentioned
93 | otherwise -- It's mentioned in the body
94 = (body_usage' +++ addRuleUsage rhs_usage binder, -- Note [Rules are extra RHSs]
95 [NonRec tagged_binder rhs'])
97 (body_usage', tagged_binder) = tagBinder body_usage binder
98 (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
103 Dropping dead code for recursive bindings is done in a very simple way:
105 the entire set of bindings is dropped if none of its binders are
106 mentioned in its body; otherwise none are.
108 This seems to miss an obvious improvement.
120 Now 'f' is unused! But it's OK! Dependency analysis will sort this
121 out into a letrec for 'g' and a 'let' for 'f', and then 'f' will get
122 dropped. It isn't easy to do a perfect job in one blow. Consider
133 Note [Loop breaking and RULES]
134 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
135 Loop breaking is surprisingly subtle. First read the section 4 of
136 "Secrets of the GHC inliner". This describes our basic plan.
138 However things are made quite a bit more complicated by RULES. Remember
140 * Note [Rules are extra RHSs]
141 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
142 A RULE for 'f' is like an extra RHS for 'f'. That way the "parent"
143 keeps the specialised "children" alive. If the parent dies
144 (because it isn't referenced any more), then the children will die
145 too (unless they are already referenced directly).
147 To that end, we build a Rec group for each cyclic strongly
149 *treating f's rules as extra RHSs for 'f'*.
151 When we make the Rec groups we include variables free in *either*
152 LHS *or* RHS of the rule. The former might seems silly, but see
153 Note [Rule dependency info].
155 So in Example [eftInt], eftInt and eftIntFB will be put in the
156 same Rec, even though their 'main' RHSs are both non-recursive.
158 * Note [Rules are visible in their own rec group]
159 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
160 We want the rules for 'f' to be visible in f's right-hand side.
161 And we'd like them to be visible in other functions in f's Rec
162 group. E.g. in Example [Specialisation rules] we want f' rule
163 to be visible in both f's RHS, and fs's RHS.
165 This means that we must simplify the RULEs first, before looking
166 at any of the definitions. This is done by Simplify.simplRecBind,
167 when it calls addLetIdInfo.
169 * Note [Choosing loop breakers]
170 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
171 We avoid infinite inlinings by choosing loop breakers, and
172 ensuring that a loop breaker cuts each loop. But what is a
173 "loop"? In particular, a RULE is like an equation for 'f' that
174 is *always* inlined if it is applicable. We do *not* disable
175 rules for loop-breakers. It's up to whoever makes the rules to
176 make sure that the rules themselves alwasys terminate. See Note
177 [Rules for recursive functions] in Simplify.lhs
180 f's RHS mentions g, and
181 g has a RULE that mentions h, and
182 h has a RULE that mentions f
184 then we *must* choose f to be a loop breaker. In general, take the
185 free variables of f's RHS, and augment it with all the variables
186 reachable by RULES from those starting points. That is the whole
187 reason for computing rule_fv_env in occAnalBind. (Of course we
188 only consider free vars that are also binders in this Rec group.)
190 Note that when we compute this rule_fv_env, we only consider variables
191 free in the *RHS* of the rule, in contrast to the way we build the
192 Rec group in the first place (Note [Rule dependency info])
194 Note that in Example [eftInt], *neither* eftInt *nor* eftIntFB is
195 chosen as a loop breaker, because their RHSs don't mention each other.
196 And indeed both can be inlined safely.
198 Note that the edges of the graph we use for computing loop breakers
199 are not the same as the edges we use for computing the Rec blocks.
200 That's why we compute
201 rec_edges for the Rec block analysis
202 loop_breaker_edges for the loop breaker analysis
205 * Note [Weak loop breakers]
206 ~~~~~~~~~~~~~~~~~~~~~~~~~
207 There is a last nasty wrinkle. Suppose we have
217 Remmber that we simplify the RULES before any RHS (see Note
218 [Rules are visible in their own rec group] above).
220 So we must *not* postInlineUnconditionally 'g', even though
221 its RHS turns out to be trivial. (I'm assuming that 'g' is
222 not choosen as a loop breaker.)
224 We "solve" this by making g a "weak" or "rules-only" loop breaker,
225 with OccInfo = IAmLoopBreaker True. A normal "strong" loop breaker
226 has IAmLoopBreaker False. So
228 Inline postInlineUnconditinoally
229 IAmLoopBreaker False no no
230 IAmLoopBreaker True yes no
233 The **sole** reason for this kind of loop breaker is so that
234 postInlineUnconditionally does not fire. Ugh.
236 * Note [Rule dependency info]
237 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
238 The VarSet in a SpecInfo is used for dependency analysis in the
239 occurrence analyser. We must track free vars in *both* lhs and rhs.
240 Hence use of idRuleVars, rather than idRuleRhsVars in addRuleUsage.
244 Then if we substitute y for x, we'd better do so in the
245 rule's LHS too, so we'd better ensure the dependency is respected
250 Example (from GHC.Enum):
252 eftInt :: Int# -> Int# -> [Int]
253 eftInt x y = ...(non-recursive)...
255 {-# INLINE [0] eftIntFB #-}
256 eftIntFB :: (Int -> r -> r) -> r -> Int# -> Int# -> r
257 eftIntFB c n x y = ...(non-recursive)...
260 "eftInt" [~1] forall x y. eftInt x y = build (\ c n -> eftIntFB c n x y)
261 "eftIntList" [1] eftIntFB (:) [] = eftInt
264 Example [Specialisation rules]
265 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
266 Consider this group, which is typical of what SpecConstr builds:
268 fs a = ....f (C a)....
269 f x = ....f (C a)....
270 {-# RULE f (C a) = fs a #-}
272 So 'f' and 'fs' are in the same Rec group (since f refers to fs via its RULE).
274 But watch out! If 'fs' is not chosen as a loop breaker, we may get an infinite loop:
275 - the RULE is applied in f's RHS (see Note [Self-recursive rules] in Simplify
276 - fs is inlined (say it's small)
277 - now there's another opportunity to apply the RULE
279 This showed up when compiling Control.Concurrent.Chan.getChanContents.
283 occAnalBind env (Rec pairs) body_usage
284 = foldr occAnalRec (body_usage, []) sccs
285 -- For a recursive group, we
286 -- * occ-analyse all the RHSs
287 -- * compute strongly-connected components
288 -- * feed those components to occAnalRec
290 -------------Dependency analysis ------------------------------
291 bndr_set = mkVarSet (map fst pairs)
293 sccs :: [SCC (Node Details)]
294 sccs = {-# SCC "occAnalBind.scc" #-} stronglyConnCompFromEdgedVerticesR rec_edges
296 rec_edges :: [Node Details]
297 rec_edges = {-# SCC "occAnalBind.assoc" #-} map make_node pairs
299 make_node (bndr, rhs)
300 = (ND bndr rhs' rhs_usage rhs_fvs, idUnique bndr, out_edges)
302 (rhs_usage, rhs') = occAnalRhs env bndr rhs
303 rhs_fvs = intersectUFM_C (\b _ -> b) bndr_set rhs_usage
304 out_edges = keysUFM (rhs_fvs `unionVarSet` idRuleVars bndr)
305 -- (a -> b) means a mentions b
306 -- Given the usage details (a UFM that gives occ info for each free var of
307 -- the RHS) we can get the list of free vars -- or rather their Int keys --
308 -- by just extracting the keys from the finite map. Grimy, but fast.
309 -- Previously we had this:
310 -- [ bndr | bndr <- bndrs,
311 -- maybeToBool (lookupVarEnv rhs_usage bndr)]
312 -- which has n**2 cost, and this meant that edges_from alone
313 -- consumed 10% of total runtime!
315 -----------------------------
316 occAnalRec :: SCC (Node Details) -> (UsageDetails, [CoreBind])
317 -> (UsageDetails, [CoreBind])
319 -- The NonRec case is just like a Let (NonRec ...) above
320 occAnalRec (AcyclicSCC (ND bndr rhs rhs_usage _, _, _)) (body_usage, binds)
321 | not (bndr `usedIn` body_usage)
322 = (body_usage, binds)
324 | otherwise -- It's mentioned in the body
325 = (body_usage' +++ addRuleUsage rhs_usage bndr, -- Note [Rules are extra RHSs]
326 NonRec tagged_bndr rhs : binds)
328 (body_usage', tagged_bndr) = tagBinder body_usage bndr
331 -- The Rec case is the interesting one
332 -- See Note [Loop breaking]
333 occAnalRec (CyclicSCC nodes) (body_usage, binds)
334 | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
335 = (body_usage, binds) -- Dead code
337 | otherwise -- At this point we always build a single Rec
338 = (final_usage, Rec pairs : binds)
341 bndrs = [b | (ND b _ _ _, _, _) <- nodes]
342 bndr_set = mkVarSet bndrs
344 ----------------------------
345 -- Tag the binders with their occurrence info
346 total_usage = foldl add_usage body_usage nodes
347 add_usage body_usage (ND bndr _ rhs_usage _, _, _)
348 = body_usage +++ addRuleUsage rhs_usage bndr
349 (final_usage, tagged_nodes) = mapAccumL tag_node total_usage nodes
351 tag_node :: UsageDetails -> Node Details -> (UsageDetails, Node Details)
352 -- (a) Tag the binders in the details with occ info
353 -- (b) Mark the binder with "weak loop-breaker" OccInfo
354 -- saying "no preInlineUnconditionally" if it is used
355 -- in any rule (lhs or rhs) of the recursive group
356 -- See Note [Weak loop breakers]
357 tag_node usage (ND bndr rhs rhs_usage rhs_fvs, k, ks)
358 = (usage `delVarEnv` bndr, (ND bndr2 rhs rhs_usage rhs_fvs, k, ks))
360 bndr2 | bndr `elemVarSet` all_rule_fvs = makeLoopBreaker True bndr1
362 bndr1 = setBinderOcc usage bndr
363 all_rule_fvs = bndr_set `intersectVarSet` foldr (unionVarSet . idRuleVars)
366 ----------------------------
367 -- Now reconstruct the cycle
368 pairs | no_rules = reOrderCycle tagged_nodes
369 | otherwise = concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR loop_breaker_edges)
371 -- See Note [Choosing loop breakers] for looop_breaker_edges
372 loop_breaker_edges = map mk_node tagged_nodes
373 mk_node (details@(ND _ _ _ rhs_fvs), k, _) = (details, k, new_ks)
375 new_ks = keysUFM (extendFvs rule_fv_env rhs_fvs rhs_fvs)
377 ------------------------------------
378 rule_fv_env :: IdEnv IdSet -- Variables from this group mentioned in RHS of rules
379 -- Domain is *subset* of bound vars (others have no rule fvs)
380 rule_fv_env = rule_loop init_rule_fvs
382 no_rules = null init_rule_fvs
383 init_rule_fvs = [(b, rule_fvs)
385 , let rule_fvs = idRuleRhsVars b `intersectVarSet` bndr_set
386 , not (isEmptyVarSet rule_fvs)]
388 rule_loop :: [(Id,IdSet)] -> IdEnv IdSet -- Finds fixpoint
391 | otherwise = rule_loop new_fv_list
393 env = mkVarEnv init_rule_fvs
394 (no_change, new_fv_list) = mapAccumL bump True fv_list
395 bump no_change (b,fvs)
396 | new_fvs `subVarSet` fvs = (no_change, (b,fvs))
397 | otherwise = (False, (b,new_fvs `unionVarSet` fvs))
399 new_fvs = extendFvs env emptyVarSet fvs
401 extendFvs :: IdEnv IdSet -> IdSet -> IdSet -> IdSet
402 -- (extendFVs env fvs s) returns (fvs `union` env(s))
403 extendFvs env fvs id_set
404 = foldUFM_Directly add fvs id_set
407 = case lookupVarEnv_Directly env uniq of
408 Just fvs' -> fvs' `unionVarSet` fvs
412 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
413 strongly connected component (there's guaranteed to be a cycle). It returns the
415 a) in a better order,
416 b) with some of the Ids having a IAmALoopBreaker pragma
418 The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
419 that the simplifier can guarantee not to loop provided it never records an inlining
420 for these no-inline guys.
422 Furthermore, the order of the binds is such that if we neglect dependencies
423 on the no-inline Ids then the binds are topologically sorted. This means
424 that the simplifier will generally do a good job if it works from top bottom,
425 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
428 [June 98: I don't understand the following paragraphs, and I've
429 changed the a=b case again so that it isn't a special case any more.]
431 Here's a case that bit me:
439 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
441 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
442 Perhaps something cleverer would suffice.
447 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
448 -- which is gotten from the Id.
449 data Details = ND Id -- Binder
451 UsageDetails -- Full usage from RHS (*not* including rules)
452 IdSet -- Other binders from this Rec group mentioned on RHS
453 -- (derivable from UsageDetails but cached here)
455 reOrderRec :: SCC (Node Details)
457 -- Sorted into a plausible order. Enough of the Ids have
458 -- IAmALoopBreaker pragmas that there are no loops left.
459 reOrderRec (AcyclicSCC (ND bndr rhs _ _, _, _)) = [(bndr, rhs)]
460 reOrderRec (CyclicSCC cycle) = reOrderCycle cycle
462 reOrderCycle :: [Node Details] -> [(Id,CoreExpr)]
464 = panic "reOrderCycle"
465 reOrderCycle [bind] -- Common case of simple self-recursion
466 = [(makeLoopBreaker False bndr, rhs)]
468 (ND bndr rhs _ _, _, _) = bind
470 reOrderCycle (bind : binds)
471 = -- Choose a loop breaker, mark it no-inline,
472 -- do SCC analysis on the rest, and recursively sort them out
473 concatMap reOrderRec (stronglyConnCompFromEdgedVerticesR unchosen) ++
474 [(makeLoopBreaker False bndr, rhs)]
477 (chosen_bind, unchosen) = choose_loop_breaker bind (score bind) [] binds
478 ND bndr rhs _ _ = chosen_bind
480 -- This loop looks for the bind with the lowest score
481 -- to pick as the loop breaker. The rest accumulate in
482 choose_loop_breaker (details,_,_) _loop_sc acc []
483 = (details, acc) -- Done
485 choose_loop_breaker loop_bind loop_sc acc (bind : binds)
486 | sc < loop_sc -- Lower score so pick this new one
487 = choose_loop_breaker bind sc (loop_bind : acc) binds
489 | otherwise -- No lower so don't pick it
490 = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
494 score :: Node Details -> Int -- Higher score => less likely to be picked as loop breaker
495 score (ND bndr rhs _ _, _, _)
496 | isInlineRule (idUnfolding bndr) = 10
497 -- Note [INLINE pragmas]
499 | exprIsTrivial rhs = 5 -- Practically certain to be inlined
500 -- Used to have also: && not (isExportedId bndr)
501 -- But I found this sometimes cost an extra iteration when we have
502 -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
503 -- where df is the exported dictionary. Then df makes a really
504 -- bad choice for loop breaker
506 | is_con_app rhs = 3 -- Data types help with cases
507 -- Note [Constructor applictions]
509 -- If an Id is marked "never inline" then it makes a great loop breaker
510 -- The only reason for not checking that here is that it is rare
511 -- and I've never seen a situation where it makes a difference,
512 -- so it probably isn't worth the time to test on every binder
513 -- | isNeverActive (idInlinePragma bndr) = -10
515 | isOneOcc (idOccInfo bndr) = 1 -- Likely to be inlined
517 | canUnfold (idUnfolding bndr) = 1
518 -- the Id has some kind of unfolding
522 -- Checking for a constructor application
523 -- Cheap and cheerful; the simplifer moves casts out of the way
524 -- The lambda case is important to spot x = /\a. C (f a)
525 -- which comes up when C is a dictionary constructor and
526 -- f is a default method.
527 -- Example: the instance for Show (ST s a) in GHC.ST
529 -- However we *also* treat (\x. C p q) as a con-app-like thing,
530 -- Note [Closure conversion]
531 is_con_app (Var v) = isDataConWorkId v
532 is_con_app (App f _) = is_con_app f
533 is_con_app (Lam _ e) = is_con_app e
534 is_con_app (Note _ e) = is_con_app e
537 makeLoopBreaker :: Bool -> Id -> Id
538 -- Set the loop-breaker flag: see Note [Weak loop breakers]
539 makeLoopBreaker weak bndr = setIdOccInfo bndr (IAmALoopBreaker weak)
542 Note [INLINE pragmas]
543 ~~~~~~~~~~~~~~~~~~~~~
544 Never choose a function with an INLINE pramga as the loop breaker!
545 If such a function is mutually-recursive with a non-INLINE thing,
546 then the latter should be the loop-breaker.
548 A particular case is wrappers generated by the demand analyser.
549 If you make then into a loop breaker you may get an infinite
550 inlining loop. For example:
552 $wfoo x = ....foo x....
554 {-loop brk-} foo x = ...$wfoo x...
556 The interface file sees the unfolding for $wfoo, and sees that foo is
557 strict (and hence it gets an auto-generated wrapper). Result: an
558 infinite inlining in the importing scope. So be a bit careful if you
559 change this. A good example is Tree.repTree in
560 nofib/spectral/minimax. If the repTree wrapper is chosen as the loop
561 breaker then compiling Game.hs goes into an infinite loop (this
562 happened when we gave is_con_app a lower score than inline candidates).
564 Note [Constructor applications]
565 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
566 It's really really important to inline dictionaries. Real
567 example (the Enum Ordering instance from GHC.Base):
569 rec f = \ x -> case d of (p,q,r) -> p x
570 g = \ x -> case d of (p,q,r) -> q x
573 Here, f and g occur just once; but we can't inline them into d.
574 On the other hand we *could* simplify those case expressions if
575 we didn't stupidly choose d as the loop breaker.
576 But we won't because constructor args are marked "Many".
577 Inlining dictionaries is really essential to unravelling
578 the loops in static numeric dictionaries, see GHC.Float.
580 Note [Closure conversion]
581 ~~~~~~~~~~~~~~~~~~~~~~~~~
582 We treat (\x. C p q) as a high-score candidate in the letrec scoring algorithm.
583 The immediate motivation came from the result of a closure-conversion transformation
584 which generated code like this:
586 data Clo a b = forall c. Clo (c -> a -> b) c
588 ($:) :: Clo a b -> a -> b
589 Clo f env $: x = f env x
591 rec { plus = Clo plus1 ()
593 ; plus1 _ n = Clo plus2 n
596 ; plus2 (Succ m) n = Succ (plus $: m $: n) }
598 If we inline 'plus' and 'plus1', everything unravels nicely. But if
599 we choose 'plus1' as the loop breaker (which is entirely possible
600 otherwise), the loop does not unravel nicely.
603 @occAnalRhs@ deals with the question of bindings where the Id is marked
604 by an INLINE pragma. For these we record that anything which occurs
605 in its RHS occurs many times. This pessimistically assumes that ths
606 inlined binder also occurs many times in its scope, but if it doesn't
607 we'll catch it next time round. At worst this costs an extra simplifier pass.
608 ToDo: try using the occurrence info for the inline'd binder.
610 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
611 [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
616 -> Id -> CoreExpr -- Binder and rhs
617 -- For non-recs the binder is alrady tagged
618 -- with occurrence info
619 -> (UsageDetails, CoreExpr)
621 occAnalRhs env id rhs
624 ctxt | certainly_inline id = env
625 | otherwise = rhsCtxt env
626 -- Note that we generally use an rhsCtxt. This tells the occ anal n
627 -- that it's looking at an RHS, which has an effect in occAnalApp
629 -- But there's a problem. Consider
634 -- First time round, it looks as if x1 and x2 occur as an arg of a
635 -- let-bound constructor ==> give them a many-occurrence.
636 -- But then x3 is inlined (unconditionally as it happens) and
637 -- next time round, x2 will be, and the next time round x1 will be
638 -- Result: multiple simplifier iterations. Sigh.
639 -- Crude solution: use rhsCtxt for things that occur just once...
641 certainly_inline id = case idOccInfo id of
642 OneOcc in_lam one_br _ -> not in_lam && one_br
649 addRuleUsage :: UsageDetails -> Id -> UsageDetails
650 -- Add the usage from RULES in Id to the usage
651 addRuleUsage usage id
652 = foldVarSet add usage (idRuleVars id)
653 -- idRuleVars here: see Note [Rule dependency info]
655 add v u = addOneOcc u v NoOccInfo
656 -- Give a non-committal binder info (i.e manyOcc) because
657 -- a) Many copies of the specialised thing can appear
658 -- b) We don't want to substitute a BIG expression inside a RULE
659 -- even if that's the only occurrence of the thing
660 -- (Same goes for INLINE.)
668 -> (UsageDetails, -- Gives info only about the "interesting" Ids
671 occAnal _ (Type t) = (emptyDetails, Type t)
672 occAnal env (Var v) = (mkOneOcc env v False, Var v)
673 -- At one stage, I gathered the idRuleVars for v here too,
674 -- which in a way is the right thing to do.
675 -- But that went wrong right after specialisation, when
676 -- the *occurrences* of the overloaded function didn't have any
677 -- rules in them, so the *specialised* versions looked as if they
678 -- weren't used at all.
681 We regard variables that occur as constructor arguments as "dangerousToDup":
685 f x = let y = expensive x in
687 (case z of {(p,q)->q}, case z of {(p,q)->q})
690 We feel free to duplicate the WHNF (True,y), but that means
691 that y may be duplicated thereby.
693 If we aren't careful we duplicate the (expensive x) call!
694 Constructors are rather like lambdas in this way.
697 occAnal _ expr@(Lit _) = (emptyDetails, expr)
701 occAnal env (Note note@(SCC _) body)
702 = case occAnal env body of { (usage, body') ->
703 (mapVarEnv markInsideSCC usage, Note note body')
706 occAnal env (Note note body)
707 = case occAnal env body of { (usage, body') ->
708 (usage, Note note body')
711 occAnal env (Cast expr co)
712 = case occAnal env expr of { (usage, expr') ->
713 (markRhsUds env True usage, Cast expr' co)
714 -- If we see let x = y `cast` co
715 -- then mark y as 'Many' so that we don't
716 -- immediately inline y again.
721 occAnal env app@(App _ _)
722 = occAnalApp env (collectArgs app)
724 -- Ignore type variables altogether
725 -- (a) occurrences inside type lambdas only not marked as InsideLam
726 -- (b) type variables not in environment
728 occAnal env (Lam x body) | isTyVar x
729 = case occAnal env body of { (body_usage, body') ->
730 (body_usage, Lam x body')
733 -- For value lambdas we do a special hack. Consider
735 -- If we did nothing, x is used inside the \y, so would be marked
736 -- as dangerous to dup. But in the common case where the abstraction
737 -- is applied to two arguments this is over-pessimistic.
738 -- So instead, we just mark each binder with its occurrence
739 -- info in the *body* of the multiple lambda.
740 -- Then, the simplifier is careful when partially applying lambdas.
742 occAnal env expr@(Lam _ _)
743 = case occAnal env_body body of { (body_usage, body') ->
745 (final_usage, tagged_binders) = tagBinders body_usage binders
746 -- URGH! Sept 99: we don't seem to be able to use binders' here, because
747 -- we get linear-typed things in the resulting program that we can't handle yet.
748 -- (e.g. PrelShow) TODO
750 really_final_usage = if linear then
753 mapVarEnv markInsideLam final_usage
756 mkLams tagged_binders body') }
758 env_body = vanillaCtxt env -- Body is (no longer) an RhsContext
759 (binders, body) = collectBinders expr
760 binders' = oneShotGroup env binders
761 linear = all is_one_shot binders'
762 is_one_shot b = isId b && isOneShotBndr b
764 occAnal env (Case scrut bndr ty alts)
765 = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
766 case mapAndUnzip occ_anal_alt alts of { (alts_usage_s, alts') ->
768 alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
769 alts_usage' = addCaseBndrUsage alts_usage
770 (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
771 total_usage = scrut_usage +++ alts_usage1
773 total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
775 -- Note [Case binder usage]
776 -- ~~~~~~~~~~~~~~~~~~~~~~~~
777 -- The case binder gets a usage of either "many" or "dead", never "one".
778 -- Reason: we like to inline single occurrences, to eliminate a binding,
779 -- but inlining a case binder *doesn't* eliminate a binding.
780 -- We *don't* want to transform
781 -- case x of w { (p,q) -> f w }
783 -- case x of w { (p,q) -> f (p,q) }
784 addCaseBndrUsage usage = case lookupVarEnv usage bndr of
786 Just _ -> extendVarEnv usage bndr NoOccInfo
788 alt_env = mkAltEnv env bndr_swap
789 -- Consider x = case v of { True -> (p,q); ... }
790 -- Then it's fine to inline p and q
792 bndr_swap = case scrut of
793 Var v -> Just (v, Var bndr)
794 Cast (Var v) co -> Just (v, Cast (Var bndr) (mkSymCoercion co))
797 occ_anal_alt = occAnalAlt alt_env bndr bndr_swap
799 occ_anal_scrut (Var v) (alt1 : other_alts)
800 | not (null other_alts) || not (isDefaultAlt alt1)
801 = (mkOneOcc env v True, Var v) -- The 'True' says that the variable occurs
802 -- in an interesting context; the case has
803 -- at least one non-default alternative
804 occ_anal_scrut scrut _alts
805 = occAnal (vanillaCtxt env) scrut -- No need for rhsCtxt
807 occAnal env (Let bind body)
808 = case occAnal env body of { (body_usage, body') ->
809 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
810 (final_usage, mkLets new_binds body') }}
812 occAnalArgs :: OccEnv -> [CoreExpr] -> (UsageDetails, [CoreExpr])
814 = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
815 (foldr (+++) emptyDetails arg_uds_s, args')}
817 arg_env = vanillaCtxt env
820 Applications are dealt with specially because we want
821 the "build hack" to work.
825 -> (Expr CoreBndr, [Arg CoreBndr])
826 -> (UsageDetails, Expr CoreBndr)
827 occAnalApp env (Var fun, args)
828 = case args_stuff of { (args_uds, args') ->
830 final_args_uds = markRhsUds env is_pap args_uds
832 (fun_uds +++ final_args_uds, mkApps (Var fun) args') }
834 fun_uniq = idUnique fun
835 fun_uds = mkOneOcc env fun (valArgCount args > 0)
836 is_pap = isDataConWorkId fun || valArgCount args < idArity fun
838 -- Hack for build, fold, runST
839 args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
840 | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
841 | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
842 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
843 -- (foldr k z xs) may call k many times, but it never
844 -- shares a partial application of k; hence [False,True]
845 -- This means we can optimise
846 -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
847 -- by floating in the v
849 | otherwise = occAnalArgs env args
852 occAnalApp env (fun, args)
853 = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
854 -- The addAppCtxt is a bit cunning. One iteration of the simplifier
855 -- often leaves behind beta redexs like
857 -- Here we would like to mark x,y as one-shot, and treat the whole
858 -- thing much like a let. We do this by pushing some True items
859 -- onto the context stack.
861 case occAnalArgs env args of { (args_uds, args') ->
863 final_uds = fun_uds +++ args_uds
865 (final_uds, mkApps fun' args') }}
868 markRhsUds :: OccEnv -- Check if this is a RhsEnv
869 -> Bool -- and this is true
870 -> UsageDetails -- The do markMany on this
872 -- We mark the free vars of the argument of a constructor or PAP
873 -- as "many", if it is the RHS of a let(rec).
874 -- This means that nothing gets inlined into a constructor argument
875 -- position, which is what we want. Typically those constructor
876 -- arguments are just variables, or trivial expressions.
878 -- This is the *whole point* of the isRhsEnv predicate
879 markRhsUds env is_pap arg_uds
880 | isRhsEnv env && is_pap = mapVarEnv markMany arg_uds
881 | otherwise = arg_uds
885 -> Int -> CtxtTy -- Argument number, and context to use for it
887 -> (UsageDetails, [CoreExpr])
888 appSpecial env n ctxt args
891 arg_env = vanillaCtxt env
893 go _ [] = (emptyDetails, []) -- Too few args
895 go 1 (arg:args) -- The magic arg
896 = case occAnal (setCtxtTy arg_env ctxt) arg of { (arg_uds, arg') ->
897 case occAnalArgs env args of { (args_uds, args') ->
898 (arg_uds +++ args_uds, arg':args') }}
901 = case occAnal arg_env arg of { (arg_uds, arg') ->
902 case go (n-1) args of { (args_uds, args') ->
903 (arg_uds +++ args_uds, arg':args') }}
909 We do these two transformations right here:
911 (1) case x of b { pi -> ri }
913 case x of b { pi -> let x=b in ri }
915 (2) case (x |> co) of b { pi -> ri }
917 case (x |> co) of b { pi -> let x = b |> sym co in ri }
919 Why (2)? See Note [Case of cast]
921 In both cases, in a particular alternative (pi -> ri), we only
923 (a) x occurs free in (pi -> ri)
924 (ie it occurs in ri, but is not bound in pi)
925 (b) the pi does not bind b (or the free vars of co)
926 We need (a) and (b) for the inserted binding to be correct.
928 For the alternatives where we inject the binding, we can transfer
929 all x's OccInfo to b. And that is the point.
932 * The deliberate shadowing of 'x'.
933 * That (a) rapidly becomes false, so no bindings are injected.
935 The reason for doing these transformations here is because it allows
936 us to adjust the OccInfo for 'x' and 'b' as we go.
938 * Suppose the only occurrences of 'x' are the scrutinee and in the
939 ri; then this transformation makes it occur just once, and hence
940 get inlined right away.
942 * If we do this in the Simplifier, we don't know whether 'x' is used
943 in ri, so we are forced to pessimistically zap b's OccInfo even
944 though it is typically dead (ie neither it nor x appear in the
945 ri). There's nothing actually wrong with zapping it, except that
946 it's kind of nice to know which variables are dead. My nose
947 tells me to keep this information as robustly as possible.
949 The Maybe (Id,CoreExpr) passed to occAnalAlt is the extra let-binding
950 {x=b}; it's Nothing if the binder-swap doesn't happen.
952 Note [Binder swap on GlobalId scrutinees]
953 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
954 When the scrutinee is a GlobalId we must take care in two ways
956 i) In order to *know* whether 'x' occurs free in the RHS, we need its
957 occurrence info. BUT, we don't gather occurrence info for
958 GlobalIds. That's what the (small) occ_scrut_ids set in OccEnv is
959 for: it says "gather occurrence info for these.
961 ii) We must call localiseId on 'x' first, in case it's a GlobalId, or
962 has an External Name. See, for example, SimplEnv Note [Global Ids in
967 Consider case (x `cast` co) of b { I# ->
968 ... (case (x `cast` co) of {...}) ...
969 We'd like to eliminate the inner case. That is the motivation for
970 equation (2) in Note [Binder swap]. When we get to the inner case, we
971 inline x, cancel the casts, and away we go.
973 Note [Binders in case alternatives]
974 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
976 case x of y { (a,b) -> f y }
977 We treat 'a', 'b' as dead, because they don't physically occur in the
978 case alternative. (Indeed, a variable is dead iff it doesn't occur in
979 its scope in the output of OccAnal.) This invariant is It really
980 helpe to know when binders are unused. See esp the call to
981 isDeadBinder in Simplify.mkDupableAlt
983 In this example, though, the Simplifier will bring 'a' and 'b' back to
984 life, beause it binds 'y' to (a,b) (imagine got inlined and
990 -> Maybe (Id, CoreExpr) -- Note [Binder swap]
992 -> (UsageDetails, Alt IdWithOccInfo)
993 occAnalAlt env case_bndr mb_scrut_var (con, bndrs, rhs)
994 = case occAnal env rhs of { (rhs_usage, rhs') ->
996 (alt_usg, tagged_bndrs) = tagBinders rhs_usage bndrs
997 bndrs' = tagged_bndrs -- See Note [Binders in case alternatives]
1000 Just (scrut_var, scrut_rhs) -- See Note [Binder swap]
1001 | scrut_var `localUsedIn` alt_usg -- (a) Fast path, usually false
1002 , not (any shadowing bndrs) -- (b)
1003 -> (addOneOcc usg_wo_scrut case_bndr NoOccInfo,
1004 -- See Note [Case binder usage] for the NoOccInfo
1005 (con, bndrs', Let (NonRec scrut_var' scrut_rhs) rhs'))
1007 (usg_wo_scrut, scrut_var') = tagBinder alt_usg (localiseId scrut_var)
1008 -- Note the localiseId; we're making a new binding
1009 -- for it, and it might have an External Name, or
1010 -- even be a GlobalId; Note [Binder swap on GlobalId scrutinees]
1011 shadowing bndr = bndr `elemVarSet` rhs_fvs
1012 rhs_fvs = exprFreeVars scrut_rhs
1014 _other -> (alt_usg, (con, bndrs', rhs')) }
1018 %************************************************************************
1020 \subsection[OccurAnal-types]{OccEnv}
1022 %************************************************************************
1026 = OccEnv { occ_encl :: !OccEncl -- Enclosing context information
1027 , occ_ctxt :: !CtxtTy -- Tells about linearity
1028 , occ_scrut_ids :: !GblScrutIds }
1030 type GblScrutIds = IdSet -- GlobalIds that are scrutinised, and for which
1031 -- we want to gather occurence info; see
1032 -- Note [Binder swap for GlobalId scrutinee]
1033 -- No need to prune this if there's a shadowing binding
1034 -- because it's OK for it to be too big
1036 -- OccEncl is used to control whether to inline into constructor arguments
1038 -- x = (p,q) -- Don't inline p or q
1039 -- y = /\a -> (p a, q a) -- Still don't inline p or q
1040 -- z = f (p,q) -- Do inline p,q; it may make a rule fire
1041 -- So OccEncl tells enought about the context to know what to do when
1042 -- we encounter a contructor application or PAP.
1045 = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
1046 -- Don't inline into constructor args here
1047 | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
1048 -- Do inline into constructor args here
1050 type CtxtTy = [Bool]
1053 -- True:ctxt Analysing a function-valued expression that will be
1054 -- applied just once
1056 -- False:ctxt Analysing a function-valued expression that may
1057 -- be applied many times; but when it is,
1058 -- the CtxtTy inside applies
1060 initOccEnv :: OccEnv
1061 initOccEnv = OccEnv { occ_encl = OccRhs
1063 , occ_scrut_ids = emptyVarSet }
1065 vanillaCtxt :: OccEnv -> OccEnv
1066 vanillaCtxt env = OccEnv { occ_encl = OccVanilla, occ_ctxt = []
1067 , occ_scrut_ids = occ_scrut_ids env }
1069 rhsCtxt :: OccEnv -> OccEnv
1070 rhsCtxt env = OccEnv { occ_encl = OccRhs, occ_ctxt = []
1071 , occ_scrut_ids = occ_scrut_ids env }
1073 mkAltEnv :: OccEnv -> Maybe (Id, CoreExpr) -> OccEnv
1074 -- Does two things: a) makes the occ_ctxt = OccVanilla
1075 -- b) extends the scrut_ids if necessary
1076 mkAltEnv env (Just (scrut_id, _))
1077 | not (isLocalId scrut_id)
1078 = OccEnv { occ_encl = OccVanilla
1079 , occ_scrut_ids = extendVarSet (occ_scrut_ids env) scrut_id
1080 , occ_ctxt = occ_ctxt env }
1082 | isRhsEnv env = env { occ_encl = OccVanilla }
1085 setCtxtTy :: OccEnv -> CtxtTy -> OccEnv
1086 setCtxtTy env ctxt = env { occ_ctxt = ctxt }
1088 isRhsEnv :: OccEnv -> Bool
1089 isRhsEnv (OccEnv { occ_encl = OccRhs }) = True
1090 isRhsEnv (OccEnv { occ_encl = OccVanilla }) = False
1092 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
1093 -- The result binders have one-shot-ness set that they might not have had originally.
1094 -- This happens in (build (\cn -> e)). Here the occurrence analyser
1095 -- linearity context knows that c,n are one-shot, and it records that fact in
1096 -- the binder. This is useful to guide subsequent float-in/float-out tranformations
1098 oneShotGroup (OccEnv { occ_ctxt = ctxt }) bndrs
1101 go _ [] rev_bndrs = reverse rev_bndrs
1103 go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
1104 | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
1106 bndr' | lin_ctxt = setOneShotLambda bndr
1109 go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
1111 addAppCtxt :: OccEnv -> [Arg CoreBndr] -> OccEnv
1112 addAppCtxt env@(OccEnv { occ_ctxt = ctxt }) args
1113 = env { occ_ctxt = replicate (valArgCount args) True ++ ctxt }
1116 %************************************************************************
1118 \subsection[OccurAnal-types]{OccEnv}
1120 %************************************************************************
1123 type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
1124 -- INVARIANT: never IAmDead
1125 -- (Deadness is signalled by not being in the map at all)
1127 (+++), combineAltsUsageDetails
1128 :: UsageDetails -> UsageDetails -> UsageDetails
1131 = plusVarEnv_C addOccInfo usage1 usage2
1133 combineAltsUsageDetails usage1 usage2
1134 = plusVarEnv_C orOccInfo usage1 usage2
1136 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
1137 addOneOcc usage id info
1138 = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
1139 -- ToDo: make this more efficient
1141 emptyDetails :: UsageDetails
1142 emptyDetails = (emptyVarEnv :: UsageDetails)
1144 localUsedIn, usedIn :: Id -> UsageDetails -> Bool
1145 v `localUsedIn` details = v `elemVarEnv` details
1146 v `usedIn` details = isExportedId v || v `localUsedIn` details
1148 type IdWithOccInfo = Id
1150 tagBinders :: UsageDetails -- Of scope
1152 -> (UsageDetails, -- Details with binders removed
1153 [IdWithOccInfo]) -- Tagged binders
1155 tagBinders usage binders
1157 usage' = usage `delVarEnvList` binders
1158 uss = map (setBinderOcc usage) binders
1160 usage' `seq` (usage', uss)
1162 tagBinder :: UsageDetails -- Of scope
1164 -> (UsageDetails, -- Details with binders removed
1165 IdWithOccInfo) -- Tagged binders
1167 tagBinder usage binder
1169 usage' = usage `delVarEnv` binder
1170 binder' = setBinderOcc usage binder
1172 usage' `seq` (usage', binder')
1174 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
1175 setBinderOcc usage bndr
1176 | isTyVar bndr = bndr
1177 | isExportedId bndr = case idOccInfo bndr of
1179 _ -> setIdOccInfo bndr NoOccInfo
1180 -- Don't use local usage info for visible-elsewhere things
1181 -- BUT *do* erase any IAmALoopBreaker annotation, because we're
1182 -- about to re-generate it and it shouldn't be "sticky"
1184 | otherwise = setIdOccInfo bndr occ_info
1186 occ_info = lookupVarEnv usage bndr `orElse` IAmDead
1190 %************************************************************************
1192 \subsection{Operations over OccInfo}
1194 %************************************************************************
1197 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
1198 mkOneOcc env id int_cxt
1199 | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
1200 | id `elemVarSet` occ_scrut_ids env = unitVarEnv id NoOccInfo
1201 | otherwise = emptyDetails
1203 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
1205 markMany _ = NoOccInfo
1207 markInsideSCC occ = markMany occ
1209 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
1210 markInsideLam occ = occ
1212 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
1214 addOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )
1215 NoOccInfo -- Both branches are at least One
1216 -- (Argument is never IAmDead)
1218 -- (orOccInfo orig new) is used
1219 -- when combining occurrence info from branches of a case
1221 orOccInfo (OneOcc in_lam1 _ int_cxt1)
1222 (OneOcc in_lam2 _ int_cxt2)
1223 = OneOcc (in_lam1 || in_lam2)
1224 False -- False, because it occurs in both branches
1225 (int_cxt1 && int_cxt2)
1226 orOccInfo a1 a2 = ASSERT( not (isDeadOcc a1 || isDeadOcc a2) )