2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 %************************************************************************
6 \section[NewOccurAnal]{The *New* Occurrence analysis pass}
8 %************************************************************************
10 The occurrence analyser analyses the way in which variables are used
11 in their scope, and pins that information on the binder. It does {\em
12 not} take any strategic decisions about what to do as a result (eg
13 discard binding, inline binding etc). That's the job of the
16 The occurrence analyser {\em simply} records usage information. That is,
17 it pins on each binder info on how that binder occurs in its scope.
19 Any uses within the RHS of a let(rec) binding for a variable which is
20 itself unused are ignored. For example:
27 Here, y is unused, so x will be marked as appearing just once.
29 An exported Id gets tagged as ManyOcc.
31 IT MUST OBSERVE SCOPING: CANNOT assume unique binders.
35 The occurrence analyser marks each binder in a lambda the same way.
38 will have both x and y marked as single occurrence, and *not* dangerous-to-dup.
39 Technically, x occurs inside a lambda, and therefore *is* dangerous-to-dup,
40 but the simplifer very carefully takes care of this special case.
41 (See the CoLam case in simplExpr.)
43 Why? Because typically applications are saturated, in which case x is *not*
49 There *is* a reason not to substitute for
50 variables applied to types: it can undo the effect of floating
54 f = /\b -> let d = c b
57 Here, inlining c would be a Bad Idea.
59 At present I've set it up so that the "inside-lambda" flag sets set On
60 for type-lambdas too, which effectively prevents such substitutions.
61 I don't *think* it disables any interesting ones either.
66 let { (u6.sAMi, <1,0>) = (_build s141374) ua.sALY } in
69 /\ s141380 -> \ (u5.sAM1, <2,0>) (u6.sAMl, <2,0>) ->
73 let { (u8.sAM3, <3,0>) = f.sALV u7.sAM2
75 } in ((foldr s141374) s141380) u9.sAM7 u6.sAMl u6.sAMi
76 } in (_build s141376) ua.sAMj]
78 I want to `inline' u6.sAMi, via the foldr/build rule,
79 but I cant. So I need to inline through /\. I only do it when
80 I've got a `linear' stack, ie actually real arguments still to apply.
83 #include "HsVersions.h"
86 newOccurAnalyseBinds, newOccurAnalyseExpr,
88 -- and to make the interface self-sufficient...
89 CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch,
90 PlainCoreProgram(..), PlainCoreExpr(..),
91 SimplifiableCoreExpr(..), SimplifiableCoreBinding(..)
95 import Outputable -- ToDo: rm; debugging
98 import PlainCore -- the stuff we read...
99 import TaggedCore -- ... and produce Simplifiable*
103 import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) )
104 import Digraph ( stronglyConnComp )
105 import Id ( eqId, idWantsToBeINLINEd, isConstMethodId,
106 isSpecPragmaId_maybe, getIdArgUsageInfo,
109 import IdInfo -- ( ArgUsage(..), ArgUsageInfo, OptIdInfo(..), getArgUsage)
117 %************************************************************************
119 \subsection[OccurAnal-types]{Data types}
121 %************************************************************************
125 Bool -- Keep-unused-bindings flag
126 -- False <=> OK to chuck away binding
127 -- and ignore occurrences within it
128 Bool -- Keep-spec-pragma-ids flag
129 -- False <=> OK to chuck away spec pragma bindings
130 -- and ignore occurrences within it
131 Bool -- Keep-conjurable flag
132 -- False <=> OK to throw away *dead*
133 -- "conjurable" Ids; at the moment, that
134 -- *only* means constant methods, which
135 -- are top-level. A use of a "conjurable"
136 -- Id may appear out of thin air -- e.g.,
137 -- specialiser conjuring up refs to const
139 Bool -- IgnoreINLINEPragma flag
140 -- False <=> OK to use INLINEPragma information
141 -- True <=> ignore INLINEPragma information
142 (UniqSet Id) -- Candidates
144 addNewCands :: OccEnv -> [Id] -> OccEnv
145 addNewCands (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids
146 = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids)
148 addNewCand :: OccEnv -> Id -> OccEnv
149 addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id
150 = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id)
152 isCandidate :: OccEnv -> Id -> Bool
153 isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
155 ignoreINLINEPragma :: OccEnv -> Bool
156 ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma
158 keepUnusedBinding :: OccEnv -> Id -> Bool
159 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
160 = keep_dead || (keep_spec && is_spec)
162 is_spec = maybeToBool (isSpecPragmaId_maybe binder)
164 keepBecauseConjurable :: OccEnv -> Id -> Bool
165 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
166 = keep_conjurable && is_conjurable
168 is_conjurable = isConstMethodId binder
170 type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
172 combineUsageDetails, combineAltsUsageDetails
173 :: UsageDetails -> UsageDetails -> UsageDetails
175 combineUsageDetails usage1 usage2
176 = --BSCC("combineUsages")
177 combineIdEnvs combineBinderInfo usage1 usage2
180 combineAltsUsageDetails usage1 usage2
181 = --BSCC("combineUsages")
182 combineIdEnvs combineAltsBinderInfo usage1 usage2
185 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
186 addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
187 -- ToDo: make this more efficient
189 emptyDetails = (nullIdEnv :: UsageDetails)
191 unitDetails id info = (unitIdEnv id info :: UsageDetails)
193 tagBinders :: UsageDetails -- Of scope
195 -> (UsageDetails, -- Details with binders removed
196 [(Id,BinderInfo)]) -- Tagged binders
198 tagBinders usage binders
199 = (usage `delManyFromIdEnv` binders,
200 [(binder, usage_of usage binder) | binder <- binders]
203 tagBinder :: UsageDetails -- Of scope
205 -> (UsageDetails, -- Details with binders removed
206 (Id,BinderInfo)) -- Tagged binders
208 tagBinder usage binder
209 = (usage `delOneFromIdEnv` binder,
210 (binder, usage_of usage binder)
213 usage_of usage binder
214 | isExported binder = ManyOcc 0 -- Exported things count as many
216 = case lookupIdEnv usage binder of
220 fixStkToZero :: Id -> UsageDetails -> UsageDetails
221 fixStkToZero id env = modifyIdEnv env setBinderInfoArityToZero id
223 isNeeded env usage binder
224 = case usage_of usage binder of
225 DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
230 %************************************************************************
232 \subsection[OccurAnal-main]{Counting occurrences: main function}
234 %************************************************************************
236 Here's the externally-callable interface:
240 :: [PlainCoreBinding] -- input
241 -> (GlobalSwitch -> Bool)
242 -> (SimplifierSwitch -> Bool)
243 -> [SimplifiableCoreBinding] -- output
245 newOccurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
246 | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds'
249 (_, binds') = do initial_env binds
251 initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
252 (simplifier_sw_chkr KeepSpecPragmaIds)
253 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
254 (simplifier_sw_chkr IgnoreINLINEPragma)
257 do env [] = (emptyDetails, [])
259 = (final_usage, new_binds ++ the_rest)
261 new_env = env `addNewCands` (bindersOf bind)
262 (binds_usage, the_rest) = do new_env binds
263 (final_usage, new_binds) = --BSCC("occAnalBind1")
264 occAnalBind env bind binds_usage
269 newOccurAnalyseExpr :: UniqSet Id -- Set of interesting free vars
271 -> (IdEnv BinderInfo, -- Occ info for interesting free vars
272 SimplifiableCoreExpr)
274 newOccurAnalyseExpr candidates expr
275 = occAnal initial_env initContext expr
277 initial_env = OccEnv False {- Drop unused bindings -}
278 False {- Drop SpecPragmaId bindings -}
279 True {- Keep conjurable Ids -}
280 False {- Do not ignore INLINE Pragma -}
283 newOccurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr
284 newOccurAnalyseGlobalExpr expr
285 = -- Top level expr, so no interesting free vars, and
286 -- discard occurence info returned
287 expr' where (_, expr') = newOccurAnalyseExpr emptyUniqSet expr
290 %************************************************************************
292 \subsection[OccurAnal-main]{Counting occurrences: main function}
294 %************************************************************************
300 occAnalBind :: OccEnv
302 -> UsageDetails -- Usage details of scope
303 -> (UsageDetails, -- Of the whole let(rec)
304 [SimplifiableCoreBinding])
306 occAnalBind env (CoNonRec binder rhs) body_usage
307 | isNeeded env body_usage binder -- It's mentioned in body
308 = (final_body_usage `combineUsageDetails` rhs_usage,
309 [CoNonRec tagged_binder rhs'])
315 stk = mkContextFromBinderInfo (usage_of body_usage binder)
316 (rhs_usage, rhs') = occAnalRhs env binder stk rhs
317 (final_body_usage, tagged_binder) = tagBinder body_usage binder
319 occAnalBind env (CoRec [(binder,rhs)]) body_usage
320 | getContextSize after_stk < getContextSize stk && mentions_itself
321 -- our pre-condition does not hold!
322 -- so, we have to go back, and
323 -- *make* of pre-condition hold.
324 -- Will, you can leave out this trace
325 = {-pprTrace ("after_stk < stk (BAD, BAD, VERY VERY BAD):"
326 ++ show (getContextSize after_stk,getContextSize stk)) (ppr PprDebug binder) -}
327 (occAnalBind env (CoRec [(binder,rhs)]) (fixStkToZero binder body_usage))
329 | isNeeded env body_usage binder -- It's mentioned in body
330 = --BSCC("occAnalBindC")
331 (final_usage, [final_bind])
335 = --BSCC("occAnalBindD")
340 stk = shareContext (mkContextFromBinderInfo (usage_of body_usage binder))
341 new_env = env `addNewCand` binder
342 (rhs_usage, rhs') = occAnalRhs new_env binder stk rhs
343 total_usage = combineUsageDetails body_usage rhs_usage
344 (final_usage, tagged_binder) = tagBinder total_usage binder
346 after_stk = mkContextFromBinderInfo (usage_of rhs_usage binder)
348 final_bind = if mentions_itself
349 then CoRec [(tagged_binder,rhs')]
350 else CoNonRec tagged_binder rhs'
352 mentions_itself = maybeToBool (lookupIdEnv rhs_usage binder)
355 Dropping dead code for recursive bindings is done in a very simple way:
357 the entire set of bindings is dropped if none of its binders are
358 mentioned in its body; otherwise none are.
360 This seems to miss an obvious improvement.
375 Now @f@ is unused. But dependency analysis will sort this out into a
376 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
377 It isn't easy to do a perfect job in one blow. Consider
391 occAnalBind env (CoRec pairs) body_usage
392 = foldr do_final_bind (body_usage, []) sccs
395 (binders, rhss) = unzip pairs
396 new_env = env `addNewCands` binders
398 analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
399 analysed_pairs = [(id, occAnalRhs new_env id initContext rhs) | (id,rhs) <- pairs]
401 lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
402 lookup id = assoc "occAnalBind:lookup" analysed_pairs id
405 ---- stuff for dependency analysis of binds -------------------------------
407 edges :: [(Id,Id)] -- (a,b) means a mentions b
408 edges = concat [ edges_from binder rhs_usage
409 | (binder, (rhs_usage, _)) <- analysed_pairs]
411 edges_from :: Id -> UsageDetails -> [(Id,Id)]
412 edges_from id its_rhs_usage
413 = [(id,mentioned) | mentioned <- binders,
414 maybeToBool (lookupIdEnv its_rhs_usage mentioned)
418 sccs = case binders of
419 [_] -> [binders] -- Singleton; no need to analyse
420 other -> stronglyConnComp eqId edges binders
422 ---- stuff to "re-constitute" bindings from dependency-analysis info ------
424 do_final_bind sCC@[binder] (body_usage, binds_so_far)
425 | isNeeded env body_usage binder
426 = (combined_usage, new_bind:binds_so_far)
429 = (body_usage, binds_so_far)
431 total_usage = combineUsageDetails body_usage rhs_usage
432 (rhs_usage, rhs') = lookup binder
433 (combined_usage, tagged_binder) = tagBinder total_usage binder
436 | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')]
437 | otherwise = CoNonRec tagged_binder rhs'
439 mentions_itself binder usage
440 = maybeToBool (lookupIdEnv usage binder)
442 do_final_bind sCC (body_usage, binds_so_far)
443 | any (isNeeded env body_usage) sCC
444 = (combined_usage, new_bind:binds_so_far)
447 = (body_usage, binds_so_far)
449 (rhs_usages, rhss') = unzip (map lookup sCC)
450 total_usage = foldr combineUsageDetails body_usage rhs_usages
451 (combined_usage, tagged_binders) = tagBinders total_usage sCC
453 new_bind = CoRec (tagged_binders `zip` rhss')
456 @occAnalRhs@ deals with the question of bindings where the Id is marked
457 by an INLINE pragma. For these we record that anything which occurs
458 in its RHS occurs many times. This pessimistically assumes that ths
459 inlined binder also occurs many times in its scope, but if it doesn't
460 we'll catch it next time round. At worst this costs an extra simplifier pass.
461 ToDo: try using the occurrence info for the inline'd binder.
466 -> Context -- Stack Style Context
467 -> PlainCoreExpr -- Rhs
468 -> (UsageDetails, SimplifiableCoreExpr)
470 occAnalRhs env id stk rhs
471 | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
472 = (mapIdEnv markMany rhs_usage, rhs')
478 (rhs_usage, rhs') = occAnal env stk rhs
487 -> (UsageDetails, -- Gives info only about the "interesting" Ids
488 SimplifiableCoreExpr)
490 occAnal env stk (CoVar v)
492 = (unitIdEnv v (funOccurrence (getContextSize stk)), CoVar v)
495 = (emptyDetails, CoVar v)
497 occAnal env _ (CoLit lit) = (emptyDetails, CoLit lit)
498 -- PERHAPS ASSERT THAT STACK == 0 ?
499 occAnal env _ (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args)
500 occAnal env _ (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args)
502 occAnal env stk (CoSCC lbl body)
503 = (mapIdEnv markInsideSCC usage, CoSCC lbl body')
505 (usage, body') = occAnal env initContext body
507 occAnal env stk (CoApp fun arg)
508 = occAnalApp env (incContext stk) [ValArg arg] fun
509 occAnal env stk (CoTyApp fun arg)
510 = occAnalApp env stk [TypeArg arg] fun
512 occAnal env (CoApp fun arg)
513 = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg)
515 (fun_usage, fun') = occAnal env fun
516 arg_usage = occAnalAtom env arg
518 occAnal env (CoTyApp fun ty)
519 = (fun_usage, CoTyApp fun' ty)
521 (fun_usage, fun') = occAnal env fun
523 occAnal env stk (CoLam binders body) | isLinContext stk
524 = (final_usage, mkCoLam tagged_binders body')
526 (lin_binders,other_binders) = splitAt (getContextSize stk) binders
527 new_env = env `addNewCands` lin_binders
528 (body_usage, body') = occAnal new_env (lamOnContext stk (length lin_binders))
529 (mkCoLam other_binders body)
530 (final_usage, tagged_binders) = tagBinders body_usage lin_binders
532 occAnal env stk (CoLam binders body)
533 = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
535 new_env = env `addNewCands` binders
536 (body_usage, body') = occAnal new_env (lamOnContext stk (length binders)) body
537 (final_usage, tagged_binders) = tagBinders body_usage binders
540 occAnal env (CoLam binders body)
541 = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
543 new_env = env `addNewCands` binders
544 (body_usage, body') = occAnal new_env body
545 (final_usage, tagged_binders) = tagBinders body_usage binders
548 occAnal env stk (CoTyLam tyvar body)
549 = (new_body_usage, CoTyLam tyvar body')
551 (body_usage, body') = occAnal env stk body
552 new_body_usage = if isLinContext stk
554 else mapIdEnv markDangerousToDup body_usage
556 occAnal env stk (CoCase scrut alts)
557 = (scrut_usage `combineUsageDetails` alts_usage,
560 (scrut_usage, scrut') = occAnal env initContext scrut
561 (alts_usage, alts') = occAnalAlts env stk alts
564 occAnal env stk (CoLet bind body)
565 = (final_usage , foldr CoLet body' new_binds) -- mkCoLets* wants PlainCore... (sigh)
567 new_env = env `addNewCands` (bindersOf bind)
568 (body_usage, body') = occAnal new_env stk {- ?? -} body
569 (final_usage, new_binds) = --BSCC("occAnalBind2")
570 occAnalBind env bind body_usage
577 occAnalAlts env stk (CoAlgAlts alts deflt)
578 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
579 -- Note: combine*Alts*UsageDetails...
580 CoAlgAlts alts' deflt')
582 (alts_usage, alts') = unzip (map do_alt alts)
583 (deflt_usage, deflt') = occAnalDeflt env stk deflt
585 do_alt (con, args, rhs)
586 = (final_usage, (con, tagged_args, rhs'))
588 new_env = env `addNewCands` args
589 (rhs_usage, rhs') = occAnal new_env stk rhs
590 (final_usage, tagged_args) = tagBinders rhs_usage args
592 occAnalAlts env stk (CoPrimAlts alts deflt)
593 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
594 -- Note: combine*Alts*UsageDetails...
595 CoPrimAlts alts' deflt')
597 (alts_usage, alts') = unzip (map do_alt alts)
598 (deflt_usage, deflt') = occAnalDeflt env stk deflt
601 = (rhs_usage, (lit, rhs'))
603 (rhs_usage, rhs') = occAnal env stk rhs
605 occAnalDeflt env stk CoNoDefault = (emptyDetails, CoNoDefault)
607 occAnalDeflt env stk (CoBindDefault binder rhs)
608 = (final_usage, CoBindDefault tagged_binder rhs')
610 new_env = env `addNewCand` binder
611 (rhs_usage, rhs') = occAnal new_env stk rhs
612 (final_usage, tagged_binder) = tagBinder rhs_usage binder
619 occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails
621 occAnalAtoms env atoms
622 = foldr do_one_atom emptyDetails atoms
624 do_one_atom (CoLitAtom lit) usage = usage
625 do_one_atom (CoVarAtom v) usage
626 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
630 occAnalArgAtoms :: OccEnv -> [(PlainCoreAtom,ArgUsage)] -> UsageDetails
631 occAnalArgAtoms env atoms
632 = foldr do_one_atom emptyDetails atoms
634 do_one_atom (CoLitAtom lit,_) usage = usage
635 do_one_atom (CoVarAtom v,ArgUsage ar) usage
636 | isCandidate env v = addOneOcc usage v (argOccurrence ar)
638 do_one_atom (CoVarAtom v,UnknownArgUsage) usage
639 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
642 occAnalAtom :: OccEnv -> PlainCoreAtom -> UsageDetails
644 occAnalAtom env (CoLitAtom lit) = emptyDetails
645 occAnalAtom env (CoVarAtom v)
646 | isCandidate env v = unitDetails v (argOccurrence 0)
647 | otherwise = emptyDetails
649 -- This function looks for (fully) applied calls to special ids.
656 -> (UsageDetails, -- Gives info only about the "interesting" Ids
657 SimplifiableCoreExpr)
658 occAnalApp env stk args fun@(CoVar v)
660 && getContextSize stk >= length aut -- fully applied
661 = (fun_usage `combineUsageDetails` arg_usages,
662 applyToArgs fun' args)
664 val_args = [ x | ValArg x <- args ]
665 aut = getArgUsage (getIdArgUsageInfo v)
666 (fun_usage, fun') = occAnal env stk fun
667 arg_usages = occAnalArgAtoms env (zip val_args aut)
668 occAnalApp env stk args (CoApp fun arg)
669 = occAnalApp env (incContext stk) (ValArg arg:args) fun
670 occAnalApp env stk args (CoTyApp fun arg)
671 = occAnalApp env stk (TypeArg arg:args) fun
672 occAnalApp env stk args fun
673 = (fun_usage `combineUsageDetails` arg_usages,
674 applyToArgs fun' args)
676 (fun_usage, fun') = occAnal env stk fun
677 arg_usages = occAnalAtoms env val_args
678 val_args = [ x | ValArg x <- args ]
681 %************************************************************************
683 \subsection[OccurAnal-main]{Counting occurrences: main function}
685 %************************************************************************
688 Abstract, but simple rep. for stacks.
690 data Context = Context Int Bool -- if b then n > 0
692 lamOnContext :: Context -> Int -> Context
693 lamOnContext (Context n b) i = mkContext (max 0 (n - i)) b
695 isLinContext :: Context -> Bool
696 isLinContext (Context n b) = b
698 getContextSize :: Context -> Int
699 getContextSize (Context n b) = n
701 incContext :: Context -> Context
702 incContext (Context n u) = Context (n + 1) u
704 initContext :: Context
705 initContext = Context 0 False
707 shareContext :: Context -> Context
708 shareContext (Context n u) = mkContext n False
710 mkContext :: Int -> Bool -> Context
711 mkContext 0 _ = Context 0 False
712 mkContext i b = Context i b
714 mkContextFromBinderInfo :: BinderInfo -> Context
715 mkContextFromBinderInfo (DeadCode) = mkContext 0 False
716 mkContextFromBinderInfo (ManyOcc i) = mkContext i False
717 mkContextFromBinderInfo bi@(OneOcc _ _ _ _ i)
718 = mkContext i (oneSafeOcc True bi)