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"
21 import CoreFVs ( idRuleVars )
22 import CoreUtils ( exprIsTrivial, isDefaultAlt )
23 import Id ( isDataConWorkId, isOneShotBndr, setOneShotLambda,
24 idOccInfo, setIdOccInfo, isLocalId,
25 isExportedId, idArity, idHasRules,
28 import BasicTypes ( OccInfo(..), isOneOcc, InterestingCxt )
33 import Type ( isFunTy, dropForAlls )
34 import Maybes ( orElse )
35 import Digraph ( stronglyConnCompR, SCC(..) )
36 import PrelNames ( buildIdKey, foldrIdKey, runSTRepIdKey, augmentIdKey )
37 import Unique ( Unique )
38 import UniqFM ( keysUFM )
39 import Util ( zipWithEqual, mapAndUnzip )
44 %************************************************************************
46 \subsection[OccurAnal-main]{Counting occurrences: main function}
48 %************************************************************************
50 Here's the externally-callable interface:
53 occurAnalysePgm :: [CoreBind] -> [CoreBind]
55 = snd (go initOccEnv binds)
57 go :: OccEnv -> [CoreBind] -> (UsageDetails, [CoreBind])
61 = (final_usage, bind' ++ binds')
63 (bs_usage, binds') = go env binds
64 (final_usage, bind') = occAnalBind env bind bs_usage
66 occurAnalyseExpr :: CoreExpr -> CoreExpr
67 -- Do occurrence analysis, and discard occurence info returned
68 occurAnalyseExpr expr = snd (occAnal initOccEnv expr)
72 %************************************************************************
74 \subsection[OccurAnal-main]{Counting occurrences: main function}
76 %************************************************************************
84 -> UsageDetails -- Usage details of scope
85 -> (UsageDetails, -- Of the whole let(rec)
88 occAnalBind env (NonRec binder rhs) body_usage
89 | not (binder `usedIn` body_usage) -- It's not mentioned
92 | otherwise -- It's mentioned in the body
93 = (final_body_usage `combineUsageDetails` rhs_usage,
94 [NonRec tagged_binder rhs'])
97 (final_body_usage, tagged_binder) = tagBinder body_usage binder
98 (rhs_usage, rhs') = occAnalRhs env tagged_binder rhs
101 Dropping dead code for recursive bindings is done in a very simple way:
103 the entire set of bindings is dropped if none of its binders are
104 mentioned in its body; otherwise none are.
106 This seems to miss an obvious improvement.
121 Now @f@ is unused. But dependency analysis will sort this out into a
122 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
123 It isn't easy to do a perfect job in one blow. Consider
137 occAnalBind env (Rec pairs) body_usage
138 = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
140 analysed_pairs :: [Details1]
141 analysed_pairs = [ (bndr, rhs_usage, rhs')
142 | (bndr, rhs) <- pairs,
143 let (rhs_usage, rhs') = occAnalRhs env bndr rhs
146 sccs :: [SCC (Node Details1)]
147 sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges
150 ---- stuff for dependency analysis of binds -------------------------------
151 edges :: [Node Details1]
152 edges = _scc_ "occAnalBind.assoc"
153 [ (details, idUnique id, edges_from rhs_usage)
154 | details@(id, rhs_usage, rhs) <- analysed_pairs
157 -- (a -> b) means a mentions b
158 -- Given the usage details (a UFM that gives occ info for each free var of
159 -- the RHS) we can get the list of free vars -- or rather their Int keys --
160 -- by just extracting the keys from the finite map. Grimy, but fast.
161 -- Previously we had this:
162 -- [ bndr | bndr <- bndrs,
163 -- maybeToBool (lookupVarEnv rhs_usage bndr)]
164 -- which has n**2 cost, and this meant that edges_from alone
165 -- consumed 10% of total runtime!
166 edges_from :: UsageDetails -> [Unique]
167 edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
170 ---- stuff to "re-constitute" bindings from dependency-analysis info ------
173 do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far)
174 | not (bndr `usedIn` body_usage)
175 = (body_usage, binds_so_far) -- Dead code
177 = (combined_usage, new_bind : binds_so_far)
179 total_usage = combineUsageDetails body_usage rhs_usage
180 (combined_usage, tagged_bndr) = tagBinder total_usage bndr
181 new_bind = NonRec tagged_bndr rhs'
184 do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
185 | not (any (`usedIn` body_usage) bndrs) -- NB: look at body_usage, not total_usage
186 = (body_usage, binds_so_far) -- Dead code
188 = (combined_usage, final_bind:binds_so_far)
190 details = [details | (details, _, _) <- cycle]
191 bndrs = [bndr | (bndr, _, _) <- details]
192 rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details]
193 rhs_usage = foldr1 combineUsageDetails rhs_usages
194 total_usage = rhs_usage `combineUsageDetails` body_usage
195 (combined_usage, tagged_bndrs) = tagBinders total_usage bndrs
197 new_cycle :: [Node Details2]
198 new_cycle = zipWithEqual "reorder" mk_node tagged_bndrs cycle
199 final_bind = Rec (reOrderCycle rhs_usage new_cycle)
200 mk_node tagged_bndr ((_, _, rhs'), key, keys) = ((tagged_bndr, rhs'), key, keys)
202 {- An alternative; rebuild the edges. No semantic difference, but perf might change
204 -- Hopefully 'bndrs' is a relatively small group now
205 -- Now get ready for the loop-breaking phase, this time ignoring RulesOnly references
206 -- We've done dead-code elimination already, so no worries about un-referenced binders
207 keys = map idUnique bndrs
208 mk_node tagged_bndr (_, rhs_usage, rhs')
209 = ((tagged_bndr, rhs'), idUnique tagged_bndr, used)
211 used = [key | key <- keys, used_outside_rule rhs_usage key ]
213 used_outside_rule usage uniq = case lookupUFM_Directly usage uniq of
215 Just RulesOnly -> False -- Ignore rules
220 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
221 strongly connected component (there's guaranteed to be a cycle). It returns the
223 a) in a better order,
224 b) with some of the Ids having a IAmALoopBreaker pragma
226 The "loop-breaker" Ids are sufficient to break all cycles in the SCC. This means
227 that the simplifier can guarantee not to loop provided it never records an inlining
228 for these no-inline guys.
230 Furthermore, the order of the binds is such that if we neglect dependencies
231 on the no-inline Ids then the binds are topologically sorted. This means
232 that the simplifier will generally do a good job if it works from top bottom,
233 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
236 [June 98: I don't understand the following paragraphs, and I've
237 changed the a=b case again so that it isn't a special case any more.]
239 Here's a case that bit me:
247 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
249 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
250 Perhaps something cleverer would suffice.
255 type IdWithOccInfo = Id -- An Id with fresh PragmaInfo attached
257 type Node details = (details, Unique, [Unique]) -- The Ints are gotten from the Unique,
258 -- which is gotten from the Id.
259 type Details1 = (Id, UsageDetails, CoreExpr)
260 type Details2 = (IdWithOccInfo, CoreExpr)
262 reOrderRec :: UsageDetails -> SCC (Node Details2) -> [Details2]
263 -- Sorted into a plausible order. Enough of the Ids have
264 -- IAmALoopBreaker pragmas that there are no loops left.
265 reOrderRec rhs_usg (AcyclicSCC (bind, _, _)) = [bind]
266 reOrderRec rhs_usg (CyclicSCC cycle) = reOrderCycle rhs_usg cycle
268 reOrderCycle :: UsageDetails -> [Node Details2] -> [Details2]
269 reOrderCycle rhs_usg []
270 = panic "reOrderCycle"
271 reOrderCycle rhs_usg [bind] -- Common case of simple self-recursion
272 = [(makeLoopBreaker rhs_usg tagged_bndr, rhs)]
274 ((tagged_bndr, rhs), _, _) = bind
276 reOrderCycle rhs_usg (bind : binds)
277 = -- Choose a loop breaker, mark it no-inline,
278 -- do SCC analysis on the rest, and recursively sort them out
279 concatMap (reOrderRec rhs_usg) (stronglyConnCompR unchosen) ++
280 [(makeLoopBreaker rhs_usg tagged_bndr, rhs)]
283 (chosen_pair, unchosen) = choose_loop_breaker bind (score bind) [] binds
284 (tagged_bndr, rhs) = chosen_pair
286 -- This loop looks for the bind with the lowest score
287 -- to pick as the loop breaker. The rest accumulate in
288 choose_loop_breaker (details,_,_) loop_sc acc []
289 = (details, acc) -- Done
291 choose_loop_breaker loop_bind loop_sc acc (bind : binds)
292 | sc < loop_sc -- Lower score so pick this new one
293 = choose_loop_breaker bind sc (loop_bind : acc) binds
295 | otherwise -- No lower so don't pick it
296 = choose_loop_breaker loop_bind loop_sc (bind : acc) binds
300 score :: Node Details2 -> Int -- Higher score => less likely to be picked as loop breaker
301 score ((bndr, rhs), _, _)
302 | exprIsTrivial rhs = 4 -- Practically certain to be inlined
303 -- Used to have also: && not (isExportedId bndr)
304 -- But I found this sometimes cost an extra iteration when we have
305 -- rec { d = (a,b); a = ...df...; b = ...df...; df = d }
306 -- where df is the exported dictionary. Then df makes a really
307 -- bad choice for loop breaker
309 | not_fun_ty (idType bndr) = 3 -- Data types help with cases
310 -- This used to have a lower score than inlineCandidate, but
311 -- it's *really* helpful if dictionaries get inlined fast,
312 -- so I'm experimenting with giving higher priority to data-typed things
314 | inlineCandidate bndr rhs = 2 -- Likely to be inlined
316 | idHasRules bndr = 1
317 -- Avoid things with specialisations; we'd like
318 -- to take advantage of them in the subsequent bindings
322 inlineCandidate :: Id -> CoreExpr -> Bool
323 inlineCandidate id (Note InlineMe _) = True
324 inlineCandidate id rhs = isOneOcc (idOccInfo id)
326 -- Real example (the Enum Ordering instance from PrelBase):
327 -- rec f = \ x -> case d of (p,q,r) -> p x
328 -- g = \ x -> case d of (p,q,r) -> q x
331 -- Here, f and g occur just once; but we can't inline them into d.
332 -- On the other hand we *could* simplify those case expressions if
333 -- we didn't stupidly choose d as the loop breaker.
334 -- But we won't because constructor args are marked "Many".
336 not_fun_ty ty = not (isFunTy (dropForAlls ty))
338 makeLoopBreaker :: UsageDetails -> Id -> Id
339 -- Set the loop-breaker flag, recording whether the thing occurs only in
340 -- the RHS of a RULE (in this recursive group)
341 makeLoopBreaker rhs_usg bndr
342 = setIdOccInfo bndr (IAmALoopBreaker rules_only)
344 rules_only = case lookupVarEnv rhs_usg bndr of
345 Just RulesOnly -> True
349 @occAnalRhs@ deals with the question of bindings where the Id is marked
350 by an INLINE pragma. For these we record that anything which occurs
351 in its RHS occurs many times. This pessimistically assumes that ths
352 inlined binder also occurs many times in its scope, but if it doesn't
353 we'll catch it next time round. At worst this costs an extra simplifier pass.
354 ToDo: try using the occurrence info for the inline'd binder.
356 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
357 [June 98, SLPJ] I've undone this change; I don't understand it. See notes with reOrderRec.
362 -> Id -> CoreExpr -- Binder and rhs
363 -- For non-recs the binder is alrady tagged
364 -- with occurrence info
365 -> (UsageDetails, CoreExpr)
367 occAnalRhs env id rhs
368 = (final_usage, rhs')
370 (rhs_usage, rhs') = occAnal ctxt rhs
371 ctxt | certainly_inline id = env
372 | otherwise = rhsCtxt
373 -- Note that we generally use an rhsCtxt. This tells the occ anal n
374 -- that it's looking at an RHS, which has an effect in occAnalApp
376 -- But there's a problem. Consider
381 -- First time round, it looks as if x1 and x2 occur as an arg of a
382 -- let-bound constructor ==> give them a many-occurrence.
383 -- But then x3 is inlined (unconditionally as it happens) and
384 -- next time round, x2 will be, and the next time round x1 will be
385 -- Result: multiple simplifier iterations. Sigh.
386 -- Crude solution: use rhsCtxt for things that occur just once...
388 certainly_inline id = case idOccInfo id of
389 OneOcc in_lam one_br _ -> not in_lam && one_br
392 -- [March 98] A new wrinkle is that if the binder has specialisations inside
393 -- it then we count the specialised Ids as "extra rhs's". That way
394 -- the "parent" keeps the specialised "children" alive. If the parent
395 -- dies (because it isn't referenced any more), then the children will
396 -- die too unless they are already referenced directly.
398 final_usage = addRuleUsage rhs_usage id
400 addRuleUsage :: UsageDetails -> Id -> UsageDetails
401 -- Add the usage from RULES in Id to the usage
402 addRuleUsage usage id
403 = foldVarSet add usage (idRuleVars id)
405 add v u = addOneOcc u v RulesOnly -- Give a non-committal binder info
406 -- (i.e manyOcc) because many copies
407 -- of the specialised thing can appear
415 -> (UsageDetails, -- Gives info only about the "interesting" Ids
418 occAnal env (Type t) = (emptyDetails, Type t)
419 occAnal env (Var v) = (mkOneOcc env v False, Var v)
420 -- At one stage, I gathered the idRuleVars for v here too,
421 -- which in a way is the right thing to do.
422 -- Btu that went wrong right after specialisation, when
423 -- the *occurrences* of the overloaded function didn't have any
424 -- rules in them, so the *specialised* versions looked as if they
425 -- weren't used at all.
428 We regard variables that occur as constructor arguments as "dangerousToDup":
432 f x = let y = expensive x in
434 (case z of {(p,q)->q}, case z of {(p,q)->q})
437 We feel free to duplicate the WHNF (True,y), but that means
438 that y may be duplicated thereby.
440 If we aren't careful we duplicate the (expensive x) call!
441 Constructors are rather like lambdas in this way.
444 occAnal env expr@(Lit lit) = (emptyDetails, expr)
448 occAnal env (Note InlineMe body)
449 = case occAnal env body of { (usage, body') ->
450 (mapVarEnv markMany usage, Note InlineMe body')
453 occAnal env (Note note@(SCC cc) body)
454 = case occAnal env body of { (usage, body') ->
455 (mapVarEnv markInsideSCC usage, Note note body')
458 occAnal env (Note note body)
459 = case occAnal env body of { (usage, body') ->
460 (usage, Note note body')
463 occAnal env (Cast expr co)
464 = case occAnal env expr of { (usage, expr') ->
465 (usage, Cast expr' co)
470 occAnal env app@(App fun arg)
471 = occAnalApp env (collectArgs app) False
473 -- Ignore type variables altogether
474 -- (a) occurrences inside type lambdas only not marked as InsideLam
475 -- (b) type variables not in environment
477 occAnal env expr@(Lam x body) | isTyVar x
478 = case occAnal env body of { (body_usage, body') ->
479 (body_usage, Lam x body')
482 -- For value lambdas we do a special hack. Consider
484 -- If we did nothing, x is used inside the \y, so would be marked
485 -- as dangerous to dup. But in the common case where the abstraction
486 -- is applied to two arguments this is over-pessimistic.
487 -- So instead, we just mark each binder with its occurrence
488 -- info in the *body* of the multiple lambda.
489 -- Then, the simplifier is careful when partially applying lambdas.
491 occAnal env expr@(Lam _ _)
492 = case occAnal env_body body of { (body_usage, body') ->
494 (final_usage, tagged_binders) = tagBinders body_usage binders
495 -- URGH! Sept 99: we don't seem to be able to use binders' here, because
496 -- we get linear-typed things in the resulting program that we can't handle yet.
497 -- (e.g. PrelShow) TODO
499 really_final_usage = if linear then
502 mapVarEnv markInsideLam final_usage
505 mkLams tagged_binders body') }
507 env_body = vanillaCtxt -- Body is (no longer) an RhsContext
508 (binders, body) = collectBinders expr
509 binders' = oneShotGroup env binders
510 linear = all is_one_shot binders'
511 is_one_shot b = isId b && isOneShotBndr b
513 occAnal env (Case scrut bndr ty alts)
514 = case occ_anal_scrut scrut alts of { (scrut_usage, scrut') ->
515 case mapAndUnzip (occAnalAlt alt_env bndr) alts of { (alts_usage_s, alts') ->
517 alts_usage = foldr1 combineAltsUsageDetails alts_usage_s
518 alts_usage' = addCaseBndrUsage alts_usage
519 (alts_usage1, tagged_bndr) = tagBinder alts_usage' bndr
520 total_usage = scrut_usage `combineUsageDetails` alts_usage1
522 total_usage `seq` (total_usage, Case scrut' tagged_bndr ty alts') }}
524 -- The case binder gets a usage of either "many" or "dead", never "one".
525 -- Reason: we like to inline single occurrences, to eliminate a binding,
526 -- but inlining a case binder *doesn't* eliminate a binding.
527 -- We *don't* want to transform
528 -- case x of w { (p,q) -> f w }
530 -- case x of w { (p,q) -> f (p,q) }
531 addCaseBndrUsage usage = case lookupVarEnv usage bndr of
533 Just occ -> extendVarEnv usage bndr (markMany occ)
535 alt_env = setVanillaCtxt env
536 -- Consider x = case v of { True -> (p,q); ... }
537 -- Then it's fine to inline p and q
539 occ_anal_scrut (Var v) (alt1 : other_alts)
540 | not (null other_alts) || not (isDefaultAlt alt1)
541 = (mkOneOcc env v True, Var v)
542 occ_anal_scrut scrut alts = occAnal vanillaCtxt scrut
543 -- No need for rhsCtxt
545 occAnal env (Let bind body)
546 = case occAnal env body of { (body_usage, body') ->
547 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
548 (final_usage, mkLets new_binds body') }}
551 = case mapAndUnzip (occAnal arg_env) args of { (arg_uds_s, args') ->
552 (foldr combineUsageDetails emptyDetails arg_uds_s, args')}
554 arg_env = vanillaCtxt
557 Applications are dealt with specially because we want
558 the "build hack" to work.
561 occAnalApp env (Var fun, args) is_rhs
562 = case args_stuff of { (args_uds, args') ->
564 -- We mark the free vars of the argument of a constructor or PAP
565 -- as "many", if it is the RHS of a let(rec).
566 -- This means that nothing gets inlined into a constructor argument
567 -- position, which is what we want. Typically those constructor
568 -- arguments are just variables, or trivial expressions.
570 -- This is the *whole point* of the isRhsEnv predicate
573 isDataConWorkId fun || valArgCount args < idArity fun
574 = mapVarEnv markMany args_uds
575 | otherwise = args_uds
577 (fun_uds `combineUsageDetails` final_args_uds, mkApps (Var fun) args') }
579 fun_uniq = idUnique fun
580 fun_uds = mkOneOcc env fun (valArgCount args > 0)
582 -- Hack for build, fold, runST
583 args_stuff | fun_uniq == buildIdKey = appSpecial env 2 [True,True] args
584 | fun_uniq == augmentIdKey = appSpecial env 2 [True,True] args
585 | fun_uniq == foldrIdKey = appSpecial env 3 [False,True] args
586 | fun_uniq == runSTRepIdKey = appSpecial env 2 [True] args
587 -- (foldr k z xs) may call k many times, but it never
588 -- shares a partial application of k; hence [False,True]
589 -- This means we can optimise
590 -- foldr (\x -> let v = ...x... in \y -> ...v...) z xs
591 -- by floating in the v
593 | otherwise = occAnalArgs env args
596 occAnalApp env (fun, args) is_rhs
597 = case occAnal (addAppCtxt env args) fun of { (fun_uds, fun') ->
598 -- The addAppCtxt is a bit cunning. One iteration of the simplifier
599 -- often leaves behind beta redexs like
601 -- Here we would like to mark x,y as one-shot, and treat the whole
602 -- thing much like a let. We do this by pushing some True items
603 -- onto the context stack.
605 case occAnalArgs env args of { (args_uds, args') ->
607 final_uds = fun_uds `combineUsageDetails` args_uds
609 (final_uds, mkApps fun' args') }}
612 -> Int -> CtxtTy -- Argument number, and context to use for it
614 -> (UsageDetails, [CoreExpr])
615 appSpecial env n ctxt args
618 arg_env = vanillaCtxt
620 go n [] = (emptyDetails, []) -- Too few args
622 go 1 (arg:args) -- The magic arg
623 = case occAnal (setCtxt arg_env ctxt) arg of { (arg_uds, arg') ->
624 case occAnalArgs env args of { (args_uds, args') ->
625 (combineUsageDetails arg_uds args_uds, arg':args') }}
628 = case occAnal arg_env arg of { (arg_uds, arg') ->
629 case go (n-1) args of { (args_uds, args') ->
630 (combineUsageDetails arg_uds args_uds, arg':args') }}
636 If the case binder occurs at all, the other binders effectively do too.
638 case e of x { (a,b) -> rhs }
641 If e turns out to be (e1,e2) we indeed get something like
642 let a = e1; b = e2; x = (a,b) in rhs
644 Note [Aug 06]: I don't think this is necessary any more, and it helpe
645 to know when binders are unused. See esp the call to
646 isDeadBinder in Simplify.mkDupableAlt
649 occAnalAlt env case_bndr (con, bndrs, rhs)
650 = case occAnal env rhs of { (rhs_usage, rhs') ->
652 (final_usage, tagged_bndrs) = tagBinders rhs_usage bndrs
653 final_bndrs = tagged_bndrs -- See Note [Aug06] above
655 final_bndrs | case_bndr `elemVarEnv` final_usage = bndrs
656 | otherwise = tagged_bndrs
657 -- Leave the binders untagged if the case
658 -- binder occurs at all; see note above
661 (final_usage, (con, final_bndrs, rhs')) }
665 %************************************************************************
667 \subsection[OccurAnal-types]{OccEnv}
669 %************************************************************************
673 = OccEnv OccEncl -- Enclosing context information
674 CtxtTy -- Tells about linearity
676 -- OccEncl is used to control whether to inline into constructor arguments
678 -- x = (p,q) -- Don't inline p or q
679 -- y = /\a -> (p a, q a) -- Still don't inline p or q
680 -- z = f (p,q) -- Do inline p,q; it may make a rule fire
681 -- So OccEncl tells enought about the context to know what to do when
682 -- we encounter a contructor application or PAP.
685 = OccRhs -- RHS of let(rec), albeit perhaps inside a type lambda
686 -- Don't inline into constructor args here
687 | OccVanilla -- Argument of function, body of lambda, scruintee of case etc.
688 -- Do inline into constructor args here
693 -- True:ctxt Analysing a function-valued expression that will be
696 -- False:ctxt Analysing a function-valued expression that may
697 -- be applied many times; but when it is,
698 -- the CtxtTy inside applies
701 initOccEnv = OccEnv OccRhs []
703 vanillaCtxt = OccEnv OccVanilla []
704 rhsCtxt = OccEnv OccRhs []
706 isRhsEnv (OccEnv OccRhs _) = True
707 isRhsEnv (OccEnv OccVanilla _) = False
709 setVanillaCtxt :: OccEnv -> OccEnv
710 setVanillaCtxt (OccEnv OccRhs ctxt_ty) = OccEnv OccVanilla ctxt_ty
711 setVanillaCtxt other_env = other_env
713 setCtxt :: OccEnv -> CtxtTy -> OccEnv
714 setCtxt (OccEnv encl _) ctxt = OccEnv encl ctxt
716 oneShotGroup :: OccEnv -> [CoreBndr] -> [CoreBndr]
717 -- The result binders have one-shot-ness set that they might not have had originally.
718 -- This happens in (build (\cn -> e)). Here the occurrence analyser
719 -- linearity context knows that c,n are one-shot, and it records that fact in
720 -- the binder. This is useful to guide subsequent float-in/float-out tranformations
722 oneShotGroup (OccEnv encl ctxt) bndrs
725 go ctxt [] rev_bndrs = reverse rev_bndrs
727 go (lin_ctxt:ctxt) (bndr:bndrs) rev_bndrs
728 | isId bndr = go ctxt bndrs (bndr':rev_bndrs)
730 bndr' | lin_ctxt = setOneShotLambda bndr
733 go ctxt (bndr:bndrs) rev_bndrs = go ctxt bndrs (bndr:rev_bndrs)
735 addAppCtxt (OccEnv encl ctxt) args
736 = OccEnv encl (replicate (valArgCount args) True ++ ctxt)
739 %************************************************************************
741 \subsection[OccurAnal-types]{OccEnv}
743 %************************************************************************
746 type UsageDetails = IdEnv OccInfo -- A finite map from ids to their usage
748 combineUsageDetails, combineAltsUsageDetails
749 :: UsageDetails -> UsageDetails -> UsageDetails
751 combineUsageDetails usage1 usage2
752 = plusVarEnv_C addOccInfo usage1 usage2
754 combineAltsUsageDetails usage1 usage2
755 = plusVarEnv_C orOccInfo usage1 usage2
757 addOneOcc :: UsageDetails -> Id -> OccInfo -> UsageDetails
758 addOneOcc usage id info
759 = plusVarEnv_C addOccInfo usage (unitVarEnv id info)
760 -- ToDo: make this more efficient
762 emptyDetails = (emptyVarEnv :: UsageDetails)
764 usedIn :: Id -> UsageDetails -> Bool
765 v `usedIn` details = isExportedId v || v `elemVarEnv` details
767 tagBinders :: UsageDetails -- Of scope
769 -> (UsageDetails, -- Details with binders removed
770 [IdWithOccInfo]) -- Tagged binders
772 tagBinders usage binders
774 usage' = usage `delVarEnvList` binders
775 uss = map (setBinderOcc usage) binders
777 usage' `seq` (usage', uss)
779 tagBinder :: UsageDetails -- Of scope
781 -> (UsageDetails, -- Details with binders removed
782 IdWithOccInfo) -- Tagged binders
784 tagBinder usage binder
786 usage' = usage `delVarEnv` binder
787 binder' = setBinderOcc usage binder
789 usage' `seq` (usage', binder')
791 setBinderOcc :: UsageDetails -> CoreBndr -> CoreBndr
792 setBinderOcc usage bndr
793 | isTyVar bndr = bndr
794 | isExportedId bndr = case idOccInfo bndr of
796 other -> setIdOccInfo bndr NoOccInfo
797 -- Don't use local usage info for visible-elsewhere things
798 -- BUT *do* erase any IAmALoopBreaker annotation, because we're
799 -- about to re-generate it and it shouldn't be "sticky"
801 | otherwise = setIdOccInfo bndr occ_info
803 occ_info = lookupVarEnv usage bndr `orElse` IAmDead
807 %************************************************************************
809 \subsection{Operations over OccInfo}
811 %************************************************************************
814 mkOneOcc :: OccEnv -> Id -> InterestingCxt -> UsageDetails
815 mkOneOcc env id int_cxt
816 | isLocalId id = unitVarEnv id (OneOcc False True int_cxt)
817 | otherwise = emptyDetails
819 markMany, markInsideLam, markInsideSCC :: OccInfo -> OccInfo
821 markMany IAmDead = IAmDead
822 markMany other = NoOccInfo
824 markInsideSCC occ = markMany occ
826 markInsideLam (OneOcc _ one_br int_cxt) = OneOcc True one_br int_cxt
827 markInsideLam occ = occ
829 addOccInfo, orOccInfo :: OccInfo -> OccInfo -> OccInfo
831 addOccInfo IAmDead info2 = info2
832 addOccInfo info1 IAmDead = info1
833 addOccInfo RulesOnly RulesOnly = RulesOnly
834 addOccInfo info1 info2 = NoOccInfo
836 -- (orOccInfo orig new) is used
837 -- when combining occurrence info from branches of a case
839 orOccInfo IAmDead info2 = info2
840 orOccInfo info1 IAmDead = info1
841 orOccInfo RulesOnly RulesOnly = RulesOnly
842 orOccInfo (OneOcc in_lam1 one_branch1 int_cxt1)
843 (OneOcc in_lam2 one_branch2 int_cxt2)
844 = OneOcc (in_lam1 || in_lam2)
845 False -- False, because it occurs in both branches
846 (int_cxt1 && int_cxt2)
847 orOccInfo info1 info2 = NoOccInfo