2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
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
19 -- and to make the interface self-sufficient...
24 import CmdLineOpts ( GlobalSwitch(..), SimplifierSwitch(..) )
25 import Digraph ( stronglyConnComp )
26 import Id ( eqId, idWantsToBeINLINEd, isConstMethodId,
27 isSpecPragmaId_maybe, SpecInfo )
34 %************************************************************************
36 \subsection[OccurAnal-types]{Data types}
38 %************************************************************************
43 Bool -- Keep-unused-bindings flag
44 -- False <=> OK to chuck away binding
45 -- and ignore occurrences within it
46 Bool -- Keep-spec-pragma-ids flag
47 -- False <=> OK to chuck away spec pragma bindings
48 -- and ignore occurrences within it
49 Bool -- Keep-conjurable flag
50 -- False <=> OK to throw away *dead*
51 -- "conjurable" Ids; at the moment, that
52 -- *only* means constant methods, which
53 -- are top-level. A use of a "conjurable"
54 -- Id may appear out of thin air -- e.g.,
55 -- specialiser conjuring up refs to const methods.
56 Bool -- IgnoreINLINEPragma flag
57 -- False <=> OK to use INLINEPragma information
58 -- True <=> ignore INLINEPragma information
59 (UniqSet Id) -- Candidates
61 addNewCands :: OccEnv -> [Id] -> OccEnv
62 addNewCands (OccEnv kd ks kc ip cands) ids
63 = OccEnv kd ks kc ip (cands `unionUniqSets` mkUniqSet ids)
65 addNewCand :: OccEnv -> Id -> OccEnv
66 addNewCand (OccEnv ks kd kc ip cands) id
67 = OccEnv kd ks kc ip (cands `unionUniqSets` singletonUniqSet id)
69 isCandidate :: OccEnv -> Id -> Bool
70 isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfUniqSet` cands
72 ignoreINLINEPragma :: OccEnv -> Bool
73 ignoreINLINEPragma (OccEnv _ _ _ ip _) = ip
75 keepUnusedBinding :: OccEnv -> Id -> Bool
76 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
77 = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
79 keepBecauseConjurable :: OccEnv -> Id -> Bool
80 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
81 = keep_conjurable && isConstMethodId binder
83 type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
85 combineUsageDetails, combineAltsUsageDetails
86 :: UsageDetails -> UsageDetails -> UsageDetails
88 combineUsageDetails usage1 usage2
89 = --BSCC("combineUsages")
90 combineIdEnvs combineBinderInfo usage1 usage2
93 combineAltsUsageDetails usage1 usage2
94 = --BSCC("combineUsages")
95 combineIdEnvs combineAltsBinderInfo usage1 usage2
98 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
99 addOneOcc usage id info = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
100 -- ToDo: make this more efficient
102 emptyDetails = (nullIdEnv :: UsageDetails)
104 unitDetails id info = (unitIdEnv id info :: UsageDetails)
106 tagBinders :: UsageDetails -- Of scope
108 -> (UsageDetails, -- Details with binders removed
109 [(Id,BinderInfo)]) -- Tagged binders
111 tagBinders usage binders
112 = (usage `delManyFromIdEnv` binders,
113 [(binder, usage_of usage binder) | binder <- binders]
116 tagBinder :: UsageDetails -- Of scope
118 -> (UsageDetails, -- Details with binders removed
119 (Id,BinderInfo)) -- Tagged binders
121 tagBinder usage binder
122 = (usage `delOneFromIdEnv` binder,
123 (binder, usage_of usage binder)
126 usage_of usage binder
127 | isExported binder = ManyOcc 0 -- Exported things count as many
129 = case lookupIdEnv usage binder of
133 isNeeded env usage binder
134 = case usage_of usage binder of
135 DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
140 %************************************************************************
142 \subsection[OccurAnal-main]{Counting occurrences: main function}
144 %************************************************************************
146 Here's the externally-callable interface:
150 :: [CoreBinding] -- input
151 -> (GlobalSwitch -> Bool)
152 -> (SimplifierSwitch -> Bool)
153 -> [SimplifiableCoreBinding] -- output
155 occurAnalyseBinds binds global_sw_chkr simplifier_sw_chkr
156 | global_sw_chkr D_dump_occur_anal = pprTrace "OccurAnal:" (ppr PprDebug binds') binds'
159 (_, binds') = do initial_env binds
161 initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
162 (simplifier_sw_chkr KeepSpecPragmaIds)
163 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
164 (simplifier_sw_chkr IgnoreINLINEPragma)
167 do env [] = (emptyDetails, [])
169 = (final_usage, new_binds ++ the_rest)
171 new_env = env `addNewCands` (bindersOf bind)
172 (binds_usage, the_rest) = do new_env binds
173 (final_usage, new_binds) = --BSCC("occAnalBind1")
174 occAnalBind env bind binds_usage
179 occurAnalyseExpr :: UniqSet Id -- Set of interesting free vars
181 -> (IdEnv BinderInfo, -- Occ info for interesting free vars
182 SimplifiableCoreExpr)
184 occurAnalyseExpr candidates expr
185 = occAnal initial_env expr
187 initial_env = OccEnv False {- Drop unused bindings -}
188 False {- Drop SpecPragmaId bindings -}
189 True {- Keep conjurable Ids -}
190 False {- Do not ignore INLINE Pragma -}
193 occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
194 occurAnalyseGlobalExpr expr
195 = -- Top level expr, so no interesting free vars, and
196 -- discard occurence info returned
197 expr' where (_, expr') = occurAnalyseExpr emptyUniqSet expr
200 %************************************************************************
202 \subsection[OccurAnal-main]{Counting occurrences: main function}
204 %************************************************************************
210 occAnalBind :: OccEnv
212 -> UsageDetails -- Usage details of scope
213 -> (UsageDetails, -- Of the whole let(rec)
214 [SimplifiableCoreBinding])
216 occAnalBind env (NonRec binder rhs) body_usage
217 | isNeeded env body_usage binder -- It's mentioned in body
218 = (final_body_usage `combineUsageDetails` rhs_usage,
219 [NonRec tagged_binder rhs'])
225 (rhs_usage, rhs') = occAnalRhs env binder rhs
226 (final_body_usage, tagged_binder) = tagBinder body_usage binder
229 Dropping dead code for recursive bindings is done in a very simple way:
231 the entire set of bindings is dropped if none of its binders are
232 mentioned in its body; otherwise none are.
234 This seems to miss an obvious improvement.
249 Now @f@ is unused. But dependency analysis will sort this out into a
250 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
251 It isn't easy to do a perfect job in one blow. Consider
265 occAnalBind env (Rec pairs) body_usage
266 = foldr do_final_bind (body_usage, []) sccs
269 (binders, rhss) = unzip pairs
270 new_env = env `addNewCands` binders
272 analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
273 analysed_pairs = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
275 lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
276 lookup id = assoc "occAnalBind:lookup" analysed_pairs id
279 ---- stuff for dependency analysis of binds -------------------------------
281 edges :: [(Id,Id)] -- (a,b) means a mentions b
282 edges = concat [ edges_from binder rhs_usage
283 | (binder, (rhs_usage, _)) <- analysed_pairs]
285 edges_from :: Id -> UsageDetails -> [(Id,Id)]
286 edges_from id its_rhs_usage
287 = [(id,mentioned) | mentioned <- binders,
288 maybeToBool (lookupIdEnv its_rhs_usage mentioned)
292 sccs = case binders of
293 [_] -> [binders] -- Singleton; no need to analyse
294 other -> stronglyConnComp eqId edges binders
296 ---- stuff to "re-constitute" bindings from dependency-analysis info ------
298 do_final_bind sCC@[binder] (body_usage, binds_so_far)
299 | isNeeded env body_usage binder
300 = (combined_usage, new_bind:binds_so_far)
303 = (body_usage, binds_so_far)
305 total_usage = combineUsageDetails body_usage rhs_usage
306 (rhs_usage, rhs') = lookup binder
307 (combined_usage, tagged_binder) = tagBinder total_usage binder
310 | mentions_itself binder rhs_usage = Rec [(tagged_binder,rhs')]
311 | otherwise = NonRec tagged_binder rhs'
313 mentions_itself binder usage
314 = maybeToBool (lookupIdEnv usage binder)
316 do_final_bind sCC (body_usage, binds_so_far)
317 | any (isNeeded env body_usage) sCC
318 = (combined_usage, new_bind:binds_so_far)
321 = (body_usage, binds_so_far)
323 (rhs_usages, rhss') = unzip (map lookup sCC)
324 total_usage = foldr combineUsageDetails body_usage rhs_usages
325 (combined_usage, tagged_binders) = tagBinders total_usage sCC
327 new_bind = Rec (tagged_binders `zip` rhss')
330 @occAnalRhs@ deals with the question of bindings where the Id is marked
331 by an INLINE pragma. For these we record that anything which occurs
332 in its RHS occurs many times. This pessimistically assumes that ths
333 inlined binder also occurs many times in its scope, but if it doesn't
334 we'll catch it next time round. At worst this costs an extra simplifier pass.
335 ToDo: try using the occurrence info for the inline'd binder.
341 -> (UsageDetails, SimplifiableCoreExpr)
343 occAnalRhs env id rhs
344 | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
345 = (mapIdEnv markMany rhs_usage, rhs')
351 (rhs_usage, rhs') = occAnal env rhs
359 -> (UsageDetails, -- Gives info only about the "interesting" Ids
360 SimplifiableCoreExpr)
364 = (unitIdEnv v (funOccurrence 0), Var v)
367 = (emptyDetails, Var v)
369 occAnal env (Lit lit) = (emptyDetails, Lit lit)
370 occAnal env (Con con tys args) = (occAnalAtoms env args, Con con tys args)
371 occAnal env (Prim op tys args) = (occAnalAtoms env args, Prim op tys args)
373 occAnal env (SCC cc body)
374 = (mapIdEnv markInsideSCC usage, SCC cc body')
376 (usage, body') = occAnal env body
378 occAnal env (App fun arg)
379 = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
381 (fun_usage, fun') = occAnal env fun
382 arg_usage = occAnalAtom env arg
384 occAnal env (CoTyApp fun ty)
385 = (fun_usage, CoTyApp fun' ty)
387 (fun_usage, fun') = occAnal env fun
389 occAnal env (Lam binder body)
390 = (mapIdEnv markDangerousToDup final_usage, Lam tagged_binder body')
392 (body_usage, body') = occAnal (env `addNewCand` binder) body
393 (final_usage, tagged_binder) = tagBinder body_usage binder
395 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
396 occAnal env (CoTyLam tyvar body)
397 = (mapIdEnv markDangerousToDup body_usage, CoTyLam tyvar body')
399 (body_usage, body') = occAnal env body
401 occAnal env (Case scrut alts)
402 = (scrut_usage `combineUsageDetails` alts_usage,
405 (scrut_usage, scrut') = occAnal env scrut
406 (alts_usage, alts') = occAnalAlts env alts
408 occAnal env (Let bind body)
409 = (final_usage, foldr Let body' new_binds) -- mkCoLet* wants Core... (sigh)
411 new_env = env `addNewCands` (bindersOf bind)
412 (body_usage, body') = occAnal new_env body
413 (final_usage, new_binds) = --BSCC("occAnalBind2")
414 occAnalBind env bind body_usage
421 occAnalAlts env (AlgAlts alts deflt)
422 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
423 -- Note: combine*Alts*UsageDetails...
424 AlgAlts alts' deflt')
426 (alts_usage, alts') = unzip (map do_alt alts)
427 (deflt_usage, deflt') = occAnalDeflt env deflt
429 do_alt (con, args, rhs)
430 = (final_usage, (con, tagged_args, rhs'))
432 new_env = env `addNewCands` args
433 (rhs_usage, rhs') = occAnal new_env rhs
434 (final_usage, tagged_args) = tagBinders rhs_usage args
436 occAnalAlts env (PrimAlts alts deflt)
437 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
438 -- Note: combine*Alts*UsageDetails...
439 PrimAlts alts' deflt')
441 (alts_usage, alts') = unzip (map do_alt alts)
442 (deflt_usage, deflt') = occAnalDeflt env deflt
445 = (rhs_usage, (lit, rhs'))
447 (rhs_usage, rhs') = occAnal env rhs
449 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
451 occAnalDeflt env (BindDefault binder rhs)
452 = (final_usage, BindDefault tagged_binder rhs')
454 new_env = env `addNewCand` binder
455 (rhs_usage, rhs') = occAnal new_env rhs
456 (final_usage, tagged_binder) = tagBinder rhs_usage binder
463 occAnalAtoms :: OccEnv -> [CoreArg] -> UsageDetails
465 occAnalAtoms env atoms
466 = foldr do_one_atom emptyDetails atoms
468 do_one_atom (LitArg lit) usage = usage
469 do_one_atom (VarArg v) usage
470 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
474 occAnalAtom :: OccEnv -> CoreArg -> UsageDetails
476 occAnalAtom env (LitArg lit) = emptyDetails
477 occAnalAtom env (VarArg v)
478 | isCandidate env v = unitDetails v (argOccurrence 0)
479 | otherwise = emptyDetails