2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
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 occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
18 #include "HsVersions.h"
21 import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
23 import CoreUtils ( idSpecVars )
24 import Digraph ( stronglyConnCompR, SCC(..) )
25 import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
26 omitIfaceSigForId, isSpecPragmaId, getIdSpecialisation,
28 emptyIdSet, unionIdSets, mkIdSet,
32 IdEnv, nullIdEnv, unitIdEnv, combineIdEnvs,
33 delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
34 mapIdEnv, lookupIdEnv, elemIdEnv, addOneToIdEnv
36 import SpecEnv ( isEmptySpecEnv )
37 import Name ( isExported, isLocallyDefined )
38 import Type ( splitFunTy_maybe, splitForAllTys )
39 import Maybes ( maybeToBool )
42 import UniqFM ( keysUFM )
43 import Util ( zipWithEqual )
48 %************************************************************************
50 \subsection[OccurAnal-main]{Counting occurrences: main function}
52 %************************************************************************
54 Here's the externally-callable interface:
58 :: [CoreBinding] -- input
59 -> (SimplifierSwitch -> Bool)
60 -> [SimplifiableCoreBinding] -- output
62 occurAnalyseBinds binds simplifier_sw_chkr
63 | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
64 (pprGenericBindings new_binds)
66 | otherwise = new_binds
68 new_binds = concat binds'
70 (_, _, binds') = occAnalTop initial_env binds
72 (_, binds') = occAnalTop initial_env binds
74 initial_env = OccEnv (simplifier_sw_chkr IgnoreINLINEPragma)
75 (\id in_scope -> isLocallyDefined id) -- Anything local is interesting
76 emptyIdSet -- Not actually used
81 occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
83 -> (IdEnv BinderInfo, -- Occ info for interesting free vars
86 occurAnalyseExpr interesting expr
87 = occAnal initial_env expr
89 initial_env = OccEnv False {- Do not ignore INLINE Pragma -}
90 (\id locals -> interesting id || elementOfIdSet id locals)
93 occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
94 occurAnalyseGlobalExpr expr
95 = -- Top level expr, so no interesting free vars, and
96 -- discard occurence info returned
97 snd (occurAnalyseExpr (\_ -> False) expr)
101 %************************************************************************
103 \subsection{Top level stuff}
105 %************************************************************************
107 In @occAnalTop@ we do indirection-shorting. That is, if we have this:
113 where exp is exported, and loc is not, then we replace it with this:
119 Without this we never get rid of the exp = loc thing.
120 This save a gratuitous jump
121 (from \tr{x_exported} to \tr{x_local}), and makes strictness
122 information propagate better.
123 This used to happen in the final phase, but its tidier to do it here.
126 If more than one exported thing is equal to a local thing (i.e., the
127 local thing really is shared), then we do one only:
130 x_exported1 = x_local
131 x_exported2 = x_local
135 x_exported2 = x_exported1
138 We rely on prior eta reduction to simplify things like
140 x_exported = /\ tyvars -> x_local tyvars
144 Hence,there's a possibility of leaving unchanged something like this:
147 x_exported1 = x_local Int
149 By the time we've thrown away the types in STG land this
150 could be eliminated. But I don't think it's very common
151 and it's dangerous to do this fiddling in STG land
152 because we might elminate a binding that's mentioned in the
153 unfolding for something.
158 occAnalTop :: OccEnv -- What's in scope
160 -> (IdEnv BinderInfo, -- Occurrence info
161 IdEnv Id, -- Indirection elimination info
162 [[SimplifiableCoreBinding]]
164 occAnalTop env [] = (emptyDetails, nullIdEnv, [])
165 occAnalTop env (NonRec exported_id (Var local_id) : binds)
166 | isExported exported_id && -- Only if this is exported
168 isLocallyDefined local_id && -- Only if this one is defined in this
169 -- module, so that we *can* change its
170 -- binding to be the exported thing!
172 not (isExported local_id) && -- Only if this one is not itself exported,
173 -- since the transformation will nuke it
175 not (omitIfaceSigForId local_id) && -- Don't do the transformation if rhs_id is
176 -- something like a constructor, whose
177 -- definition is implicitly exported and
178 -- which must not vanish.
180 -- To illustrate the preceding check consider
184 -- Here, we'll make a local, non-exported, defn for MkT, and without the
185 -- above condition we'll transform it to:
188 -- This is bad because mkT will get the IdDetails of MkT, and won't
189 -- be exported. Also the code generator won't make a definition for
190 -- the MkT constructor.
191 -- Slightly gruesome, this.
193 not (maybeToBool (lookupIdEnv ind_env local_id))
194 -- Only if not already substituted for
197 = -- Aha! An indirection; let's eliminate it!
198 -- pprTrace "occAnalTop" (ppr exported_id <+> ppr local_id)
199 (scope_usage, ind_env', binds')
201 (scope_usage, ind_env, binds') = occAnalTop env binds
202 ind_env' = addOneToIdEnv ind_env local_id exported_id
204 occAnalTop env (bind : binds)
205 = (final_usage, ind_env, (new_binds : binds'))
207 new_env = env `addNewCands` (bindersOf bind)
208 (scope_usage, ind_env, binds') = occAnalTop new_env binds
209 (final_usage, new_binds) = occAnalBind env (zap_bind bind) scope_usage
211 -- Deal with any indirections
212 zap_bind (NonRec bndr rhs)
213 | bndr `elemIdEnv` ind_env = Rec (zap (bndr,rhs))
214 -- The Rec isn't strictly necessary, but it's convenient
216 | or [id `elemIdEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs))
220 zap pair@(bndr,rhs) = case lookupIdEnv ind_env bndr of
222 Just exported_id -> [(bndr, Var exported_id),
227 occAnalTop :: OccEnv -- What's in scope
229 -> (IdEnv BinderInfo, -- Occurrence info
230 [[SimplifiableCoreBinding]]
232 occAnalTop env binds = occAnalTop' env ind_env binds
234 ind_env = go nullIdEnv binds
236 go ind_env [] = ind_env
237 go ind_env (NonRec exported_id (Var local_id) : binds)
238 | isExported exported_id && -- Only if this is exported
240 isLocallyDefined local_id && -- Only if this one is defined in this
241 -- module, so that we *can* change its
242 -- binding to be the exported thing!
244 not (isExported local_id) && -- Only if this one is not itself exported,
245 -- since the transformation will nuke it
247 not (omitIfaceSigForId local_id)
250 -- the last addition for 'local_id' wins.
251 ind_env' = addOneToIdEnv ind_env local_id exported_id
253 go ind_env (_:xs) = go ind_env xs
255 occAnalTop' :: OccEnv -- What's in scope
256 -> IdEnv Id -- Indirection elimination info
258 -> (IdEnv BinderInfo, -- Occurrence info
259 [[SimplifiableCoreBinding]]
261 occAnalTop' env ind_env [] = (emptyDetails, [])
263 -- Special case for eliminating indirections
264 -- Note: it's a shortcoming that this only works for
265 -- non-recursive bindings. Elminating indirections
266 -- makes perfect sense for recursive bindings too, but
267 -- it's more complicated to implement, so I haven't done so
269 occAnalTop' env ind_env (NonRec exported_id (Var local_id) : binds)
270 | maybeToBool (lookupIdEnv ind_env local_id)
271 = occAnalTop' env ind_env' binds
273 ind_env' = delOneFromIdEnv ind_env local_id
276 occAnalTop' env ind_env (bind : binds)
277 = (final_usage, (new_binds : binds'))
279 new_env = env `addNewCands` (bindersOf bind)
280 (scope_usage, binds') = occAnalTop' new_env ind_env binds
281 (final_usage, new_binds) = occAnalBind env (zap_bind bind) scope_usage
283 -- Deal with any indirections
284 zap_bind (NonRec bndr rhs)
285 | bndr `elemIdEnv` ind_env = Rec (zap (bndr,rhs))
286 -- The Rec isn't strictly necessary, but it's convenient
288 | or [id `elemIdEnv` ind_env | (id,_) <- pairs] = Rec (concat (map zap pairs))
292 zap pair@(bndr,rhs) = case lookupIdEnv ind_env bndr of
294 Just exported_id -> [(bndr, Var exported_id),
300 %************************************************************************
302 \subsection[OccurAnal-main]{Counting occurrences: main function}
304 %************************************************************************
310 type Node details = (details, Int, [Int]) -- The Ints are gotten from the Unique,
311 -- which is gotten from the Id.
312 type Details1 = (Id, UsageDetails, SimplifiableCoreExpr)
313 type Details2 = ((Id, BinderInfo), SimplifiableCoreExpr)
316 occAnalBind :: OccEnv
318 -> UsageDetails -- Usage details of scope
319 -> (UsageDetails, -- Of the whole let(rec)
320 [SimplifiableCoreBinding])
322 occAnalBind env (NonRec binder rhs) body_usage
323 | isNeeded env body_usage binder -- It's mentioned in body
324 = (final_body_usage `combineUsageDetails` rhs_usage,
325 [NonRec tagged_binder rhs'])
327 | otherwise -- Not mentioned, so drop dead code
331 binder' = nukeNoInlinePragma binder
332 (rhs_usage, rhs') = occAnalRhs env binder' rhs
333 (final_body_usage, tagged_binder) = tagBinder body_usage binder'
336 Dropping dead code for recursive bindings is done in a very simple way:
338 the entire set of bindings is dropped if none of its binders are
339 mentioned in its body; otherwise none are.
341 This seems to miss an obvious improvement.
356 Now @f@ is unused. But dependency analysis will sort this out into a
357 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
358 It isn't easy to do a perfect job in one blow. Consider
372 occAnalBind env (Rec pairs) body_usage
373 = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
375 pp_item (_, bndr, _) = ppr bndr
377 binders = map fst pairs
378 new_env = env `addNewCands` binders
380 analysed_pairs :: [Details1]
381 analysed_pairs = [ (nukeNoInlinePragma bndr, rhs_usage, rhs')
382 | (bndr, rhs) <- pairs,
383 let (rhs_usage, rhs') = occAnalRhs new_env bndr rhs
386 sccs :: [SCC (Node Details1)]
387 sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges
390 ---- stuff for dependency analysis of binds -------------------------------
391 edges :: [Node Details1]
392 edges = _scc_ "occAnalBind.assoc"
393 [ (details, IBOX(u2i (idUnique id)), edges_from rhs_usage)
394 | details@(id, rhs_usage, rhs) <- analysed_pairs
397 -- (a -> b) means a mentions b
398 -- Given the usage details (a UFM that gives occ info for each free var of
399 -- the RHS) we can get the list of free vars -- or rather their Int keys --
400 -- by just extracting the keys from the finite map. Grimy, but fast.
401 -- Previously we had this:
402 -- [ bndr | bndr <- bndrs,
403 -- maybeToBool (lookupIdEnv rhs_usage bndr)]
404 -- which has n**2 cost, and this meant that edges_from alone
405 -- consumed 10% of total runtime!
406 edges_from :: UsageDetails -> [Int]
407 edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
410 ---- stuff to "re-constitute" bindings from dependency-analysis info ------
413 do_final_bind (AcyclicSCC ((bndr, rhs_usage, rhs'), _, _)) (body_usage, binds_so_far)
414 | isNeeded env body_usage bndr
415 = (combined_usage, new_bind : binds_so_far)
417 = (body_usage, binds_so_far) -- Dead code
419 total_usage = combineUsageDetails body_usage rhs_usage
420 (combined_usage, tagged_bndr) = tagBinder total_usage bndr
421 new_bind = NonRec tagged_bndr rhs'
424 do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
425 | any (isNeeded env body_usage) bndrs
426 = (combined_usage, final_bind:binds_so_far)
428 = (body_usage, binds_so_far) -- Dead code
430 details = [details | (details, _, _) <- cycle]
431 bndrs = [bndr | (bndr, _, _) <- details]
432 rhs_usages = [rhs_usage | (_, rhs_usage, _) <- details]
433 total_usage = foldr combineUsageDetails body_usage rhs_usages
434 (combined_usage, tagged_binders) = tagBinders total_usage bndrs
435 final_bind = Rec (reOrderRec env new_cycle)
437 new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_binders cycle)
438 mk_new_bind (bndr, occ_info) ((_, _, rhs'), key, keys) = (((bndr, occ_info), rhs'), key, keys)
441 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
442 strongly connected component (there's guaranteed to be a cycle). It returns the
444 a) in a better order,
445 b) with some of the Ids having a IMustNotBeINLINEd pragma
447 The "no-inline" Ids are sufficient to break all cycles in the SCC. This means
448 that the simplifier can guarantee not to loop provided it never records an inlining
449 for these no-inline guys.
451 Furthermore, the order of the binds is such that if we neglect dependencies
452 on the no-inline Ids then the binds are topologically sorted. This means
453 that the simplifier will generally do a good job if it works from top bottom,
454 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
456 Here's a case that bit me:
464 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
466 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
467 Perhaps something cleverer would suffice.
469 You might think that you can prevent non-termination simply by making
470 sure that we simplify a recursive binding's RHS in an environment that
471 simply clones the recursive Id. But no. Consider
473 letrec f = \x -> let z = f x' in ...
480 We bind n to its *simplified* RHS, we then *re-simplify* it when
481 we inline n. Then we may well inline f; and then the same thing
484 I don't think it's possible to prevent non-termination by environment
485 manipulation in this way. Apart from anything else, successive
486 iterations of the simplifier may unroll recursive loops in cases like
487 that above. The idea of beaking every recursive loop with an
488 IMustNotBeINLINEd pragma is much much better.
494 -> SCC (Node Details2)
496 -- Sorted into a plausible order. Enough of the Ids have
497 -- dontINLINE pragmas that there are no loops left.
499 -- Non-recursive case
500 reOrderRec env (AcyclicSCC (bind, _, _)) = [bind]
502 -- Common case of simple self-recursion
503 reOrderRec env (CyclicSCC [bind])
504 = [((addNoInlinePragma bndr, occ_info), rhs)]
506 (((bndr, occ_info), rhs), _, _) = bind
508 reOrderRec env (CyclicSCC binds)
509 = -- Choose a loop breaker, mark it no-inline,
510 -- do SCC analysis on the rest, and recursively sort them out
511 concat (map (reOrderRec env) (stronglyConnCompR unchosen))
513 [((addNoInlinePragma bndr, occ_info), rhs)]
516 (chosen_pair, unchosen) = choose_loop_breaker binds
517 ((bndr,occ_info), rhs) = chosen_pair
519 -- Choosing the loop breaker; heursitic
520 choose_loop_breaker (bind@(details, _, _) : rest)
523 = (chosen, bind : unchosen) -- Don't pick it
524 | otherwise -- Pick it
527 (chosen, unchosen) = choose_loop_breaker rest
529 bad_choice ((bndr, occ_info), rhs)
530 = var_rhs rhs -- Dont pick var RHS
531 || inlineMe env bndr -- Dont pick INLINE thing
532 || isOneFunOcc occ_info -- Dont pick single-occ thing
533 || not_fun_ty (idType bndr) -- Dont pick data-ty thing
534 || not (isEmptySpecEnv (getIdSpecialisation bndr))
535 -- Avoid things with a SpecEnv; we'd like
536 -- to take advantage of the SpecEnv in the subsuequent bindings
538 -- isOneFunOcc looks for one textual occurrence, whether inside lambda or whatever.
539 -- We stick to just FunOccs because if we're not going to be able
540 -- to inline the thing on this round it might be better to pick
541 -- this one as the loop breaker. Real example (the Enum Ordering instance
543 -- rec f = \ x -> case d of (p,q,r) -> p x
544 -- g = \ x -> case d of (p,q,r) -> q x
547 -- Here, f and g occur just once; but we can't inline them into d.
548 -- On the other hand we *could* simplify those case expressions if
549 -- we didn't stupidly choose d as the loop breaker.
551 not_fun_ty ty = not (maybeToBool (splitFunTy_maybe rho_ty))
553 (_, rho_ty) = splitForAllTys ty
556 var_rhs (Var v) = True
557 var_rhs other_rhs = False
560 @occAnalRhs@ deals with the question of bindings where the Id is marked
561 by an INLINE pragma. For these we record that anything which occurs
562 in its RHS occurs many times. This pessimistically assumes that ths
563 inlined binder also occurs many times in its scope, but if it doesn't
564 we'll catch it next time round. At worst this costs an extra simplifier pass.
565 ToDo: try using the occurrence info for the inline'd binder.
567 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
569 [March 98] A new wrinkle is that if the binder has specialisations inside
570 it then we count the specialised Ids as "extra rhs's". That way
571 the "parent" keeps the specialised "children" alive. If the parent
572 dies (because it isn't referenced any more), then the children will
573 die too unless they are already referenced directly.
577 -> Id -> CoreExpr -- Binder and rhs
578 -> (UsageDetails, SimplifiableCoreExpr)
580 occAnalRhs env id (Var v)
582 = (unitIdEnv v (markMany (funOccurrence 0)), Var v)
585 = (emptyDetails, Var v)
587 occAnalRhs env id rhs
589 = (mapIdEnv markMany total_usage, rhs')
592 = (total_usage, rhs')
595 (rhs_usage, rhs') = occAnal env rhs
596 total_usage = foldr add rhs_usage (idSpecVars id)
597 add v u = addOneOcc u v noBinderInfo -- Give a non-committal binder info
598 -- (i.e manyOcc) because many copies
599 -- of the specialised thing can appear
607 -> (UsageDetails, -- Gives info only about the "interesting" Ids
608 SimplifiableCoreExpr)
612 = (unitIdEnv v (funOccurrence 0), Var v)
615 = (emptyDetails, Var v)
617 occAnal env (Lit lit) = (emptyDetails, Lit lit)
618 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
621 We regard variables that occur as constructor arguments as "dangerousToDup":
625 f x = let y = expensive x in
627 (case z of {(p,q)->q}, case z of {(p,q)->q})
630 We feel free to duplicate the WHNF (True,y), but that means
631 that y may be duplicated thereby.
633 If we aren't careful we duplicate the (expensive x) call!
634 Constructors are rather like lambdas in this way.
637 occAnal env (Con con args)
638 = (mapIdEnv markDangerousToDup (occAnalArgs env args),
641 occAnal env (Note note@(SCC cc) body)
642 = (mapIdEnv markInsideSCC usage, Note note body')
644 (usage, body') = occAnal env body
646 occAnal env (Note note body)
647 = (usage, Note note body')
649 (usage, body') = occAnal env body
651 occAnal env (App fun arg)
652 = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
654 (fun_usage, fun') = occAnal env fun
655 arg_usage = occAnalArg env arg
657 -- For value lambdas we do a special hack. Consider
659 -- If we did nothing, x is used inside the \y, so would be marked
660 -- as dangerous to dup. But in the common case where the abstraction
661 -- is applied to two arguments this is over-pessimistic.
662 -- So instead we don't take account of the \y when dealing with x's usage;
663 -- instead, the simplifier is careful when partially applying lambdas
665 occAnal env expr@(Lam (ValBinder binder) body)
666 = (mapIdEnv markDangerousToDup final_usage,
667 foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
669 (binders,body) = collectValBinders expr
670 (body_usage, body') = occAnal (env `addNewCands` binders) body
671 (final_usage, tagged_binders) = tagBinders body_usage binders
673 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
674 occAnal env (Lam (TyBinder tyvar) body)
675 = case occAnal env body of { (body_usage, body') ->
676 (mapIdEnv markDangerousToDup body_usage,
677 Lam (TyBinder tyvar) body') }
679 -- (body_usage, body') = occAnal env body
681 occAnal env (Case scrut alts)
682 = case occAnalAlts env alts of { (alts_usage, alts') ->
683 case occAnal env scrut of { (scrut_usage, scrut') ->
685 det = scrut_usage `combineUsageDetails` alts_usage
687 if isNullIdEnv det then
688 (det, Case scrut' alts')
690 (det, Case scrut' alts') }}
692 (scrut_usage `combineUsageDetails` alts_usage,
695 (scrut_usage, scrut') = occAnal env scrut
696 (alts_usage, alts') = occAnalAlts env alts
699 occAnal env (Let bind body)
700 = case occAnal new_env body of { (body_usage, body') ->
701 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
702 (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh)
704 new_env = env `addNewCands` (bindersOf bind)
705 -- (body_usage, body') = occAnal new_env body
706 -- (final_usage, new_binds) = occAnalBind env bind body_usage
712 occAnalAlts env (AlgAlts alts deflt)
713 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
714 -- Note: combine*Alts*UsageDetails...
715 AlgAlts alts' deflt')
717 (alts_usage, alts') = unzip (map do_alt alts)
718 (deflt_usage, deflt') = occAnalDeflt env deflt
720 do_alt (con, args, rhs)
721 = (final_usage, (con, tagged_args, rhs'))
723 new_env = env `addNewCands` args
724 (rhs_usage, rhs') = occAnal new_env rhs
725 (final_usage, tagged_args) = tagBinders rhs_usage args
727 occAnalAlts env (PrimAlts alts deflt)
728 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
729 -- Note: combine*Alts*UsageDetails...
730 PrimAlts alts' deflt')
732 (alts_usage, alts') = unzip (map do_alt alts)
733 (deflt_usage, deflt') = occAnalDeflt env deflt
736 = (rhs_usage, (lit, rhs'))
738 (rhs_usage, rhs') = occAnal env rhs
740 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
742 occAnalDeflt env (BindDefault binder rhs)
743 = (final_usage, BindDefault tagged_binder rhs')
745 new_env = env `addNewCand` binder
746 (rhs_usage, rhs') = occAnal new_env rhs
747 (final_usage, tagged_binder) = tagBinder rhs_usage binder
754 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
756 occAnalArgs env atoms
757 = foldr do_one_atom emptyDetails atoms
759 do_one_atom (VarArg v) usage
760 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
762 do_one_atom other_arg usage = usage
765 occAnalArg :: OccEnv -> CoreArg -> UsageDetails
767 occAnalArg env (VarArg v)
768 | isCandidate env v = unitDetails v (argOccurrence 0)
769 | otherwise = emptyDetails
770 occAnalArg _ _ = emptyDetails
774 %************************************************************************
776 \subsection[OccurAnal-types]{Data types}
778 %************************************************************************
783 Bool -- IgnoreINLINEPragma flag
784 -- False <=> OK to use INLINEPragma information
785 -- True <=> ignore INLINEPragma information
787 (Id -> IdSet -> Bool) -- Tells whether an Id occurrence is interesting,
788 -- given the set of in-scope variables
790 IdSet -- In-scope Ids
793 addNewCands :: OccEnv -> [Id] -> OccEnv
794 addNewCands (OccEnv ip ifun cands) ids
795 = OccEnv ip ifun (cands `unionIdSets` mkIdSet ids)
797 addNewCand :: OccEnv -> Id -> OccEnv
798 addNewCand (OccEnv ip ifun cands) id
799 = OccEnv ip ifun (addOneToIdSet cands id)
801 isCandidate :: OccEnv -> Id -> Bool
802 isCandidate (OccEnv _ ifun cands) id = ifun id cands
804 inlineMe :: OccEnv -> Id -> Bool
806 = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
807 not ignore_inline_prag &&
809 idWantsToBeINLINEd id
812 type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
814 combineUsageDetails, combineAltsUsageDetails
815 :: UsageDetails -> UsageDetails -> UsageDetails
817 combineUsageDetails usage1 usage2
818 = combineIdEnvs addBinderInfo usage1 usage2
820 combineAltsUsageDetails usage1 usage2
821 = combineIdEnvs orBinderInfo usage1 usage2
823 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
824 addOneOcc usage id info
825 = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
826 -- ToDo: make this more efficient
828 emptyDetails = (nullIdEnv :: UsageDetails)
830 unitDetails id info = (unitIdEnv id info :: UsageDetails)
832 tagBinders :: UsageDetails -- Of scope
834 -> (UsageDetails, -- Details with binders removed
835 [(Id,BinderInfo)]) -- Tagged binders
837 tagBinders usage binders =
839 usage' = usage `delManyFromIdEnv` binders
840 uss = [ (binder, usage_of usage binder) | binder <- binders ]
842 if isNullIdEnv usage' then
847 = (usage `delManyFromIdEnv` binders,
848 [ (binder, usage_of usage binder) | binder <- binders ]
851 tagBinder :: UsageDetails -- Of scope
853 -> (UsageDetails, -- Details with binders removed
854 (Id,BinderInfo)) -- Tagged binders
856 tagBinder usage binder =
858 usage' = usage `delOneFromIdEnv` binder
859 us = usage_of usage binder
861 if isNullIdEnv usage' then -- Bogus test to force evaluation.
862 (usage', (binder, us))
864 (usage', (binder, us))
866 if isDeadOcc us then -- Ditto
872 usage_of usage binder
873 | isExported binder || isSpecPragmaId binder
874 = noBinderInfo -- Visible-elsewhere things count as many
876 = case (lookupIdEnv usage binder) of
877 Nothing -> deadOccurrence
880 isNeeded env usage binder = not (isDeadOcc (usage_of usage binder))