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_DELOOPER(IdLoop) -- paranoia
24 import CmdLineOpts ( opt_D_dump_occur_anal, SimplifierSwitch(..) )
26 import Digraph ( stronglyConnComp )
27 import Id ( idWantsToBeINLINEd, isConstMethodId,
28 emptyIdSet, unionIdSets, mkIdSet,
29 unitIdSet, elementOfIdSet,
30 addOneToIdSet, IdSet(..),
31 nullIdEnv, unitIdEnv, combineIdEnvs,
32 delOneFromIdEnv, delManyFromIdEnv,
33 mapIdEnv, lookupIdEnv, IdEnv(..),
36 import Maybes ( maybeToBool )
37 import Name ( isExported )
38 import Outputable ( Outputable(..){-instance * (,) -} )
40 import PprStyle ( PprStyle(..) )
41 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
42 import Pretty ( ppAboves )
43 import TyVar ( GenTyVar{-instance Eq-} )
44 import Unique ( Unique{-instance Eq-} )
45 import Util ( assoc, zipEqual, pprTrace, panic )
47 isSpecPragmaId_maybe = panic "OccurAnal.isSpecPragmaId_maybe (ToDo)"
51 %************************************************************************
53 \subsection[OccurAnal-types]{Data types}
55 %************************************************************************
60 Bool -- Keep-unused-bindings flag
61 -- False <=> OK to chuck away binding
62 -- and ignore occurrences within it
63 Bool -- Keep-spec-pragma-ids flag
64 -- False <=> OK to chuck away spec pragma bindings
65 -- and ignore occurrences within it
66 Bool -- Keep-conjurable flag
67 -- False <=> OK to throw away *dead*
68 -- "conjurable" Ids; at the moment, that
69 -- *only* means constant methods, which
70 -- are top-level. A use of a "conjurable"
71 -- Id may appear out of thin air -- e.g.,
72 -- specialiser conjuring up refs to const methods.
73 Bool -- IgnoreINLINEPragma flag
74 -- False <=> OK to use INLINEPragma information
75 -- True <=> ignore INLINEPragma information
78 addNewCands :: OccEnv -> [Id] -> OccEnv
79 addNewCands (OccEnv kd ks kc ip cands) ids
80 = OccEnv kd ks kc ip (cands `unionIdSets` mkIdSet ids)
82 addNewCand :: OccEnv -> Id -> OccEnv
83 addNewCand (OccEnv ks kd kc ip cands) id
84 = OccEnv kd ks kc ip (addOneToIdSet cands id)
86 isCandidate :: OccEnv -> Id -> Bool
87 isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfIdSet` cands
89 ignoreINLINEPragma :: OccEnv -> Bool
90 ignoreINLINEPragma (OccEnv _ _ _ ip _) = ip
92 keepUnusedBinding :: OccEnv -> Id -> Bool
93 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
94 = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
96 keepBecauseConjurable :: OccEnv -> Id -> Bool
97 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
98 = keep_conjurable && isConstMethodId binder
100 type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
102 combineUsageDetails, combineAltsUsageDetails
103 :: UsageDetails -> UsageDetails -> UsageDetails
105 combineUsageDetails usage1 usage2
106 = combineIdEnvs addBinderInfo usage1 usage2
108 combineAltsUsageDetails usage1 usage2
109 = combineIdEnvs orBinderInfo usage1 usage2
111 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
112 addOneOcc usage id info
113 = combineIdEnvs addBinderInfo usage (unitIdEnv id info)
114 -- ToDo: make this more efficient
116 emptyDetails = (nullIdEnv :: UsageDetails)
118 unitDetails id info = (unitIdEnv id info :: UsageDetails)
120 tagBinders :: UsageDetails -- Of scope
122 -> (UsageDetails, -- Details with binders removed
123 [(Id,BinderInfo)]) -- Tagged binders
125 tagBinders usage binders
126 = (usage `delManyFromIdEnv` binders,
127 [ (binder, usage_of usage binder) | binder <- binders ]
130 tagBinder :: UsageDetails -- Of scope
132 -> (UsageDetails, -- Details with binders removed
133 (Id,BinderInfo)) -- Tagged binders
135 tagBinder usage binder
136 = (usage `delOneFromIdEnv` binder,
137 (binder, usage_of usage binder)
140 usage_of usage binder
141 | isExported binder = ManyOcc 0 -- Exported things count as many
143 = case (lookupIdEnv usage binder) of
147 isNeeded env usage binder
148 = case (usage_of usage binder) of
149 DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
154 %************************************************************************
156 \subsection[OccurAnal-main]{Counting occurrences: main function}
158 %************************************************************************
160 Here's the externally-callable interface:
164 :: [CoreBinding] -- input
165 -> (SimplifierSwitch -> Bool)
166 -> [SimplifiableCoreBinding] -- output
168 occurAnalyseBinds binds simplifier_sw_chkr
169 | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
170 (ppAboves (map (ppr PprDebug) binds'))
174 (_, binds') = do initial_env binds
176 initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
177 (simplifier_sw_chkr KeepSpecPragmaIds)
178 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
179 (simplifier_sw_chkr IgnoreINLINEPragma)
182 do env [] = (emptyDetails, [])
184 = (final_usage, new_binds ++ the_rest)
186 new_env = env `addNewCands` (bindersOf bind)
187 (binds_usage, the_rest) = do new_env binds
188 (final_usage, new_binds) = occAnalBind env bind binds_usage
192 occurAnalyseExpr :: IdSet -- Set of interesting free vars
194 -> (IdEnv BinderInfo, -- Occ info for interesting free vars
195 SimplifiableCoreExpr)
197 occurAnalyseExpr candidates expr
198 = occAnal initial_env expr
200 initial_env = OccEnv False {- Drop unused bindings -}
201 False {- Drop SpecPragmaId bindings -}
202 True {- Keep conjurable Ids -}
203 False {- Do not ignore INLINE Pragma -}
206 occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
207 occurAnalyseGlobalExpr expr
208 = -- Top level expr, so no interesting free vars, and
209 -- discard occurence info returned
210 snd (occurAnalyseExpr emptyIdSet expr)
213 %************************************************************************
215 \subsection[OccurAnal-main]{Counting occurrences: main function}
217 %************************************************************************
223 occAnalBind :: OccEnv
225 -> UsageDetails -- Usage details of scope
226 -> (UsageDetails, -- Of the whole let(rec)
227 [SimplifiableCoreBinding])
229 occAnalBind env (NonRec binder rhs) body_usage
230 | isNeeded env body_usage binder -- It's mentioned in body
231 = (final_body_usage `combineUsageDetails` rhs_usage,
232 [NonRec tagged_binder rhs'])
238 (rhs_usage, rhs') = occAnalRhs env binder rhs
239 (final_body_usage, tagged_binder) = tagBinder body_usage binder
242 Dropping dead code for recursive bindings is done in a very simple way:
244 the entire set of bindings is dropped if none of its binders are
245 mentioned in its body; otherwise none are.
247 This seems to miss an obvious improvement.
262 Now @f@ is unused. But dependency analysis will sort this out into a
263 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
264 It isn't easy to do a perfect job in one blow. Consider
278 occAnalBind env (Rec pairs) body_usage
279 = foldr do_final_bind (body_usage, []) sccs
282 (binders, rhss) = unzip pairs
283 new_env = env `addNewCands` binders
285 analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
286 analysed_pairs = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
288 lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
289 lookup id = assoc "occAnalBind:lookup" analysed_pairs id
292 ---- stuff for dependency analysis of binds -------------------------------
294 edges :: [(Id,Id)] -- (a,b) means a mentions b
295 edges = concat [ edges_from binder rhs_usage
296 | (binder, (rhs_usage, _)) <- analysed_pairs]
298 edges_from :: Id -> UsageDetails -> [(Id,Id)]
299 edges_from id its_rhs_usage
300 = [(id,mentioned) | mentioned <- binders,
301 maybeToBool (lookupIdEnv its_rhs_usage mentioned)
305 sccs = case binders of
306 [_] -> [binders] -- Singleton; no need to analyse
307 other -> stronglyConnComp (==) edges binders
309 ---- stuff to "re-constitute" bindings from dependency-analysis info ------
311 do_final_bind sCC@[binder] (body_usage, binds_so_far)
312 | isNeeded env body_usage binder
313 = (combined_usage, new_bind:binds_so_far)
316 = (body_usage, binds_so_far)
318 total_usage = combineUsageDetails body_usage rhs_usage
319 (rhs_usage, rhs') = lookup binder
320 (combined_usage, tagged_binder) = tagBinder total_usage binder
323 | mentions_itself binder rhs_usage = Rec [(tagged_binder,rhs')]
324 | otherwise = NonRec tagged_binder rhs'
326 mentions_itself binder usage
327 = maybeToBool (lookupIdEnv usage binder)
329 do_final_bind sCC (body_usage, binds_so_far)
330 | any (isNeeded env body_usage) sCC
331 = (combined_usage, new_bind:binds_so_far)
334 = (body_usage, binds_so_far)
336 (rhs_usages, rhss') = unzip (map lookup sCC)
337 total_usage = foldr combineUsageDetails body_usage rhs_usages
338 (combined_usage, tagged_binders) = tagBinders total_usage sCC
340 new_bind = Rec (zipEqual "occAnalBind" tagged_binders rhss')
343 @occAnalRhs@ deals with the question of bindings where the Id is marked
344 by an INLINE pragma. For these we record that anything which occurs
345 in its RHS occurs many times. This pessimistically assumes that ths
346 inlined binder also occurs many times in its scope, but if it doesn't
347 we'll catch it next time round. At worst this costs an extra simplifier pass.
348 ToDo: try using the occurrence info for the inline'd binder.
354 -> (UsageDetails, SimplifiableCoreExpr)
356 occAnalRhs env id rhs
357 | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
358 = (mapIdEnv markMany rhs_usage, rhs')
364 (rhs_usage, rhs') = occAnal env rhs
372 -> (UsageDetails, -- Gives info only about the "interesting" Ids
373 SimplifiableCoreExpr)
377 = (unitIdEnv v (funOccurrence 0), Var v)
380 = (emptyDetails, Var v)
382 occAnal env (Lit lit) = (emptyDetails, Lit lit)
383 occAnal env (Con con args) = (occAnalArgs env args, Con con args)
384 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
386 occAnal env (SCC cc body)
387 = (mapIdEnv markInsideSCC usage, SCC cc body')
389 (usage, body') = occAnal env body
391 occAnal env (Coerce c ty body)
392 = (usage, Coerce c ty body')
394 (usage, body') = occAnal env body
396 occAnal env (App fun arg)
397 = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
399 (fun_usage, fun') = occAnal env fun
400 arg_usage = occAnalArg env arg
402 occAnal env (Lam (ValBinder binder) body)
403 = (mapIdEnv markDangerousToDup final_usage,
404 Lam (ValBinder tagged_binder) body')
406 (body_usage, body') = occAnal (env `addNewCand` binder) body
407 (final_usage, tagged_binder) = tagBinder body_usage binder
409 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
410 occAnal env (Lam (TyBinder tyvar) body)
411 = (mapIdEnv markDangerousToDup body_usage,
412 Lam (TyBinder tyvar) body')
414 (body_usage, body') = occAnal env body
416 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
418 occAnal env (Case scrut alts)
419 = (scrut_usage `combineUsageDetails` alts_usage,
422 (scrut_usage, scrut') = occAnal env scrut
423 (alts_usage, alts') = occAnalAlts env alts
425 occAnal env (Let bind body)
426 = (final_usage, foldr Let body' new_binds) -- mkCoLet* wants Core... (sigh)
428 new_env = env `addNewCands` (bindersOf bind)
429 (body_usage, body') = occAnal new_env body
430 (final_usage, new_binds) = occAnalBind env bind body_usage
436 occAnalAlts env (AlgAlts alts deflt)
437 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
438 -- Note: combine*Alts*UsageDetails...
439 AlgAlts alts' deflt')
441 (alts_usage, alts') = unzip (map do_alt alts)
442 (deflt_usage, deflt') = occAnalDeflt env deflt
444 do_alt (con, args, rhs)
445 = (final_usage, (con, tagged_args, rhs'))
447 new_env = env `addNewCands` args
448 (rhs_usage, rhs') = occAnal new_env rhs
449 (final_usage, tagged_args) = tagBinders rhs_usage args
451 occAnalAlts env (PrimAlts alts deflt)
452 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
453 -- Note: combine*Alts*UsageDetails...
454 PrimAlts alts' deflt')
456 (alts_usage, alts') = unzip (map do_alt alts)
457 (deflt_usage, deflt') = occAnalDeflt env deflt
460 = (rhs_usage, (lit, rhs'))
462 (rhs_usage, rhs') = occAnal env rhs
464 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
466 occAnalDeflt env (BindDefault binder rhs)
467 = (final_usage, BindDefault tagged_binder rhs')
469 new_env = env `addNewCand` binder
470 (rhs_usage, rhs') = occAnal new_env rhs
471 (final_usage, tagged_binder) = tagBinder rhs_usage binder
478 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
480 occAnalArgs env atoms
481 = foldr do_one_atom emptyDetails atoms
483 do_one_atom (VarArg v) usage
484 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
486 do_one_atom other_arg usage = usage
489 occAnalArg :: OccEnv -> CoreArg -> UsageDetails
491 occAnalArg env (VarArg v)
492 | isCandidate env v = unitDetails v (argOccurrence 0)
493 | otherwise = emptyDetails
494 occAnalArg _ _ = emptyDetails