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 Outputable ( isExported, Outputable(..){-instance * (,) -} )
38 import PprStyle ( PprStyle(..) )
39 import PprType ( GenType{-instance Outputable-}, GenTyVar{-ditto-} )
40 import Pretty ( ppAboves )
41 import TyVar ( GenTyVar{-instance Eq-} )
42 import Unique ( Unique{-instance Eq-} )
43 import Util ( assoc, pprTrace, panic )
45 isSpecPragmaId_maybe = panic "OccurAnal.isSpecPragmaId_maybe (ToDo)"
49 %************************************************************************
51 \subsection[OccurAnal-types]{Data types}
53 %************************************************************************
58 Bool -- Keep-unused-bindings flag
59 -- False <=> OK to chuck away binding
60 -- and ignore occurrences within it
61 Bool -- Keep-spec-pragma-ids flag
62 -- False <=> OK to chuck away spec pragma bindings
63 -- and ignore occurrences within it
64 Bool -- Keep-conjurable flag
65 -- False <=> OK to throw away *dead*
66 -- "conjurable" Ids; at the moment, that
67 -- *only* means constant methods, which
68 -- are top-level. A use of a "conjurable"
69 -- Id may appear out of thin air -- e.g.,
70 -- specialiser conjuring up refs to const methods.
71 Bool -- IgnoreINLINEPragma flag
72 -- False <=> OK to use INLINEPragma information
73 -- True <=> ignore INLINEPragma information
76 addNewCands :: OccEnv -> [Id] -> OccEnv
77 addNewCands (OccEnv kd ks kc ip cands) ids
78 = OccEnv kd ks kc ip (cands `unionIdSets` mkIdSet ids)
80 addNewCand :: OccEnv -> Id -> OccEnv
81 addNewCand (OccEnv ks kd kc ip cands) id
82 = OccEnv kd ks kc ip (addOneToIdSet cands id)
84 isCandidate :: OccEnv -> Id -> Bool
85 isCandidate (OccEnv _ _ _ _ cands) id = id `elementOfIdSet` cands
87 ignoreINLINEPragma :: OccEnv -> Bool
88 ignoreINLINEPragma (OccEnv _ _ _ ip _) = ip
90 keepUnusedBinding :: OccEnv -> Id -> Bool
91 keepUnusedBinding (OccEnv keep_dead keep_spec keep_conjurable _ _) binder
92 = keep_dead || (keep_spec && maybeToBool (isSpecPragmaId_maybe binder))
94 keepBecauseConjurable :: OccEnv -> Id -> Bool
95 keepBecauseConjurable (OccEnv _ _ keep_conjurable _ _) binder
96 = keep_conjurable && isConstMethodId binder
98 type UsageDetails = IdEnv BinderInfo -- A finite map from ids to their usage
100 combineUsageDetails, combineAltsUsageDetails
101 :: UsageDetails -> UsageDetails -> UsageDetails
103 combineUsageDetails usage1 usage2
104 = combineIdEnvs combineBinderInfo usage1 usage2
106 combineAltsUsageDetails usage1 usage2
107 = combineIdEnvs combineAltsBinderInfo usage1 usage2
109 addOneOcc :: UsageDetails -> Id -> BinderInfo -> UsageDetails
110 addOneOcc usage id info
111 = combineIdEnvs combineBinderInfo usage (unitIdEnv id info)
112 -- ToDo: make this more efficient
114 emptyDetails = (nullIdEnv :: UsageDetails)
116 unitDetails id info = (unitIdEnv id info :: UsageDetails)
118 tagBinders :: UsageDetails -- Of scope
120 -> (UsageDetails, -- Details with binders removed
121 [(Id,BinderInfo)]) -- Tagged binders
123 tagBinders usage binders
124 = (usage `delManyFromIdEnv` binders,
125 [ (binder, usage_of usage binder) | binder <- binders ]
128 tagBinder :: UsageDetails -- Of scope
130 -> (UsageDetails, -- Details with binders removed
131 (Id,BinderInfo)) -- Tagged binders
133 tagBinder usage binder
134 = (usage `delOneFromIdEnv` binder,
135 (binder, usage_of usage binder)
138 usage_of usage binder
139 | isExported binder = ManyOcc 0 -- Exported things count as many
141 = case (lookupIdEnv usage binder) of
145 isNeeded env usage binder
146 = case (usage_of usage binder) of
147 DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
152 %************************************************************************
154 \subsection[OccurAnal-main]{Counting occurrences: main function}
156 %************************************************************************
158 Here's the externally-callable interface:
162 :: [CoreBinding] -- input
163 -> (SimplifierSwitch -> Bool)
164 -> [SimplifiableCoreBinding] -- output
166 occurAnalyseBinds binds simplifier_sw_chkr
167 | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
168 (ppAboves (map (ppr PprDebug) binds'))
172 (_, binds') = do initial_env binds
174 initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
175 (simplifier_sw_chkr KeepSpecPragmaIds)
176 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
177 (simplifier_sw_chkr IgnoreINLINEPragma)
180 do env [] = (emptyDetails, [])
182 = (final_usage, new_binds ++ the_rest)
184 new_env = env `addNewCands` (bindersOf bind)
185 (binds_usage, the_rest) = do new_env binds
186 (final_usage, new_binds) = occAnalBind env bind binds_usage
190 occurAnalyseExpr :: IdSet -- Set of interesting free vars
192 -> (IdEnv BinderInfo, -- Occ info for interesting free vars
193 SimplifiableCoreExpr)
195 occurAnalyseExpr candidates expr
196 = occAnal initial_env expr
198 initial_env = OccEnv False {- Drop unused bindings -}
199 False {- Drop SpecPragmaId bindings -}
200 True {- Keep conjurable Ids -}
201 False {- Do not ignore INLINE Pragma -}
204 occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
205 occurAnalyseGlobalExpr expr
206 = -- Top level expr, so no interesting free vars, and
207 -- discard occurence info returned
208 expr' where (_, expr') = occurAnalyseExpr emptyIdSet expr
211 %************************************************************************
213 \subsection[OccurAnal-main]{Counting occurrences: main function}
215 %************************************************************************
221 occAnalBind :: OccEnv
223 -> UsageDetails -- Usage details of scope
224 -> (UsageDetails, -- Of the whole let(rec)
225 [SimplifiableCoreBinding])
227 occAnalBind env (NonRec binder rhs) body_usage
228 | isNeeded env body_usage binder -- It's mentioned in body
229 = (final_body_usage `combineUsageDetails` rhs_usage,
230 [NonRec tagged_binder rhs'])
236 (rhs_usage, rhs') = occAnalRhs env binder rhs
237 (final_body_usage, tagged_binder) = tagBinder body_usage binder
240 Dropping dead code for recursive bindings is done in a very simple way:
242 the entire set of bindings is dropped if none of its binders are
243 mentioned in its body; otherwise none are.
245 This seems to miss an obvious improvement.
260 Now @f@ is unused. But dependency analysis will sort this out into a
261 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
262 It isn't easy to do a perfect job in one blow. Consider
276 occAnalBind env (Rec pairs) body_usage
277 = foldr do_final_bind (body_usage, []) sccs
280 (binders, rhss) = unzip pairs
281 new_env = env `addNewCands` binders
283 analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
284 analysed_pairs = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
286 lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
287 lookup id = assoc "occAnalBind:lookup" analysed_pairs id
290 ---- stuff for dependency analysis of binds -------------------------------
292 edges :: [(Id,Id)] -- (a,b) means a mentions b
293 edges = concat [ edges_from binder rhs_usage
294 | (binder, (rhs_usage, _)) <- analysed_pairs]
296 edges_from :: Id -> UsageDetails -> [(Id,Id)]
297 edges_from id its_rhs_usage
298 = [(id,mentioned) | mentioned <- binders,
299 maybeToBool (lookupIdEnv its_rhs_usage mentioned)
303 sccs = case binders of
304 [_] -> [binders] -- Singleton; no need to analyse
305 other -> stronglyConnComp (==) edges binders
307 ---- stuff to "re-constitute" bindings from dependency-analysis info ------
309 do_final_bind sCC@[binder] (body_usage, binds_so_far)
310 | isNeeded env body_usage binder
311 = (combined_usage, new_bind:binds_so_far)
314 = (body_usage, binds_so_far)
316 total_usage = combineUsageDetails body_usage rhs_usage
317 (rhs_usage, rhs') = lookup binder
318 (combined_usage, tagged_binder) = tagBinder total_usage binder
321 | mentions_itself binder rhs_usage = Rec [(tagged_binder,rhs')]
322 | otherwise = NonRec tagged_binder rhs'
324 mentions_itself binder usage
325 = maybeToBool (lookupIdEnv usage binder)
327 do_final_bind sCC (body_usage, binds_so_far)
328 | any (isNeeded env body_usage) sCC
329 = (combined_usage, new_bind:binds_so_far)
332 = (body_usage, binds_so_far)
334 (rhs_usages, rhss') = unzip (map lookup sCC)
335 total_usage = foldr combineUsageDetails body_usage rhs_usages
336 (combined_usage, tagged_binders) = tagBinders total_usage sCC
338 new_bind = Rec (tagged_binders `zip` rhss')
341 @occAnalRhs@ deals with the question of bindings where the Id is marked
342 by an INLINE pragma. For these we record that anything which occurs
343 in its RHS occurs many times. This pessimistically assumes that ths
344 inlined binder also occurs many times in its scope, but if it doesn't
345 we'll catch it next time round. At worst this costs an extra simplifier pass.
346 ToDo: try using the occurrence info for the inline'd binder.
352 -> (UsageDetails, SimplifiableCoreExpr)
354 occAnalRhs env id rhs
355 | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
356 = (mapIdEnv markMany rhs_usage, rhs')
362 (rhs_usage, rhs') = occAnal env rhs
370 -> (UsageDetails, -- Gives info only about the "interesting" Ids
371 SimplifiableCoreExpr)
375 = (unitIdEnv v (funOccurrence 0), Var v)
378 = (emptyDetails, Var v)
380 occAnal env (Lit lit) = (emptyDetails, Lit lit)
381 occAnal env (Con con args) = (occAnalArgs env args, Con con args)
382 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
384 occAnal env (SCC cc body)
385 = (mapIdEnv markInsideSCC usage, SCC cc body')
387 (usage, body') = occAnal env body
389 occAnal env (App fun arg)
390 = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
392 (fun_usage, fun') = occAnal env fun
393 arg_usage = occAnalArg env arg
395 occAnal env (Lam (ValBinder binder) body)
396 = (mapIdEnv markDangerousToDup final_usage,
397 Lam (ValBinder tagged_binder) body')
399 (body_usage, body') = occAnal (env `addNewCand` binder) body
400 (final_usage, tagged_binder) = tagBinder body_usage binder
402 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
403 occAnal env (Lam (TyBinder tyvar) body)
404 = (mapIdEnv markDangerousToDup body_usage,
405 Lam (TyBinder tyvar) body')
407 (body_usage, body') = occAnal env body
409 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
411 occAnal env (Case scrut alts)
412 = (scrut_usage `combineUsageDetails` alts_usage,
415 (scrut_usage, scrut') = occAnal env scrut
416 (alts_usage, alts') = occAnalAlts env alts
418 occAnal env (Let bind body)
419 = (final_usage, foldr Let body' new_binds) -- mkCoLet* wants Core... (sigh)
421 new_env = env `addNewCands` (bindersOf bind)
422 (body_usage, body') = occAnal new_env body
423 (final_usage, new_binds) = occAnalBind env bind body_usage
429 occAnalAlts env (AlgAlts alts deflt)
430 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
431 -- Note: combine*Alts*UsageDetails...
432 AlgAlts alts' deflt')
434 (alts_usage, alts') = unzip (map do_alt alts)
435 (deflt_usage, deflt') = occAnalDeflt env deflt
437 do_alt (con, args, rhs)
438 = (final_usage, (con, tagged_args, rhs'))
440 new_env = env `addNewCands` args
441 (rhs_usage, rhs') = occAnal new_env rhs
442 (final_usage, tagged_args) = tagBinders rhs_usage args
444 occAnalAlts env (PrimAlts alts deflt)
445 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
446 -- Note: combine*Alts*UsageDetails...
447 PrimAlts alts' deflt')
449 (alts_usage, alts') = unzip (map do_alt alts)
450 (deflt_usage, deflt') = occAnalDeflt env deflt
453 = (rhs_usage, (lit, rhs'))
455 (rhs_usage, rhs') = occAnal env rhs
457 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
459 occAnalDeflt env (BindDefault binder rhs)
460 = (final_usage, BindDefault tagged_binder rhs')
462 new_env = env `addNewCand` binder
463 (rhs_usage, rhs') = occAnal new_env rhs
464 (final_usage, tagged_binder) = tagBinder rhs_usage binder
471 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
473 occAnalArgs env atoms
474 = foldr do_one_atom emptyDetails atoms
476 do_one_atom (VarArg v) usage
477 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
479 do_one_atom other_arg usage = usage
482 occAnalArg :: OccEnv -> CoreArg -> UsageDetails
484 occAnalArg env (VarArg v)
485 | isCandidate env v = unitDetails v (argOccurrence 0)
486 | otherwise = emptyDetails
487 occAnalArg _ _ = emptyDetails