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),
29 emptyIdSet, unionIdSets, mkIdSet,
30 unitIdSet, elementOfIdSet,
31 addOneToIdSet, SYN_IE(IdSet),
32 nullIdEnv, unitIdEnv, combineIdEnvs,
33 delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
34 mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
37 import Name ( isExported, isLocallyDefined )
38 import Type ( getFunTy_maybe, splitForAllTy )
39 import Maybes ( maybeToBool )
40 import Outputable ( PprStyle(..), Outputable(..){-instance * (,) -} )
42 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
43 import Pretty ( Doc, vcat, ptext, nest, punctuate, comma, hcat, text )
44 import TyVar ( GenTyVar{-instance Eq-} )
45 import Unique ( Unique{-instance Eq-}, u2i )
46 import UniqFM ( keysUFM )
47 import Util ( assoc, zipEqual, zipWithEqual, Ord3(..)
54 isSpecPragmaId_maybe x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
58 %************************************************************************
60 \subsection[OccurAnal-types]{Data types}
62 %************************************************************************
67 Bool -- Keep-unused-bindings flag
68 -- False <=> OK to chuck away binding
69 -- and ignore occurrences within it
70 Bool -- Keep-spec-pragma-ids flag
71 -- False <=> OK to chuck away spec pragma bindings
72 -- and ignore occurrences within it
73 Bool -- Keep-conjurable flag
74 -- False <=> OK to throw away *dead*
75 -- "conjurable" Ids; at the moment, that
76 -- *only* means constant methods, which
77 -- are top-level. A use of a "conjurable"
78 -- Id may appear out of thin air -- e.g.,
79 -- specialiser conjuring up refs to const methods.
80 Bool -- IgnoreINLINEPragma flag
81 -- False <=> OK to use INLINEPragma information
82 -- True <=> ignore INLINEPragma information
84 (Id -> IdSet -> Bool) -- Tells whether an Id occurrence is interesting,
85 -- given the set of in-scope variables
90 addNewCands :: OccEnv -> [Id] -> OccEnv
91 addNewCands (OccEnv kd ks kc ip ifun cands) ids
92 = OccEnv kd ks kc ip ifun (cands `unionIdSets` mkIdSet ids)
94 addNewCand :: OccEnv -> Id -> OccEnv
95 addNewCand (OccEnv ks kd kc ip ifun cands) id
96 = OccEnv kd ks kc ip ifun (addOneToIdSet cands id)
98 isCandidate :: OccEnv -> Id -> Bool
99 isCandidate (OccEnv _ _ _ _ ifun cands) id = ifun id cands
101 inlineMe :: OccEnv -> Id -> Bool
103 = {- See comments with simplIdWantsToBeINLINEd in SimplUtils.lhs
104 not ignore_inline_prag &&
106 idWantsToBeINLINEd id
108 keepUnusedBinding :: OccEnv -> Id -> Bool
109 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _ _) binder
110 = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
112 keepBecauseConjurable :: OccEnv -> Id -> Bool
113 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 if isDeadOcc us then -- Ditto
177 usage_of usage binder
178 | isExported binder = noBinderInfo -- Visible-elsewhere things count as many
180 = case (lookupIdEnv usage binder) of
181 Nothing -> deadOccurrence
184 isNeeded env usage binder
185 = if isDeadOcc (usage_of usage binder) then
186 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.
431 My solution was to make a=b bindings record b as Many, rather like INLINE bindings.
432 Perhaps something cleverer would suffice.
434 You might think that you can prevent non-termination simply by making
435 sure that we simplify a recursive binding's RHS in an environment that
436 simply clones the recursive Id. But no. Consider
438 letrec f = \x -> let z = f x' in ...
445 We bind n to its *simplified* RHS, we then *re-simplify* it when
446 we inline n. Then we may well inline f; and then the same thing
449 I don't think it's possible to prevent non-termination by environment
450 manipulation in this way. Apart from anything else, successive
451 iterations of the simplifier may unroll recursive loops in cases like
452 that above. The idea of beaking every recursive loop with an
453 IMustNotBeINLINEd pragma is much much better.
459 -> SCC (Node Details2)
461 -- Sorted into a plausible order. Enough of the Ids have
462 -- dontINLINE pragmas that there are no loops left.
464 -- Non-recursive case
465 reOrderRec env (AcyclicSCC (pair, _, _)) = [pair]
467 -- Common case of simple self-recursion
468 reOrderRec env (CyclicSCC [bind])
469 = [((addNoInlinePragma bndr, occ_info), rhs)]
471 (((bndr,occ_info), rhs), _, _) = bind
473 reOrderRec env (CyclicSCC binds)
474 = -- Choose a loop breaker, mark it no-inline,
475 -- do SCC analysis on the rest, and recursively sort them out
476 concat (map (reOrderRec env) (stronglyConnCompR unchosen))
478 [((addNoInlinePragma bndr, occ_info), rhs)]
481 (chosen_pair, unchosen) = choose_loop_breaker binds
482 ((bndr,occ_info), rhs) = chosen_pair
484 -- Choosing the loop breaker; heursitic
485 choose_loop_breaker (bind@(pair, _, _) : rest)
488 = (chosen, bind : unchosen) -- Don't pick it
489 | otherwise -- Pick it
492 (chosen, unchosen) = choose_loop_breaker rest
494 bad_choice ((bndr, occ_info), rhs)
495 = var_rhs rhs -- Dont pick var RHS
496 || inlineMe env bndr -- Dont pick INLINE thing
497 || isOneFunOcc occ_info -- Dont pick single-occ thing
498 || not_fun_ty (idType bndr) -- Dont pick data-ty thing
500 -- isOneFunOcc looks for one textual occurrence, whether inside lambda or whatever.
501 -- We stick to just FunOccs because if we're not going to be able
502 -- to inline the thing on this round it might be better to pick
503 -- this one as the loop breaker. Real example (the Enum Ordering instance
505 -- rec f = \ x -> case d of (p,q,r) -> p x
506 -- g = \ x -> case d of (p,q,r) -> q x
509 -- Here, f and g occur just once; but we can't inline them into d.
510 -- On the other hand we *could* simplify those case expressions if
511 -- we didn't stupidly choose d as the loop breaker.
513 not_fun_ty ty = not (maybeToBool (getFunTy_maybe rho_ty))
515 (_, rho_ty) = splitForAllTy ty
518 var_rhs (Var v) = True
519 var_rhs other_rhs = False
522 @occAnalRhs@ deals with the question of bindings where the Id is marked
523 by an INLINE pragma. For these we record that anything which occurs
524 in its RHS occurs many times. This pessimistically assumes that ths
525 inlined binder also occurs many times in its scope, but if it doesn't
526 we'll catch it next time round. At worst this costs an extra simplifier pass.
527 ToDo: try using the occurrence info for the inline'd binder.
529 [March 97] We do the same for atomic RHSs. Reason: see notes with reOrderRec.
533 -> Id -> CoreExpr -- Binder and rhs
534 -> (UsageDetails, SimplifiableCoreExpr)
536 occAnalRhs env id (Var v)
538 = (unitIdEnv v (markMany (funOccurrence 0)), Var v)
541 = (emptyDetails, Var v)
543 occAnalRhs env id rhs
545 = (mapIdEnv markMany rhs_usage, rhs')
551 (rhs_usage, rhs') = occAnal env rhs
559 -> (UsageDetails, -- Gives info only about the "interesting" Ids
560 SimplifiableCoreExpr)
564 = (unitIdEnv v (funOccurrence 0), Var v)
567 = (emptyDetails, Var v)
569 occAnal env (Lit lit) = (emptyDetails, Lit lit)
570 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
573 We regard variables that occur as constructor arguments as "dangerousToDup":
577 f x = let y = expensive x in
579 (case z of {(p,q)->q}, case z of {(p,q)->q})
582 We feel free to duplicate the WHNF (True,y), but that means
583 that y may be duplicated thereby.
585 If we aren't careful we duplicate the (expensive x) call!
586 Constructors are rather like lambdas in this way.
589 occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
592 occAnal env (SCC cc body)
593 = (mapIdEnv markInsideSCC usage, SCC cc body')
595 (usage, body') = occAnal env body
597 occAnal env (Coerce c ty body)
598 = (usage, Coerce c ty body')
600 (usage, body') = occAnal env body
602 occAnal env (App fun arg)
603 = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
605 (fun_usage, fun') = occAnal env fun
606 arg_usage = occAnalArg env arg
608 -- For value lambdas we do a special hack. Consider
610 -- If we did nothing, x is used inside the \y, so would be marked
611 -- as dangerous to dup. But in the common case where the abstraction
612 -- is applied to two arguments this is over-pessimistic.
613 -- So instead we don't take account of the \y when dealing with x's usage;
614 -- instead, the simplifier is careful when partially applying lambdas
616 occAnal env expr@(Lam (ValBinder binder) body)
617 = (mapIdEnv markDangerousToDup final_usage,
618 foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
620 (binders,body) = collectValBinders expr
621 (body_usage, body') = occAnal (env `addNewCands` binders) body
622 (final_usage, tagged_binders) = tagBinders body_usage binders
624 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
625 occAnal env (Lam (TyBinder tyvar) body)
626 = case occAnal env body of { (body_usage, body') ->
627 (mapIdEnv markDangerousToDup body_usage,
628 Lam (TyBinder tyvar) body') }
630 -- (body_usage, body') = occAnal env body
632 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
634 occAnal env (Case scrut alts)
635 = case occAnalAlts env alts of { (alts_usage, alts') ->
636 case occAnal env scrut of { (scrut_usage, scrut') ->
638 det = scrut_usage `combineUsageDetails` alts_usage
640 if isNullIdEnv det then
641 (det, Case scrut' alts')
643 (det, Case scrut' alts') }}
645 (scrut_usage `combineUsageDetails` alts_usage,
648 (scrut_usage, scrut') = occAnal env scrut
649 (alts_usage, alts') = occAnalAlts env alts
652 occAnal env (Let bind body)
653 = case occAnal new_env body of { (body_usage, body') ->
654 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
655 (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh)
657 new_env = env `addNewCands` (bindersOf bind)
658 -- (body_usage, body') = occAnal new_env body
659 -- (final_usage, new_binds) = occAnalBind env bind body_usage
665 occAnalAlts env (AlgAlts alts deflt)
666 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
667 -- Note: combine*Alts*UsageDetails...
668 AlgAlts alts' deflt')
670 (alts_usage, alts') = unzip (map do_alt alts)
671 (deflt_usage, deflt') = occAnalDeflt env deflt
673 do_alt (con, args, rhs)
674 = (final_usage, (con, tagged_args, rhs'))
676 new_env = env `addNewCands` args
677 (rhs_usage, rhs') = occAnal new_env rhs
678 (final_usage, tagged_args) = tagBinders rhs_usage args
680 occAnalAlts env (PrimAlts alts deflt)
681 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
682 -- Note: combine*Alts*UsageDetails...
683 PrimAlts alts' deflt')
685 (alts_usage, alts') = unzip (map do_alt alts)
686 (deflt_usage, deflt') = occAnalDeflt env deflt
689 = (rhs_usage, (lit, rhs'))
691 (rhs_usage, rhs') = occAnal env rhs
693 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
695 occAnalDeflt env (BindDefault binder rhs)
696 = (final_usage, BindDefault tagged_binder rhs')
698 new_env = env `addNewCand` binder
699 (rhs_usage, rhs') = occAnal new_env rhs
700 (final_usage, tagged_binder) = tagBinder rhs_usage binder
707 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
709 occAnalArgs env atoms
710 = foldr do_one_atom emptyDetails atoms
712 do_one_atom (VarArg v) usage
713 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
715 do_one_atom other_arg usage = usage
718 occAnalArg :: OccEnv -> CoreArg -> UsageDetails
720 occAnalArg env (VarArg v)
721 | isCandidate env v = unitDetails v (argOccurrence 0)
722 | otherwise = emptyDetails
723 occAnalArg _ _ = emptyDetails