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
23 import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
25 import Digraph ( stronglyConnComp )
26 import Id ( idWantsToBeINLINEd, isConstMethodId,
27 emptyIdSet, unionIdSets, mkIdSet,
28 unitIdSet, elementOfIdSet,
29 addOneToIdSet, IdSet(..),
30 nullIdEnv, unitIdEnv, combineIdEnvs,
31 delOneFromIdEnv, delManyFromIdEnv,
32 mapIdEnv, lookupIdEnv, IdEnv(..),
35 import Maybes ( maybeToBool )
36 import Name ( isExported )
37 import Outputable ( Outputable(..){-instance * (,) -} )
39 import PprStyle ( PprStyle(..) )
40 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
41 import Pretty ( ppAboves )
42 import TyVar ( GenTyVar{-instance Eq-} )
43 import Unique ( Unique{-instance Eq-} )
44 import Util ( assoc, pprTrace, panic )
46 isSpecPragmaId_maybe = panic "OccurAnal.isSpecPragmaId_maybe (ToDo)"
50 %************************************************************************
52 \subsection[OccurAnal-types]{Data types}
54 %************************************************************************
59 Bool -- Keep-unused-bindings flag
60 -- False <=> OK to chuck away binding
61 -- and ignore occurrences within it
62 Bool -- Keep-spec-pragma-ids flag
63 -- False <=> OK to chuck away spec pragma bindings
64 -- and ignore occurrences within it
65 Bool -- Keep-conjurable flag
66 -- False <=> OK to throw away *dead*
67 -- "conjurable" Ids; at the moment, that
68 -- *only* means constant methods, which
69 -- are top-level. A use of a "conjurable"
70 -- Id may appear out of thin air -- e.g.,
71 -- specialiser conjuring up refs to const methods.
72 Bool -- IgnoreINLINEPragma flag
73 -- False <=> OK to use INLINEPragma information
74 -- True <=> ignore INLINEPragma information
77 addNewCands :: OccEnv -> [Id] -> OccEnv
78 addNewCands (OccEnv kd ks kc ip cands) ids
79 = OccEnv kd ks kc ip (cands `unionIdSets` mkIdSet ids)
81 addNewCand :: OccEnv -> Id -> OccEnv
82 addNewCand (OccEnv ks kd kc ip cands) id
83 = OccEnv kd ks kc ip (addOneToIdSet cands id)
85 isCandidate :: OccEnv -> Id -> Bool
86 isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfIdSet` cands
88 ignoreINLINEPragma :: OccEnv -> Bool
89 ignoreINLINEPragma (OccEnv _ _ _ ip _) = ip
91 keepUnusedBinding :: OccEnv -> Id -> Bool
92 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
93 = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
95 keepBecauseConjurable :: OccEnv -> Id -> Bool
96 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
97 = keep_conjurable && isConstMethodId binder
99 type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
101 combineUsageDetails, combineAltsUsageDetails
102 :: UsageDetails -> UsageDetails -> UsageDetails
104 combineUsageDetails usage1 usage2
105 = combineIdEnvs combineBinderInfo usage1 usage2
107 combineAltsUsageDetails usage1 usage2
108 = combineIdEnvs combineAltsBinderInfo usage1 usage2
110 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
111 addOneOcc usage id info
112 = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
113 -- ToDo: make this more efficient
115 emptyDetails = (nullIdEnv :: UsageDetails)
117 unitDetails id info = (unitIdEnv id info :: UsageDetails)
119 tagBinders :: UsageDetails -- Of scope
121 -> (UsageDetails, -- Details with binders removed
122 [(Id,BinderInfo)]) -- Tagged binders
124 tagBinders usage binders
125 = (usage `delManyFromIdEnv` binders,
126 [ (binder, usage_of usage binder) | binder <- binders ]
129 tagBinder :: UsageDetails -- Of scope
131 -> (UsageDetails, -- Details with binders removed
132 (Id,BinderInfo)) -- Tagged binders
134 tagBinder usage binder
135 = (usage `delOneFromIdEnv` binder,
136 (binder, usage_of usage binder)
139 usage_of usage binder
140 | isExported binder = ManyOcc 0 -- Exported things count as many
142 = case (lookupIdEnv usage binder) of
146 isNeeded env usage binder
147 = case (usage_of usage binder) of
148 DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
153 %************************************************************************
155 \subsection[OccurAnal-main]{Counting occurrences: main function}
157 %************************************************************************
159 Here's the externally-callable interface:
163 :: [CoreBinding] -- input
164 -> (SimplifierSwitch -> Bool)
165 -> [SimplifiableCoreBinding] -- output
167 occurAnalyseBinds binds simplifier_sw_chkr
168 | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
169 (ppAboves (map (ppr PprDebug) binds'))
173 (_, binds') = do initial_env binds
175 initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
176 (simplifier_sw_chkr KeepSpecPragmaIds)
177 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
178 (simplifier_sw_chkr IgnoreINLINEPragma)
181 do env [] = (emptyDetails, [])
183 = (final_usage, new_binds ++ the_rest)
185 new_env = env `addNewCands` (bindersOf bind)
186 (binds_usage, the_rest) = do new_env binds
187 (final_usage, new_binds) = occAnalBind env bind binds_usage
191 occurAnalyseExpr :: IdSet -- Set of interesting free vars
193 -> (IdEnv BinderInfo, -- Occ info for interesting free vars
194 SimplifiableCoreExpr)
196 occurAnalyseExpr candidates expr
197 = occAnal initial_env expr
199 initial_env = OccEnv False {- Drop unused bindings -}
200 False {- Drop SpecPragmaId bindings -}
201 True {- Keep conjurable Ids -}
202 False {- Do not ignore INLINE Pragma -}
205 occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
206 occurAnalyseGlobalExpr expr
207 = -- Top level expr, so no interesting free vars, and
208 -- discard occurence info returned
209 expr' where (_, expr') = occurAnalyseExpr emptyIdSet expr
212 %************************************************************************
214 \subsection[OccurAnal-main]{Counting occurrences: main function}
216 %************************************************************************
222 occAnalBind :: OccEnv
224 -> UsageDetails -- Usage details of scope
225 -> (UsageDetails, -- Of the whole let(rec)
226 [SimplifiableCoreBinding])
228 occAnalBind env (NonRec binder rhs) body_usage
229 | isNeeded env body_usage binder -- It's mentioned in body
230 = (final_body_usage `combineUsageDetails` rhs_usage,
231 [NonRec tagged_binder rhs'])
237 (rhs_usage, rhs') = occAnalRhs env binder rhs
238 (final_body_usage, tagged_binder) = tagBinder body_usage binder
241 Dropping dead code for recursive bindings is done in a very simple way:
243 the entire set of bindings is dropped if none of its binders are
244 mentioned in its body; otherwise none are.
246 This seems to miss an obvious improvement.
261 Now @f@ is unused. But dependency analysis will sort this out into a
262 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
263 It isn't easy to do a perfect job in one blow. Consider
277 occAnalBind env (Rec pairs) body_usage
278 = foldr do_final_bind (body_usage, []) sccs
281 (binders, rhss) = unzip pairs
282 new_env = env `addNewCands` binders
284 analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
285 analysed_pairs = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
287 lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
288 lookup id = assoc "occAnalBind:lookup" analysed_pairs id
291 ---- stuff for dependency analysis of binds -------------------------------
293 edges :: [(Id,Id)] -- (a,b) means a mentions b
294 edges = concat [ edges_from binder rhs_usage
295 | (binder, (rhs_usage, _)) <- analysed_pairs]
297 edges_from :: Id -> UsageDetails -> [(Id,Id)]
298 edges_from id its_rhs_usage
299 = [(id,mentioned) | mentioned <- binders,
300 maybeToBool (lookupIdEnv its_rhs_usage mentioned)
304 sccs = case binders of
305 [_] -> [binders] -- Singleton; no need to analyse
306 other -> stronglyConnComp (==) edges binders
308 ---- stuff to "re-constitute" bindings from dependency-analysis info ------
310 do_final_bind sCC@[binder] (body_usage, binds_so_far)
311 | isNeeded env body_usage binder
312 = (combined_usage, new_bind:binds_so_far)
315 = (body_usage, binds_so_far)
317 total_usage = combineUsageDetails body_usage rhs_usage
318 (rhs_usage, rhs') = lookup binder
319 (combined_usage, tagged_binder) = tagBinder total_usage binder
322 | mentions_itself binder rhs_usage = Rec [(tagged_binder,rhs')]
323 | otherwise = NonRec tagged_binder rhs'
325 mentions_itself binder usage
326 = maybeToBool (lookupIdEnv usage binder)
328 do_final_bind sCC (body_usage, binds_so_far)
329 | any (isNeeded env body_usage) sCC
330 = (combined_usage, new_bind:binds_so_far)
333 = (body_usage, binds_so_far)
335 (rhs_usages, rhss') = unzip (map lookup sCC)
336 total_usage = foldr combineUsageDetails body_usage rhs_usages
337 (combined_usage, tagged_binders) = tagBinders total_usage sCC
339 new_bind = Rec (tagged_binders `zip` rhss')
342 @occAnalRhs@ deals with the question of bindings where the Id is marked
343 by an INLINE pragma. For these we record that anything which occurs
344 in its RHS occurs many times. This pessimistically assumes that ths
345 inlined binder also occurs many times in its scope, but if it doesn't
346 we'll catch it next time round. At worst this costs an extra simplifier pass.
347 ToDo: try using the occurrence info for the inline'd binder.
353 -> (UsageDetails, SimplifiableCoreExpr)
355 occAnalRhs env id rhs
356 | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
357 = (mapIdEnv markMany rhs_usage, rhs')
363 (rhs_usage, rhs') = occAnal env rhs
371 -> (UsageDetails, -- Gives info only about the "interesting" Ids
372 SimplifiableCoreExpr)
376 = (unitIdEnv v (funOccurrence 0), Var v)
379 = (emptyDetails, Var v)
381 occAnal env (Lit lit) = (emptyDetails, Lit lit)
382 occAnal env (Con con args) = (occAnalArgs env args, Con con args)
383 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
385 occAnal env (SCC cc body)
386 = (mapIdEnv markInsideSCC usage, SCC cc body')
388 (usage, body') = occAnal env body
390 occAnal env (Coerce c ty body)
391 = (usage, Coerce c ty body')
393 (usage, body') = occAnal env body
395 occAnal env (App fun arg)
396 = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
398 (fun_usage, fun') = occAnal env fun
399 arg_usage = occAnalArg env arg
401 occAnal env (Lam (ValBinder binder) body)
402 = (mapIdEnv markDangerousToDup final_usage,
403 Lam (ValBinder tagged_binder) body')
405 (body_usage, body') = occAnal (env `addNewCand` binder) body
406 (final_usage, tagged_binder) = tagBinder body_usage binder
408 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
409 occAnal env (Lam (TyBinder tyvar) body)
410 = (mapIdEnv markDangerousToDup body_usage,
411 Lam (TyBinder tyvar) body')
413 (body_usage, body') = occAnal env body
415 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
417 occAnal env (Case scrut alts)
418 = (scrut_usage `combineUsageDetails` alts_usage,
421 (scrut_usage, scrut') = occAnal env scrut
422 (alts_usage, alts') = occAnalAlts env alts
424 occAnal env (Let bind body)
425 = (final_usage, foldr Let body' new_binds) -- mkCoLet* wants Core... (sigh)
427 new_env = env `addNewCands` (bindersOf bind)
428 (body_usage, body') = occAnal new_env body
429 (final_usage, new_binds) = occAnalBind env bind body_usage
435 occAnalAlts env (AlgAlts alts deflt)
436 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
437 -- Note: combine*Alts*UsageDetails...
438 AlgAlts alts' deflt')
440 (alts_usage, alts') = unzip (map do_alt alts)
441 (deflt_usage, deflt') = occAnalDeflt env deflt
443 do_alt (con, args, rhs)
444 = (final_usage, (con, tagged_args, rhs'))
446 new_env = env `addNewCands` args
447 (rhs_usage, rhs') = occAnal new_env rhs
448 (final_usage, tagged_args) = tagBinders rhs_usage args
450 occAnalAlts env (PrimAlts alts deflt)
451 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
452 -- Note: combine*Alts*UsageDetails...
453 PrimAlts alts' deflt')
455 (alts_usage, alts') = unzip (map do_alt alts)
456 (deflt_usage, deflt') = occAnalDeflt env deflt
459 = (rhs_usage, (lit, rhs'))
461 (rhs_usage, rhs') = occAnal env rhs
463 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
465 occAnalDeflt env (BindDefault binder rhs)
466 = (final_usage, BindDefault tagged_binder rhs')
468 new_env = env `addNewCand` binder
469 (rhs_usage, rhs') = occAnal new_env rhs
470 (final_usage, tagged_binder) = tagBinder rhs_usage binder
477 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
479 occAnalArgs env atoms
480 = foldr do_one_atom emptyDetails atoms
482 do_one_atom (VarArg v) usage
483 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
485 do_one_atom other_arg usage = usage
488 occAnalArg :: OccEnv -> CoreArg -> UsageDetails
490 occAnalArg env (VarArg v)
491 | isCandidate env v = unitDetails v (argOccurrence 0)
492 | otherwise = emptyDetails
493 occAnalArg _ _ = emptyDetails