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_DELOOPER(IdLoop) -- paranoia
22 IMPORT_1_3(List(partition))
25 import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
27 import Digraph ( stronglyConnComp, stronglyConnCompR, SCC(..) )
28 import Id ( idWantsToBeINLINEd, addNoInlinePragma, nukeNoInlinePragma,
31 emptyIdSet, unionIdSets, mkIdSet,
32 unitIdSet, elementOfIdSet,
33 addOneToIdSet, SYN_IE(IdSet),
34 nullIdEnv, unitIdEnv, combineIdEnvs,
35 delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
36 mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
39 import Name ( isExported, isLocallyDefined )
40 import Type ( getFunTy_maybe, splitForAllTy )
41 import Maybes ( maybeToBool )
42 import Outputable ( Outputable(..){-instance * (,) -} )
44 import PprStyle ( PprStyle(..) )
45 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
46 import Pretty ( Doc, vcat, ptext, nest, punctuate, comma, hcat, text )
47 import TyVar ( GenTyVar{-instance Eq-} )
48 import Unique ( Unique{-instance Eq-}, u2i )
49 import UniqFM ( keysUFM )
50 import Util ( assoc, zipEqual, zipWithEqual, Ord3(..)
57 isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
61 %************************************************************************
63 \subsection[OccurAnal-types]{Data types}
65 %************************************************************************
70 Bool -- Keep-unused-bindings flag
71 -- False <=> OK to chuck away binding
72 -- and ignore occurrences within it
73 Bool -- Keep-spec-pragma-ids flag
74 -- False <=> OK to chuck away spec pragma bindings
75 -- and ignore occurrences within it
76 Bool -- Keep-conjurable flag
77 -- False <=> OK to throw away *dead*
78 -- "conjurable" Ids; at the moment, that
79 -- *only* means constant methods, which
80 -- are top-level. A use of a "conjurable"
81 -- Id may appear out of thin air -- e.g.,
82 -- specialiser conjuring up refs to const methods.
83 Bool -- IgnoreINLINEPragma flag
84 -- False <=> OK to use INLINEPragma information
85 -- True <=> ignore INLINEPragma information
87 (Id -> IdSet -> Bool) -- Tells whether an Id occurrence is interesting,
88 -- given the set of in-scope variables
93 addNewCands :: OccEnv -> [Id] -> OccEnv
94 addNewCands (OccEnv kd ks kc ip ifun cands) ids
95 = OccEnv kd ks kc ip ifun (cands `unionIdSets` mkIdSet ids)
97 addNewCand :: OccEnv -> Id -> OccEnv
98 addNewCand (OccEnv ks kd kc ip ifun cands) id
99 = OccEnv kd ks kc ip ifun (addOneToIdSet cands id)
101 isCandidate :: OccEnv -> Id -> Bool
102 isCandidate (OccEnv _ _ _ _ ifun cands) id = ifun id cands
104 inlineMe :: OccEnv -> Id -> Bool
106 = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
107 not ignore_inline_prag &&
109 idWantsToBeINLINEd id
111 keepUnusedBinding :: OccEnv -> Id -> Bool
112 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder
113 = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
115 keepBecauseConjurable :: OccEnv -> Id -> Bool
116 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _ _) binder
117 = keep_conjurable && isConstMethodId binder
119 type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
121 combineUsageDetails, combineAltsUsageDetails
122 :: UsageDetails -> UsageDetails -> UsageDetails
124 combineUsageDetails usage1 usage2
125 = combineIdEnvs addBinderInfo usage1 usage2
127 combineAltsUsageDetails usage1 usage2
128 = combineIdEnvs orBinderInfo usage1 usage2
130 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
131 addOneOcc usage id info
132 = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
133 -- ToDo: make this more efficient
135 emptyDetails = (nullIdEnv :: UsageDetails)
137 unitDetails id info = (unitIdEnv id info :: UsageDetails)
139 tagBinders :: UsageDetails -- Of scope
141 -> (UsageDetails, -- Details with binders removed
142 [(Id,BinderInfo)]) -- Tagged binders
144 tagBinders usage binders =
146 usage' = usage `delManyFromIdEnv` binders
147 uss = [ (binder, usage_of usage binder) | binder <- binders ]
149 if isNullIdEnv usage' then
154 = (usage `delManyFromIdEnv` binders,
155 [ (binder, usage_of usage binder) | binder <- binders ]
158 tagBinder :: UsageDetails -- Of scope
160 -> (UsageDetails, -- Details with binders removed
161 (Id,BinderInfo)) -- Tagged binders
163 tagBinder usage binder =
165 usage' = usage `delOneFromIdEnv` binder
166 us = usage_of usage binder
168 if isNullIdEnv usage' then -- bogus test to force evaluation.
169 (usage', (binder, us))
171 (usage', (binder, us))
173 case us of { DeadCode -> cont; _ -> cont }
175 -- (binder, usage_of usage binder)
178 usage_of usage binder
179 | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
181 = case (lookupIdEnv usage binder) of
185 isNeeded env usage binder
186 = case (usage_of usage binder) of
187 DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
192 %************************************************************************
194 \subsection[OccurAnal-main]{Counting occurrences: main function}
196 %************************************************************************
198 Here's the externally-callable interface:
202 :: [CoreBinding] -- input
203 -> (SimplifierSwitch -> Bool)
204 -> [SimplifiableCoreBinding] -- output
206 occurAnalyseBinds binds simplifier_sw_chkr
207 | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
208 (vcat (map ppr_bind binds'))
212 (_, binds') = doo initial_env binds
214 initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
215 (simplifier_sw_chkr KeepSpecPragmaIds)
216 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
217 (simplifier_sw_chkr IgnoreINLINEPragma)
218 (\id in_scope -> isLocallyDefined id) -- Anything local is interesting
219 emptyIdSet -- Not actually used
221 doo env [] = (emptyDetails, [])
223 = (final_usage, new_binds ++ the_rest)
225 new_env = env `addNewCands` (bindersOf bind)
226 (binds_usage, the_rest) = doo new_env binds
227 (final_usage, new_binds) = occAnalBind env bind binds_usage
229 -- This really ought to be done properly by PprCore, but
230 -- it isn't. pprCoreBinding only works on Id binders, and
231 -- the general case is complicated by the fact that it has to work
232 -- for interface files too. Sigh
234 ppr_bind bind@(NonRec binder expr)
237 ppr_bind bind@(Rec binds)
238 = vcat [ptext SLIT("Rec {"),
239 nest 2 (ppr PprDebug bind),
240 ptext SLIT("end Rec }")]
244 occurAnalyseExpr :: (Id -> Bool) -- Tells if a variable is interesting
246 -> (IdEnv BinderInfo, -- Occ info for interesting free vars
247 SimplifiableCoreExpr)
249 occurAnalyseExpr interesting expr
250 = occAnal initial_env expr
252 initial_env = OccEnv False {- Drop unused bindings -}
253 False {- Drop SpecPragmaId bindings -}
254 True {- Keep conjurable Ids -}
255 False {- Do not ignore INLINE Pragma -}
256 (\id locals -> interesting id || elementOfIdSet id locals)
259 occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
260 occurAnalyseGlobalExpr expr
261 = -- Top level expr, so no interesting free vars, and
262 -- discard occurence info returned
263 snd (occurAnalyseExpr (\_ -> False) expr)
266 %************************************************************************
268 \subsection[OccurAnal-main]{Counting occurrences: main function}
270 %************************************************************************
276 type Node details = (details, Int, [Int]) -- The Ints are gotten from the Unique,
277 -- which is gotten from the Id.
278 type Details1 = (Id, (UsageDetails, SimplifiableCoreExpr))
279 type Details2 = ((Id, BinderInfo), SimplifiableCoreExpr)
282 occAnalBind :: OccEnv
284 -> UsageDetails -- Usage details of scope
285 -> (UsageDetails, -- Of the whole let(rec)
286 [SimplifiableCoreBinding])
288 occAnalBind env (NonRec binder rhs) body_usage
289 | isNeeded env body_usage binder -- It's mentioned in body
290 = (final_body_usage `combineUsageDetails` rhs_usage,
291 [NonRec tagged_binder rhs'])
293 | otherwise -- Not mentioned, so drop dead code
297 binder' = nukeNoInlinePragma binder
298 (rhs_usage, rhs') = occAnalRhs env binder' rhs
299 (final_body_usage, tagged_binder) = tagBinder body_usage binder'
302 Dropping dead code for recursive bindings is done in a very simple way:
304 the entire set of bindings is dropped if none of its binders are
305 mentioned in its body; otherwise none are.
307 This seems to miss an obvious improvement.
322 Now @f@ is unused. But dependency analysis will sort this out into a
323 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
324 It isn't easy to do a perfect job in one blow. Consider
338 occAnalBind env (Rec pairs) body_usage
339 = foldr (_scc_ "occAnalBind.dofinal" do_final_bind) (body_usage, []) sccs
341 pp_scc (CyclicSCC cycle) = hcat [text "Cyclic ", hcat (punctuate comma (map pp_item cycle))]
342 pp_scc (AcyclicSCC item) = hcat [text "Acyclic ", pp_item item]
343 pp_item (_, bndr, _) = ppr PprDebug bndr
345 binders = map fst pairs
346 new_env = env `addNewCands` binders
348 analysed_pairs :: [Details1]
349 analysed_pairs = [(nukeNoInlinePragma bndr, occAnalRhs new_env bndr rhs) | (bndr,rhs) <- pairs]
351 sccs :: [SCC (Node Details1)]
352 sccs = _scc_ "occAnalBind.scc" stronglyConnCompR edges
355 ---- stuff for dependency analysis of binds -------------------------------
356 edges :: [Node Details1]
357 edges = _scc_ "occAnalBind.assoc"
358 [ (pair, IBOX(u2i (idUnique id)), edges_from rhs_usage)
359 | pair@(id, (rhs_usage, rhs)) <- analysed_pairs
362 -- (a -> b) means a mentions b
363 -- Given the usage details (a UFM that gives occ info for each free var of
364 -- the RHS) we can get the list of free vars -- or rather their Int keys --
365 -- by just extracting the keys from the finite map. Grimy, but fast.
366 -- Previously we had this:
367 -- [ bndr | bndr <- bndrs,
368 -- maybeToBool (lookupIdEnv rhs_usage bndr)]
369 -- which has n**2 cost, and this meant that edges_from alone
370 -- consumed 10% of total runtime!
371 edges_from :: UsageDetails -> [Int]
372 edges_from rhs_usage = _scc_ "occAnalBind.edges_from"
375 ---- stuff to "re-constitute" bindings from dependency-analysis info ------
378 do_final_bind (AcyclicSCC ((bndr, (rhs_usage, rhs')), _, _)) (body_usage, binds_so_far)
379 | isNeeded env body_usage bndr
380 = (combined_usage, new_bind : binds_so_far)
382 = (body_usage, binds_so_far) -- Dead code
384 total_usage = combineUsageDetails body_usage rhs_usage
385 (combined_usage, tagged_bndr) = tagBinder total_usage bndr
386 new_bind = NonRec tagged_bndr rhs'
389 do_final_bind (CyclicSCC cycle) (body_usage, binds_so_far)
390 | any (isNeeded env body_usage) bndrs
391 = (combined_usage, final_bind:binds_so_far)
393 = (body_usage, binds_so_far) -- Dead code
395 pairs = [pair | (pair, _, _) <- cycle]
396 bndrs = [bndr | (bndr, _) <- pairs]
397 rhs_usages = [rhs_usage | (_, (rhs_usage, _)) <- pairs]
398 total_usage = foldr combineUsageDetails body_usage rhs_usages
399 (combined_usage, tagged_binders) = tagBinders total_usage bndrs
400 final_bind = Rec (reOrderRec env new_cycle)
402 new_cycle = CyclicSCC (zipWithEqual "occAnalBind" mk_new_bind tagged_binders cycle)
403 mk_new_bind tagged_bndr ((_, (_, rhs')), key, keys) = ((tagged_bndr, rhs'), key, keys)
406 @reOrderRec@ is applied to the list of (binder,rhs) pairs for a cyclic
407 strongly connected component (there's guaranteed to be a cycle). It returns the
409 a) in a better order,
410 b) with some of the Ids having a IMustNotBeINLINEd pragma
412 The "no-inline" Ids are sufficient to break all cycles in the SCC. This means
413 that the simplifier can guarantee not to loop provided it never records an inlining
414 for these no-inline guys.
416 Furthermore, the order of the binds is such that if we neglect dependencies
417 on the no-inline Ids then the binds are topologically sorted. This means
418 that the simplifier will generally do a good job if it works from top bottom,
419 recording inlinings for any Ids which aren't marked as "no-inline" as it goes.
421 Here's a case that bit me:
429 Re-ordering doesn't change the order of bindings, but there was no loop-breaker.
430 (The first binding was a var-rhs; the second was a one-occ.) So the simplifier looped.
431 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
432 Perhaps something cleverer would suffice.
437 -> SCC (Node Details2)
439 -- Sorted into a plausible order. Enough of the Ids have
440 -- dontINLINE pragmas that there are no loops left.
442 -- Non-recursive case
443 reOrderRec env (AcyclicSCC (pair, _, _)) = [pair]
445 -- Common case of simple self-recursion
446 reOrderRec env (CyclicSCC [bind])
447 = [((addNoInlinePragma bndr, occ_info), rhs)]
449 (((bndr,occ_info), rhs), _, _) = bind
451 reOrderRec env (CyclicSCC binds)
452 = -- Choose a loop breaker, mark it no-inline,
453 -- do SCC analysis on the rest, and recursively sort them out
454 concat (map (reOrderRec env) (stronglyConnCompR unchosen))
456 [((addNoInlinePragma bndr, occ_info), rhs)]
459 (chosen_pair, unchosen) = choose_loop_breaker binds
460 ((bndr,occ_info), rhs) = chosen_pair
462 -- Choosing the loop breaker; heursitic
463 choose_loop_breaker (bind@(pair, _, _) : rest)
466 = (chosen, bind : unchosen) -- Don't pick it
467 | otherwise -- Pick it
470 (chosen, unchosen) = choose_loop_breaker rest
472 bad_choice ((bndr, occ_info), rhs)
473 = var_rhs rhs -- Dont pick var RHS
474 || inlineMe env bndr -- Dont pick INLINE thing
475 || one_occ occ_info -- Dont pick single-occ thing
476 || not_fun_ty (idType bndr) -- Dont pick data-ty thing
478 not_fun_ty ty = not (maybeToBool (getFunTy_maybe rho_ty))
480 (_, rho_ty) = splitForAllTy ty
483 var_rhs (Var v) = True
484 var_rhs other_rhs = False
486 -- One textual occurrence, whether inside lambda or whatever
487 -- We stick to just FunOccs because if we're not going to be able
488 -- to inline the thing on this round it might be better to pick
489 -- this one as the loop breaker. Real example (the Enum Ordering instance
491 -- rec f = \ x -> case d of (p,q,r) -> p x
492 -- g = \ x -> case d of (p,q,r) -> q x
495 -- Here, f and g occur just once; but we can't inline them into d.
496 -- On the other hand we *could* simplify those case expressions if
497 -- we didn't stupidly choose d as the loop breaker.
499 one_occ (OneOcc fun_or_arg _ _ _ _) = isFun fun_or_arg
500 one_occ other_bind = False
503 @occAnalRhs@ deals with the question of bindings where the Id is marked
504 by an INLINE pragma. For these we record that anything which occurs
505 in its RHS occurs many times. This pessimistically assumes that ths
506 inlined binder also occurs many times in its scope, but if it doesn't
507 we'll catch it next time round. At worst this costs an extra simplifier pass.
508 ToDo: try using the occurrence info for the inline'd binder.
510 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
514 -> Id -> CoreExpr -- Binder and rhs
515 -> (UsageDetails, SimplifiableCoreExpr)
517 occAnalRhs env id (Var v)
519 = (unitIdEnv v (markMany (funOccurrence 0)), Var v)
522 = (emptyDetails, Var v)
524 occAnalRhs env id rhs
526 = (mapIdEnv markMany rhs_usage, rhs')
532 (rhs_usage, rhs') = occAnal env rhs
540 -> (UsageDetails, -- Gives info only about the "interesting" Ids
541 SimplifiableCoreExpr)
545 = (unitIdEnv v (funOccurrence 0), Var v)
548 = (emptyDetails, Var v)
550 occAnal env (Lit lit) = (emptyDetails, Lit lit)
551 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
554 We regard variables that occur as constructor arguments as "dangerousToDup":
558 f x = let y = expensive x in
560 (case z of {(p,q)->q}, case z of {(p,q)->q})
563 We feel free to duplicate the WHNF (True,y), but that means
564 that y may be duplicated thereby.
566 If we aren't careful we duplicate the (expensive x) call!
567 Constructors are rather like lambdas in this way.
570 occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
573 occAnal env (SCC cc body)
574 = (mapIdEnv markInsideSCC usage, SCC cc body')
576 (usage, body') = occAnal env body
578 occAnal env (Coerce c ty body)
579 = (usage, Coerce c ty body')
581 (usage, body') = occAnal env body
583 occAnal env (App fun arg)
584 = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
586 (fun_usage, fun') = occAnal env fun
587 arg_usage = occAnalArg env arg
589 -- For value lambdas we do a special hack. Consider
591 -- If we did nothing, x is used inside the \y, so would be marked
592 -- as dangerous to dup. But in the common case where the abstraction
593 -- is applied to two arguments this is over-pessimistic.
594 -- So instead we don't take account of the \y when dealing with x's usage;
595 -- instead, the simplifier is careful when partially applying lambdas
597 occAnal env expr@(Lam (ValBinder binder) body)
598 = (mapIdEnv markDangerousToDup final_usage,
599 foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
601 (binders,body) = collectValBinders expr
602 (body_usage, body') = occAnal (env `addNewCands` binders) body
603 (final_usage, tagged_binders) = tagBinders body_usage binders
605 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
606 occAnal env (Lam (TyBinder tyvar) body)
607 = case occAnal env body of { (body_usage, body') ->
608 (mapIdEnv markDangerousToDup body_usage,
609 Lam (TyBinder tyvar) body') }
611 -- (body_usage, body') = occAnal env body
613 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
615 occAnal env (Case scrut alts)
616 = case occAnalAlts env alts of { (alts_usage, alts') ->
617 case occAnal env scrut of { (scrut_usage, scrut') ->
619 det = scrut_usage `combineUsageDetails` alts_usage
621 if isNullIdEnv det then
622 (det, Case scrut' alts')
624 (det, Case scrut' alts') }}
626 (scrut_usage `combineUsageDetails` alts_usage,
629 (scrut_usage, scrut') = occAnal env scrut
630 (alts_usage, alts') = occAnalAlts env alts
633 occAnal env (Let bind body)
634 = case occAnal new_env body of { (body_usage, body') ->
635 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
636 (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh)
638 new_env = env `addNewCands` (bindersOf bind)
639 -- (body_usage, body') = occAnal new_env body
640 -- (final_usage, new_binds) = occAnalBind env bind body_usage
646 occAnalAlts env (AlgAlts alts deflt)
647 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
648 -- Note: combine*Alts*UsageDetails...
649 AlgAlts alts' deflt')
651 (alts_usage, alts') = unzip (map do_alt alts)
652 (deflt_usage, deflt') = occAnalDeflt env deflt
654 do_alt (con, args, rhs)
655 = (final_usage, (con, tagged_args, rhs'))
657 new_env = env `addNewCands` args
658 (rhs_usage, rhs') = occAnal new_env rhs
659 (final_usage, tagged_args) = tagBinders rhs_usage args
661 occAnalAlts env (PrimAlts alts deflt)
662 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
663 -- Note: combine*Alts*UsageDetails...
664 PrimAlts alts' deflt')
666 (alts_usage, alts') = unzip (map do_alt alts)
667 (deflt_usage, deflt') = occAnalDeflt env deflt
670 = (rhs_usage, (lit, rhs'))
672 (rhs_usage, rhs') = occAnal env rhs
674 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
676 occAnalDeflt env (BindDefault binder rhs)
677 = (final_usage, BindDefault tagged_binder rhs')
679 new_env = env `addNewCand` binder
680 (rhs_usage, rhs') = occAnal new_env rhs
681 (final_usage, tagged_binder) = tagBinder rhs_usage binder
688 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
690 occAnalArgs env atoms
691 = foldr do_one_atom emptyDetails atoms
693 do_one_atom (VarArg v) usage
694 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
696 do_one_atom other_arg usage = usage
699 occAnalArg :: OccEnv -> CoreArg -> UsageDetails
701 occAnalArg env (VarArg v)
702 | isCandidate env v = unitDetails v (argOccurrence 0)
703 | otherwise = emptyDetails
704 occAnalArg _ _ = emptyDetails