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.
14 #include "HsVersions.h"
17 occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr
21 IMPORT_1_3(List(partition))
24 import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
26 import Digraph ( stronglyConnComp, stronglyConnCompR, SCC(..) )
27 import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
28 idType, idUnique, SYN_IE(Id),
30 emptyIdSet, unionIdSets, mkIdSet,
31 unitIdSet, elementOfIdSet,
32 addOneToIdSet, SYN_IE(IdSet),
33 nullIdEnv, unitIdEnv, combineIdEnvs,
34 delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
35 mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
38 import Name ( isExported, isLocallyDefined )
39 import Type ( getFunTy_maybe, splitForAllTy )
40 import Maybes ( maybeToBool )
41 import Outputable ( PprStyle(..), Outputable(..){-instance * (,) -} )
43 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
44 import Pretty ( Doc, vcat, ptext, nest, punctuate, comma, hcat, text )
45 import TyVar ( GenTyVar{-instance Eq-} )
46 import Unique ( Unique{-instance Eq-}, u2i )
47 import UniqFM ( keysUFM )
48 import Util ( assoc, zipEqual, zipWithEqual, Ord3(..)
55 isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
59 %************************************************************************
61 \subsection[OccurAnal-types]{Data types}
63 %************************************************************************
68 Bool -- Keep-unused-bindings flag
69 -- False <=> OK to chuck away binding
70 -- and ignore occurrences within it
71 Bool -- Keep-spec-pragma-ids flag
72 -- False <=> OK to chuck away spec pragma bindings
73 -- and ignore occurrences within it
74 Bool -- Keep-conjurable flag
75 -- False <=> OK to throw away *dead*
76 -- "conjurable" Ids; at the moment, that
77 -- *only* means constant methods, which
78 -- are top-level. A use of a "conjurable"
79 -- Id may appear out of thin air -- e.g.,
80 -- specialiser conjuring up refs to const methods.
81 Bool -- IgnoreINLINEPragma flag
82 -- False <=> OK to use INLINEPragma information
83 -- True <=> ignore INLINEPragma information
85 (Id -> IdSet -> Bool) -- Tells whether an Id occurrence is interesting,
86 -- given the set of in-scope variables
91 addNewCands :: OccEnv -> [Id] -> OccEnv
92 addNewCands (OccEnv kd ks kc ip ifun cands) ids
93 = OccEnv kd ks kc ip ifun (cands `unionIdSets` mkIdSet ids)
95 addNewCand :: OccEnv -> Id -> OccEnv
96 addNewCand (OccEnv ks kd kc ip ifun cands) id
97 = OccEnv kd ks kc ip ifun (addOneToIdSet cands id)
99 isCandidate :: OccEnv -> Id -> Bool
100 isCandidate (OccEnv _ _ _ _ ifun cands) id = ifun id cands
102 inlineMe :: OccEnv -> Id -> Bool
104 = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
105 not ignore_inline_prag &&
107 idWantsToBeINLINEd id
109 keepUnusedBinding :: OccEnv -> Id -> Bool
110 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder
111 = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
113 keepBecauseConjurable :: OccEnv -> Id -> Bool
114 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder
115 = keep_conjurable && isConstMethodId binder
117 type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
119 combineUsageDetails, combineAltsUsageDetails
120 :: UsageDetails -> UsageDetails -> UsageDetails
122 combineUsageDetails usage1 usage2
123 = combineIdEnvs addBinderInfo usage1 usage2
125 combineAltsUsageDetails usage1 usage2
126 = combineIdEnvs orBinderInfo usage1 usage2
128 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
129 addOneOcc usage id info
130 = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
131 -- ToDo: make this more efficient
133 emptyDetails = (nullIdEnv :: UsageDetails)
135 unitDetails id info = (unitIdEnv id info :: UsageDetails)
137 tagBinders :: UsageDetails -- Of scope
139 -> (UsageDetails, -- Details with binders removed
140 [(Id,BinderInfo)]) -- Tagged binders
142 tagBinders usage binders =
144 usage' = usage `delManyFromIdEnv` binders
145 uss = [ (binder, usage_of usage binder) | binder <- binders ]
147 if isNullIdEnv usage' then
152 = (usage `delManyFromIdEnv` binders,
153 [ (binder, usage_of usage binder) | binder <- binders ]
156 tagBinder :: UsageDetails -- Of scope
158 -> (UsageDetails, -- Details with binders removed
159 (Id,BinderInfo)) -- Tagged binders
161 tagBinder usage binder =
163 usage' = usage `delOneFromIdEnv` binder
164 us = usage_of usage binder
166 if isNullIdEnv usage' then -- bogus test to force evaluation.
167 (usage', (binder, us))
169 (usage', (binder, us))
171 case us of { DeadCode -> cont; _ -> cont }
173 -- (binder, usage_of usage binder)
176 usage_of usage binder
177 | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
179 = case (lookupIdEnv usage binder) of
183 isNeeded env usage binder
184 = case (usage_of usage binder) of
185 DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
190 %************************************************************************
192 \subsection[OccurAnal-main]{Counting occurrences: main function}
194 %************************************************************************
196 Here's the externally-callable interface:
200 :: [CoreBinding] -- input
201 -> (SimplifierSwitch -> Bool)
202 -> [SimplifiableCoreBinding] -- output
204 occurAnalyseBinds binds simplifier_sw_chkr
205 | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
206 (vcat (map ppr_bind binds'))
210 (_, binds') = doo initial_env binds
212 initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
213 (simplifier_sw_chkr KeepSpecPragmaIds)
214 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
215 (simplifier_sw_chkr IgnoreINLINEPragma)
216 (\id in_scope -> isLocallyDefined id) -- Anything local is interesting
217 emptyIdSet -- Not actually used
219 doo env [] = (emptyDetails, [])
221 = (final_usage, new_binds ++ the_rest)
223 new_env = env `addNewCands` (bindersOf bind)
224 (binds_usage, the_rest) = doo new_env binds
225 (final_usage, new_binds) = occAnalBind env bind binds_usage
227 -- This really ought to be done properly by PprCore, but
228 -- it isn't. pprCoreBinding only works on Id binders, and
229 -- the general case is complicated by the fact that it has to work
230 -- for interface files too. Sigh
232 ppr_bind bind@(NonRec binder expr)
235 ppr_bind bind@(Rec binds)
236 = vcat [ptext SLIT("Rec {"),
237 nest 2 (ppr PprDebug bind),
238 ptext SLIT("end Rec }")]
242 occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
244 -> (IdEnv BinderInfo, -- Occ info for interesting free vars
245 SimplifiableCoreExpr)
247 occurAnalyseExpr interesting expr
248 = occAnal initial_env expr
250 initial_env = OccEnv False {- Drop unused bindings -}
251 False {- Drop SpecPragmaId bindings -}
252 True {- Keep conjurable Ids -}
253 False {- Do not ignore INLINE Pragma -}
254 (\id locals -> interesting id || elementOfIdSet id locals)
257 occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
258 occurAnalyseGlobalExpr expr
259 = -- Top level expr, so no interesting free vars, and
260 -- discard occurence info returned
261 snd (occurAnalyseExpr (\_ -> False) expr)
264 %************************************************************************
266 \subsection[OccurAnal-main]{Counting occurrences: main function}
268 %************************************************************************
274 type Node details = (details, Int, [Int]) -- The Ints are gotten from the Unique,
275 -- which is gotten from the Id.
276 type Details1 = (Id, (UsageDetails, SimplifiableCoreExpr))
277 type Details2 = ((Id, BinderInfo), SimplifiableCoreExpr)
280 occAnalBind :: OccEnv
282 -> UsageDetails -- Usage details of scope
283 -> (UsageDetails, -- Of the whole let(rec)
284 [SimplifiableCoreBinding])
286 occAnalBind env (NonRec binder rhs) body_usage
287 | isNeeded env body_usage binder -- It's mentioned in body
288 = (final_body_usage `combineUsageDetails` rhs_usage,
289 [NonRec tagged_binder rhs'])
291 | otherwise -- Not mentioned, so drop dead code
295 binder' = nukeNoInlinePragma binder
296 (rhs_usage, rhs') = occAnalRhs env binder' rhs
297 (final_body_usage, tagged_binder) = tagBinder body_usage binder'
300 Dropping dead code for recursive bindings is done in a very simple way:
302 the entire set of bindings is dropped if none of its binders are
303 mentioned in its body; otherwise none are.
305 This seems to miss an obvious improvement.
320 Now @f@ is unused. But dependency analysis will sort this out into a
321 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
322 It isn't easy to do a perfect job in one blow. Consider
336 occAnalBind env (Rec pairs) body_usage
337 = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
339 pp_scc (CyclicSCC cycle) = hcat [text "Cyclic ", hcat (punctuate comma (map pp_item cycle))]
340 pp_scc (AcyclicSCC item) = hcat [text "Acyclic ", pp_item item]
341 pp_item (_, bndr, _) = ppr PprDebug bndr
343 binders = map fst pairs
344 new_env = env `addNewCands` binders
346 analysed_pairs :: [Details1]
347 analysed_pairs = [(nukeNoInlinePragma bndr, occAnalRhs new_env bndr rhs) | (bndr,rhs) <- pairs]
349 sccs :: [SCC (Node Details1)]
350 sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges
353 ---- stuff for dependency analysis of binds -------------------------------
354 edges :: [Node Details1]
355 edges = _scc_ "occAnalBind.assoc"
356 [ (pair, IBOX(u2i (idUnique id)), edges_from rhs_usage)
357 | pair@(id, (rhs_usage, rhs)) <- analysed_pairs
360 -- (a -> b) means a mentions b
361 -- Given the usage details (a UFM that gives occ info for each free var of
362 -- the RHS) we can get the list of free vars -- or rather their Int keys --
363 -- by just extracting the keys from the finite map. Grimy, but fast.
364 -- Previously we had this:
365 -- [ bndr | bndr <- bndrs,
366 -- maybeToBool (lookupIdEnv rhs_usage bndr)]
367 -- which has n**2 cost, and this meant that edges_from alone
368 -- consumed 10% of total runtime!
369 edges_from :: UsageDetails -> [Int]
370 edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
373 ---- stuff to "re-constitute" bindings from dependency-analysis info ------
376 do_final_bind (AcyclicSCC ((bndr, (rhs_usage, rhs')), _, _)) (body_usage, binds_so_far)
377 | isNeeded env body_usage bndr
378 = (combined_usage, new_bind : binds_so_far)
380 = (body_usage, binds_so_far) -- Dead code
382 total_usage = combineUsageDetails body_usage rhs_usage
383 (combined_usage, tagged_bndr) = tagBinder total_usage bndr
384 new_bind = NonRec tagged_bndr rhs'
387 do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
388 | any (isNeeded env body_usage) bndrs
389 = (combined_usage, final_bind:binds_so_far)
391 = (body_usage, binds_so_far) -- Dead code
393 pairs = [pair | (pair, _, _) <- cycle]
394 bndrs = [bndr | (bndr, _) <- pairs]
395 rhs_usages = [rhs_usage | (_, (rhs_usage, _)) <- pairs]
396 total_usage = foldr combineUsageDetails body_usage rhs_usages
397 (combined_usage, tagged_binders) = tagBinders total_usage bndrs
398 final_bind = Rec (reOrderRec env new_cycle)
400 new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_binders cycle)
401 mk_new_bind tagged_bndr ((_, (_, rhs')), key, keys) = ((tagged_bndr, rhs'), key, keys)
404 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
405 strongly connected component (there's guaranteed to be a cycle). It returns the
407 a) in a better order,
408 b) with some of the Ids having a IMustNotBeINLINEd pragma
410 The "no-inline" Ids are sufficient to break all cycles in the SCC. This means
411 that the simplifier can guarantee not to loop provided it never records an inlining
412 for these no-inline guys.
414 Furthermore, the order of the binds is such that if we neglect dependencies
415 on the no-inline Ids then the binds are topologically sorted. This means
416 that the simplifier will generally do a good job if it works from top bottom,
417 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
419 Here's a case that bit me:
427 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
428 (The first binding was a var-rhs; the second was a one-occ.) So the simplifier looped.
429 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
430 Perhaps something cleverer would suffice.
435 -> SCC (Node Details2)
437 -- Sorted into a plausible order. Enough of the Ids have
438 -- dontINLINE pragmas that there are no loops left.
440 -- Non-recursive case
441 reOrderRec env (AcyclicSCC (pair, _, _)) = [pair]
443 -- Common case of simple self-recursion
444 reOrderRec env (CyclicSCC [bind])
445 = [((addNoInlinePragma bndr, occ_info), rhs)]
447 (((bndr,occ_info), rhs), _, _) = bind
449 reOrderRec env (CyclicSCC binds)
450 = -- Choose a loop breaker, mark it no-inline,
451 -- do SCC analysis on the rest, and recursively sort them out
452 concat (map (reOrderRec env) (stronglyConnCompR unchosen))
454 [((addNoInlinePragma bndr, occ_info), rhs)]
457 (chosen_pair, unchosen) = choose_loop_breaker binds
458 ((bndr,occ_info), rhs) = chosen_pair
460 -- Choosing the loop breaker; heursitic
461 choose_loop_breaker (bind@(pair, _, _) : rest)
464 = (chosen, bind : unchosen) -- Don't pick it
465 | otherwise -- Pick it
468 (chosen, unchosen) = choose_loop_breaker rest
470 bad_choice ((bndr, occ_info), rhs)
471 = var_rhs rhs -- Dont pick var RHS
472 || inlineMe env bndr -- Dont pick INLINE thing
473 || one_occ occ_info -- Dont pick single-occ thing
474 || not_fun_ty (idType bndr) -- Dont pick data-ty thing
476 not_fun_ty ty = not (maybeToBool (getFunTy_maybe rho_ty))
478 (_, rho_ty) = splitForAllTy ty
481 var_rhs (Var v) = True
482 var_rhs other_rhs = False
484 -- One textual occurrence, whether inside lambda or whatever
485 -- We stick to just FunOccs because if we're not going to be able
486 -- to inline the thing on this round it might be better to pick
487 -- this one as the loop breaker. Real example (the Enum Ordering instance
489 -- rec f = \ x -> case d of (p,q,r) -> p x
490 -- g = \ x -> case d of (p,q,r) -> q x
493 -- Here, f and g occur just once; but we can't inline them into d.
494 -- On the other hand we *could* simplify those case expressions if
495 -- we didn't stupidly choose d as the loop breaker.
497 one_occ (OneOcc fun_or_arg _ _ _ _) = isFun fun_or_arg
498 one_occ other_bind = False
501 @occAnalRhs@ deals with the question of bindings where the Id is marked
502 by an INLINE pragma. For these we record that anything which occurs
503 in its RHS occurs many times. This pessimistically assumes that ths
504 inlined binder also occurs many times in its scope, but if it doesn't
505 we'll catch it next time round. At worst this costs an extra simplifier pass.
506 ToDo: try using the occurrence info for the inline'd binder.
508 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
512 -> Id -> CoreExpr -- Binder and rhs
513 -> (UsageDetails, SimplifiableCoreExpr)
515 occAnalRhs env id (Var v)
517 = (unitIdEnv v (markMany (funOccurrence 0)), Var v)
520 = (emptyDetails, Var v)
522 occAnalRhs env id rhs
524 = (mapIdEnv markMany rhs_usage, rhs')
530 (rhs_usage, rhs') = occAnal env rhs
538 -> (UsageDetails, -- Gives info only about the "interesting" Ids
539 SimplifiableCoreExpr)
543 = (unitIdEnv v (funOccurrence 0), Var v)
546 = (emptyDetails, Var v)
548 occAnal env (Lit lit) = (emptyDetails, Lit lit)
549 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
552 We regard variables that occur as constructor arguments as "dangerousToDup":
556 f x = let y = expensive x in
558 (case z of {(p,q)->q}, case z of {(p,q)->q})
561 We feel free to duplicate the WHNF (True,y), but that means
562 that y may be duplicated thereby.
564 If we aren't careful we duplicate the (expensive x) call!
565 Constructors are rather like lambdas in this way.
568 occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
571 occAnal env (SCC cc body)
572 = (mapIdEnv markInsideSCC usage, SCC cc body')
574 (usage, body') = occAnal env body
576 occAnal env (Coerce c ty body)
577 = (usage, Coerce c ty body')
579 (usage, body') = occAnal env body
581 occAnal env (App fun arg)
582 = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
584 (fun_usage, fun') = occAnal env fun
585 arg_usage = occAnalArg env arg
587 -- For value lambdas we do a special hack. Consider
589 -- If we did nothing, x is used inside the \y, so would be marked
590 -- as dangerous to dup. But in the common case where the abstraction
591 -- is applied to two arguments this is over-pessimistic.
592 -- So instead we don't take account of the \y when dealing with x's usage;
593 -- instead, the simplifier is careful when partially applying lambdas
595 occAnal env expr@(Lam (ValBinder binder) body)
596 = (mapIdEnv markDangerousToDup final_usage,
597 foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
599 (binders,body) = collectValBinders expr
600 (body_usage, body') = occAnal (env `addNewCands` binders) body
601 (final_usage, tagged_binders) = tagBinders body_usage binders
603 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
604 occAnal env (Lam (TyBinder tyvar) body)
605 = case occAnal env body of { (body_usage, body') ->
606 (mapIdEnv markDangerousToDup body_usage,
607 Lam (TyBinder tyvar) body') }
609 -- (body_usage, body') = occAnal env body
611 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
613 occAnal env (Case scrut alts)
614 = case occAnalAlts env alts of { (alts_usage, alts') ->
615 case occAnal env scrut of { (scrut_usage, scrut') ->
617 det = scrut_usage `combineUsageDetails` alts_usage
619 if isNullIdEnv det then
620 (det, Case scrut' alts')
622 (det, Case scrut' alts') }}
624 (scrut_usage `combineUsageDetails` alts_usage,
627 (scrut_usage, scrut') = occAnal env scrut
628 (alts_usage, alts') = occAnalAlts env alts
631 occAnal env (Let bind body)
632 = case occAnal new_env body of { (body_usage, body') ->
633 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
634 (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh)
636 new_env = env `addNewCands` (bindersOf bind)
637 -- (body_usage, body') = occAnal new_env body
638 -- (final_usage, new_binds) = occAnalBind env bind body_usage
644 occAnalAlts env (AlgAlts alts deflt)
645 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
646 -- Note: combine*Alts*UsageDetails...
647 AlgAlts alts' deflt')
649 (alts_usage, alts') = unzip (map do_alt alts)
650 (deflt_usage, deflt') = occAnalDeflt env deflt
652 do_alt (con, args, rhs)
653 = (final_usage, (con, tagged_args, rhs'))
655 new_env = env `addNewCands` args
656 (rhs_usage, rhs') = occAnal new_env rhs
657 (final_usage, tagged_args) = tagBinders rhs_usage args
659 occAnalAlts env (PrimAlts alts deflt)
660 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
661 -- Note: combine*Alts*UsageDetails...
662 PrimAlts alts' deflt')
664 (alts_usage, alts') = unzip (map do_alt alts)
665 (deflt_usage, deflt') = occAnalDeflt env deflt
668 = (rhs_usage, (lit, rhs'))
670 (rhs_usage, rhs') = occAnal env rhs
672 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
674 occAnalDeflt env (BindDefault binder rhs)
675 = (final_usage, BindDefault tagged_binder rhs')
677 new_env = env `addNewCand` binder
678 (rhs_usage, rhs') = occAnal new_env rhs
679 (final_usage, tagged_binder) = tagBinder rhs_usage binder
686 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
688 occAnalArgs env atoms
689 = foldr do_one_atom emptyDetails atoms
691 do_one_atom (VarArg v) usage
692 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
694 do_one_atom other_arg usage = usage
697 occAnalArg :: OccEnv -> CoreArg -> UsageDetails
699 occAnalArg env (VarArg v)
700 | isCandidate env v = unitDetails v (argOccurrence 0)
701 | otherwise = emptyDetails
702 occAnalArg _ _ = emptyDetails