2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 %************************************************************************
6 \section[OccurAnal]{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 for
60 type-lambdas too, which effectively prevents such substitutions. I don't *think*
61 it disables any interesting ones either.
64 #include "HsVersions.h"
67 occurAnalyseBinds, occurAnalyseExpr, occurAnalyseGlobalExpr,
69 -- and to make the interface self-sufficient...
70 CoreExpr, CoreBinding, Id, BinderInfo, GlobalSwitch,
71 PlainCoreProgram(..), PlainCoreExpr(..),
72 SimplifiableCoreExpr(..), SimplifiableCoreBinding(..)
76 import Outputable -- ToDo: rm; debugging
79 import PlainCore -- the stuff we read...
80 import TaggedCore -- ... and produce Simplifiable*
84 import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) )
85 import Digraph ( stronglyConnComp )
86 import Id ( eqId, idWantsToBeINLINEd, isConstMethodId,
87 isSpecPragmaId_maybe, SpecInfo )
95 %************************************************************************
97 \subsection[OccurAnal-types]{Data types}
99 %************************************************************************
103 Bool -- Keep-unused-bindings flag
104 -- False <=> OK to chuck away binding
105 -- and ignore occurrences within it
106 Bool -- Keep-spec-pragma-ids flag
107 -- False <=> OK to chuck away spec pragma bindings
108 -- and ignore occurrences within it
109 Bool -- Keep-conjurable flag
110 -- False <=> OK to throw away *dead*
111 -- "conjurable" Ids; at the moment, that
112 -- *only* means constant methods, which
113 -- are top-level. A use of a "conjurable"
114 -- Id may appear out of thin air -- e.g.,
115 -- specialiser conjuring up refs to const
117 Bool -- IgnoreINLINEPragma flag
118 -- False <=> OK to use INLINEPragma information
119 -- True <=> ignore INLINEPragma information
120 (UniqSet Id) -- Candidates
122 addNewCands :: OccEnv -> [Id] -> OccEnv
123 addNewCands (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) ids
124 = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` mkUniqSet ids)
126 addNewCand :: OccEnv -> Id -> OccEnv
127 addNewCand (OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma cands) id
128 = OccEnv keep_dead keep_spec keep_conjurable ignore_inline_pragma (cands `unionUniqSets` singletonUniqSet id)
130 isCandidate :: OccEnv -> Id -> Bool
131 isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
133 ignoreINLINEPragma :: OccEnv -> Bool
134 ignoreINLINEPragma (OccEnv _ _ _ ignore_inline_pragma _) = ignore_inline_pragma
136 keepUnusedBinding :: OccEnv -> Id -> Bool
137 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
138 = keep_dead || (keep_spec && is_spec)
140 is_spec = maybeToBool (isSpecPragmaId_maybe binder)
142 keepBecauseConjurable :: OccEnv -> Id -> Bool
143 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
144 = keep_conjurable && is_conjurable
146 is_conjurable = isConstMethodId binder
148 type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
150 combineUsageDetails, combineAltsUsageDetails
151 :: UsageDetails -> UsageDetails -> UsageDetails
153 combineUsageDetails usage1 usage2
154 = --BSCC("combineUsages")
155 combineIdEnvs combineBinderInfo usage1 usage2
158 combineAltsUsageDetails usage1 usage2
159 = --BSCC("combineUsages")
160 combineIdEnvs combineAltsBinderInfo usage1 usage2
163 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
164 addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
165 -- ToDo: make this more efficient
167 emptyDetails = (nullIdEnv :: UsageDetails)
169 unitDetails id info = (unitIdEnv id info :: UsageDetails)
171 tagBinders :: UsageDetails -- Of scope
173 -> (UsageDetails, -- Details with binders removed
174 [(Id,BinderInfo)]) -- Tagged binders
176 tagBinders usage binders
177 = (usage `delManyFromIdEnv` binders,
178 [(binder, usage_of usage binder) | binder <- binders]
181 tagBinder :: UsageDetails -- Of scope
183 -> (UsageDetails, -- Details with binders removed
184 (Id,BinderInfo)) -- Tagged binders
186 tagBinder usage binder
187 = (usage `delOneFromIdEnv` binder,
188 (binder, usage_of usage binder)
191 usage_of usage binder
192 | isExported binder = ManyOcc 0 -- Exported things count as many
194 = case lookupIdEnv usage binder of
198 isNeeded env usage binder
199 = case usage_of usage binder of
200 DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
205 %************************************************************************
207 \subsection[OccurAnal-main]{Counting occurrences: main function}
209 %************************************************************************
211 Here's the externally-callable interface:
215 :: [PlainCoreBinding] -- input
216 -> (GlobalSwitch -> Bool)
217 -> (SimplifierSwitch -> Bool)
218 -> [SimplifiableCoreBinding] -- output
220 occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
221 | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds'
224 (_, binds') = do initial_env binds
226 initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
227 (simplifier_sw_chkr KeepSpecPragmaIds)
228 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
229 (simplifier_sw_chkr IgnoreINLINEPragma)
232 do env [] = (emptyDetails, [])
234 = (final_usage, new_binds ++ the_rest)
236 new_env = env `addNewCands` (bindersOf bind)
237 (binds_usage, the_rest) = do new_env binds
238 (final_usage, new_binds) = --BSCC("occAnalBind1")
239 occAnalBind env bind binds_usage
244 occurAnalyseExpr :: UniqSet Id -- Set of interesting free vars
246 -> (IdEnv BinderInfo, -- Occ info for interesting free vars
247 SimplifiableCoreExpr)
249 occurAnalyseExpr candidates 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 -}
258 occurAnalyseGlobalExpr :: PlainCoreExpr -> SimplifiableCoreExpr
259 occurAnalyseGlobalExpr expr
260 = -- Top level expr, so no interesting free vars, and
261 -- discard occurence info returned
262 expr' where (_, expr') = occurAnalyseExpr emptyUniqSet expr
265 %************************************************************************
267 \subsection[OccurAnal-main]{Counting occurrences: main function}
269 %************************************************************************
275 occAnalBind :: OccEnv
277 -> UsageDetails -- Usage details of scope
278 -> (UsageDetails, -- Of the whole let(rec)
279 [SimplifiableCoreBinding])
281 occAnalBind env (CoNonRec binder rhs) body_usage
282 | isNeeded env body_usage binder -- It's mentioned in body
283 = (final_body_usage `combineUsageDetails` rhs_usage,
284 [CoNonRec tagged_binder rhs'])
290 (rhs_usage, rhs') = occAnalRhs env binder rhs
291 (final_body_usage, tagged_binder) = tagBinder body_usage binder
294 Dropping dead code for recursive bindings is done in a very simple way:
296 the entire set of bindings is dropped if none of its binders are
297 mentioned in its body; otherwise none are.
299 This seems to miss an obvious improvement.
314 Now @f@ is unused. But dependency analysis will sort this out into a
315 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
316 It isn't easy to do a perfect job in one blow. Consider
330 occAnalBind env (CoRec pairs) body_usage
331 = foldr do_final_bind (body_usage, []) sccs
334 (binders, rhss) = unzip pairs
335 new_env = env `addNewCands` binders
337 analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
338 analysed_pairs = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
340 lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
341 lookup id = assoc "occAnalBind:lookup" analysed_pairs id
344 ---- stuff for dependency analysis of binds -------------------------------
346 edges :: [(Id,Id)] -- (a,b) means a mentions b
347 edges = concat [ edges_from binder rhs_usage
348 | (binder, (rhs_usage, _)) <- analysed_pairs]
350 edges_from :: Id -> UsageDetails -> [(Id,Id)]
351 edges_from id its_rhs_usage
352 = [(id,mentioned) | mentioned <- binders,
353 maybeToBool (lookupIdEnv its_rhs_usage mentioned)
357 sccs = case binders of
358 [_] -> [binders] -- Singleton; no need to analyse
359 other -> stronglyConnComp eqId edges binders
361 ---- stuff to "re-constitute" bindings from dependency-analysis info ------
363 do_final_bind sCC@[binder] (body_usage, binds_so_far)
364 | isNeeded env body_usage binder
365 = (combined_usage, new_bind:binds_so_far)
368 = (body_usage, binds_so_far)
370 total_usage = combineUsageDetails body_usage rhs_usage
371 (rhs_usage, rhs') = lookup binder
372 (combined_usage, tagged_binder) = tagBinder total_usage binder
375 | mentions_itself binder rhs_usage = CoRec [(tagged_binder,rhs')]
376 | otherwise = CoNonRec tagged_binder rhs'
378 mentions_itself binder usage
379 = maybeToBool (lookupIdEnv usage binder)
381 do_final_bind sCC (body_usage, binds_so_far)
382 | any (isNeeded env body_usage) sCC
383 = (combined_usage, new_bind:binds_so_far)
386 = (body_usage, binds_so_far)
388 (rhs_usages, rhss') = unzip (map lookup sCC)
389 total_usage = foldr combineUsageDetails body_usage rhs_usages
390 (combined_usage, tagged_binders) = tagBinders total_usage sCC
392 new_bind = CoRec (tagged_binders `zip` rhss')
395 @occAnalRhs@ deals with the question of bindings where the Id is marked
396 by an INLINE pragma. For these we record that anything which occurs
397 in its RHS occurs many times. This pessimistically assumes that ths
398 inlined binder also occurs many times in its scope, but if it doesn't
399 we'll catch it next time round. At worst this costs an extra simplifier pass.
400 ToDo: try using the occurrence info for the inline'd binder.
405 -> PlainCoreExpr -- Rhs
406 -> (UsageDetails, SimplifiableCoreExpr)
408 occAnalRhs env id rhs
409 | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
410 = (mapIdEnv markMany rhs_usage, rhs')
416 (rhs_usage, rhs') = occAnal env rhs
424 -> (UsageDetails, -- Gives info only about the "interesting" Ids
425 SimplifiableCoreExpr)
427 occAnal env (CoVar v)
429 = (unitIdEnv v (funOccurrence 0), CoVar v)
432 = (emptyDetails, CoVar v)
434 occAnal env (CoLit lit) = (emptyDetails, CoLit lit)
435 occAnal env (CoCon con tys args) = (occAnalAtoms env args, CoCon con tys args)
436 occAnal env (CoPrim op tys args) = (occAnalAtoms env args, CoPrim op tys args)
438 occAnal env (CoSCC cc body)
439 = (mapIdEnv markInsideSCC usage, CoSCC cc body')
441 (usage, body') = occAnal env body
443 occAnal env (CoApp fun arg)
444 = (fun_usage `combineUsageDetails` arg_usage, CoApp fun' arg)
446 (fun_usage, fun') = occAnal env fun
447 arg_usage = occAnalAtom env arg
449 occAnal env (CoTyApp fun ty)
450 = (fun_usage, CoTyApp fun' ty)
452 (fun_usage, fun') = occAnal env fun
454 occAnal env (CoLam binders body)
455 = (mapIdEnv markDangerousToDup final_usage, mkCoLam tagged_binders body')
457 new_env = env `addNewCands` binders
458 (body_usage, body') = occAnal new_env body
459 (final_usage, tagged_binders) = tagBinders body_usage binders
461 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
462 occAnal env (CoTyLam tyvar body)
463 = (mapIdEnv markDangerousToDup body_usage, CoTyLam tyvar body')
465 (body_usage, body') = occAnal env body
467 occAnal env (CoCase scrut alts)
468 = (scrut_usage `combineUsageDetails` alts_usage,
471 (scrut_usage, scrut') = occAnal env scrut
472 (alts_usage, alts') = occAnalAlts env alts
474 occAnal env (CoLet bind body)
475 = (final_usage, foldr CoLet body' new_binds) -- mkCoLet* wants PlainCore... (sigh)
477 new_env = env `addNewCands` (bindersOf bind)
478 (body_usage, body') = occAnal new_env body
479 (final_usage, new_binds) = --BSCC("occAnalBind2")
480 occAnalBind env bind body_usage
487 occAnalAlts env (CoAlgAlts alts deflt)
488 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
489 -- Note: combine*Alts*UsageDetails...
490 CoAlgAlts alts' deflt')
492 (alts_usage, alts') = unzip (map do_alt alts)
493 (deflt_usage, deflt') = occAnalDeflt env deflt
495 do_alt (con, args, rhs)
496 = (final_usage, (con, tagged_args, rhs'))
498 new_env = env `addNewCands` args
499 (rhs_usage, rhs') = occAnal new_env rhs
500 (final_usage, tagged_args) = tagBinders rhs_usage args
502 occAnalAlts env (CoPrimAlts alts deflt)
503 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
504 -- Note: combine*Alts*UsageDetails...
505 CoPrimAlts alts' deflt')
507 (alts_usage, alts') = unzip (map do_alt alts)
508 (deflt_usage, deflt') = occAnalDeflt env deflt
511 = (rhs_usage, (lit, rhs'))
513 (rhs_usage, rhs') = occAnal env rhs
515 occAnalDeflt env CoNoDefault = (emptyDetails, CoNoDefault)
517 occAnalDeflt env (CoBindDefault binder rhs)
518 = (final_usage, CoBindDefault tagged_binder rhs')
520 new_env = env `addNewCand` binder
521 (rhs_usage, rhs') = occAnal new_env rhs
522 (final_usage, tagged_binder) = tagBinder rhs_usage binder
529 occAnalAtoms :: OccEnv -> [PlainCoreAtom] -> UsageDetails
531 occAnalAtoms env atoms
532 = foldr do_one_atom emptyDetails atoms
534 do_one_atom (CoLitAtom lit) usage = usage
535 do_one_atom (CoVarAtom v) usage
536 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
540 occAnalAtom :: OccEnv -> PlainCoreAtom -> UsageDetails
542 occAnalAtom env (CoLitAtom lit) = emptyDetails
543 occAnalAtom env (CoVarAtom v)
544 | isCandidate env v = unitDetails v (argOccurrence 0)
545 | otherwise = emptyDetails