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, SYN_IE(IdSet),
31 nullIdEnv, unitIdEnv, combineIdEnvs,
32 delOneFromIdEnv, delManyFromIdEnv, isNullIdEnv,
33 mapIdEnv, lookupIdEnv, SYN_IE(IdEnv),
36 import Name ( isExported )
37 import Maybes ( maybeToBool )
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 x = Nothing -- ToDo:!trace "OccurAnal.isSpecPragmaId_maybe"
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 =
127 usage' = usage `delManyFromIdEnv` binders
128 uss = [ (binder, usage_of usage binder) | binder <- binders ]
130 if isNullIdEnv usage' then
135 = (usage `delManyFromIdEnv` binders,
136 [ (binder, usage_of usage binder) | binder <- binders ]
139 tagBinder :: UsageDetails -- Of scope
141 -> (UsageDetails, -- Details with binders removed
142 (Id,BinderInfo)) -- Tagged binders
144 tagBinder usage binder =
146 usage' = usage `delOneFromIdEnv` binder
147 us = usage_of usage binder
149 if isNullIdEnv usage' then -- bogus test to force evaluation.
150 (usage', (binder, us))
152 (usage', (binder, us))
154 case us of { DeadCode -> cont; _ -> cont }
156 -- (binder, usage_of usage binder)
159 usage_of usage binder
160 | isExported binder = ManyOcc 0 -- Visible-elsewhere things count as many
162 = case (lookupIdEnv usage binder) of
166 isNeeded env usage binder
167 = case (usage_of usage binder) of
168 DeadCode -> keepUnusedBinding env binder -- Maybe keep it anyway
173 %************************************************************************
175 \subsection[OccurAnal-main]{Counting occurrences: main function}
177 %************************************************************************
179 Here's the externally-callable interface:
183 :: [CoreBinding] -- input
184 -> (SimplifierSwitch -> Bool)
185 -> [SimplifiableCoreBinding] -- output
187 occurAnalyseBinds binds simplifier_sw_chkr
188 | opt_D_dump_occur_anal = pprTrace "OccurAnal:"
189 (ppAboves (map (ppr PprDebug) binds'))
193 (_, binds') = doo initial_env binds
195 initial_env = OccEnv (simplifier_sw_chkr KeepUnusedBindings)
196 (simplifier_sw_chkr KeepSpecPragmaIds)
197 (not (simplifier_sw_chkr SimplMayDeleteConjurableIds))
198 (simplifier_sw_chkr IgnoreINLINEPragma)
201 doo env [] = (emptyDetails, [])
203 = (final_usage, new_binds ++ the_rest)
205 new_env = env `addNewCands` (bindersOf bind)
206 (binds_usage, the_rest) = doo new_env binds
207 (final_usage, new_binds) = occAnalBind env bind binds_usage
211 occurAnalyseExpr :: IdSet -- Set of interesting free vars
213 -> (IdEnv BinderInfo, -- Occ info for interesting free vars
214 SimplifiableCoreExpr)
216 occurAnalyseExpr candidates expr
217 = occAnal initial_env expr
219 initial_env = OccEnv False {- Drop unused bindings -}
220 False {- Drop SpecPragmaId bindings -}
221 True {- Keep conjurable Ids -}
222 False {- Do not ignore INLINE Pragma -}
225 occurAnalyseGlobalExpr :: CoreExpr -> SimplifiableCoreExpr
226 occurAnalyseGlobalExpr expr
227 = -- Top level expr, so no interesting free vars, and
228 -- discard occurence info returned
229 snd (occurAnalyseExpr emptyIdSet expr)
232 %************************************************************************
234 \subsection[OccurAnal-main]{Counting occurrences: main function}
236 %************************************************************************
242 occAnalBind :: OccEnv
244 -> UsageDetails -- Usage details of scope
245 -> (UsageDetails, -- Of the whole let(rec)
246 [SimplifiableCoreBinding])
248 occAnalBind env (NonRec binder rhs) body_usage
249 | isNeeded env body_usage binder -- It's mentioned in body
250 = (final_body_usage `combineUsageDetails` rhs_usage,
251 [NonRec tagged_binder rhs'])
257 (rhs_usage, rhs') = occAnalRhs env binder rhs
258 (final_body_usage, tagged_binder) = tagBinder body_usage binder
261 Dropping dead code for recursive bindings is done in a very simple way:
263 the entire set of bindings is dropped if none of its binders are
264 mentioned in its body; otherwise none are.
266 This seems to miss an obvious improvement.
281 Now @f@ is unused. But dependency analysis will sort this out into a
282 @letrec@ for @g@ and a @let@ for @f@, and then @f@ will get dropped.
283 It isn't easy to do a perfect job in one blow. Consider
297 occAnalBind env (Rec pairs) body_usage
298 = foldr do_final_bind (body_usage, []) sccs
301 (binders, rhss) = unzip pairs
302 new_env = env `addNewCands` binders
304 analysed_pairs :: [(Id, (UsageDetails, SimplifiableCoreExpr))]
305 analysed_pairs = [(id, occAnalRhs new_env id rhs) | (id,rhs) <- pairs]
307 lookup :: Id -> (UsageDetails, SimplifiableCoreExpr)
308 lookup id = assoc "occAnalBind:lookup" analysed_pairs id
311 ---- stuff for dependency analysis of binds -------------------------------
313 edges :: [(Id,Id)] -- (a,b) means a mentions b
314 edges = concat [ edges_from binder rhs_usage
315 | (binder, (rhs_usage, _)) <- analysed_pairs]
317 edges_from :: Id -> UsageDetails -> [(Id,Id)]
318 edges_from id its_rhs_usage
319 = [(id,mentioned) | mentioned <- binders,
320 maybeToBool (lookupIdEnv its_rhs_usage mentioned)
324 sccs = case binders of
325 [_] -> [binders] -- Singleton; no need to analyse
326 other -> stronglyConnComp (==) edges binders
328 ---- stuff to "re-constitute" bindings from dependency-analysis info ------
330 do_final_bind sCC@[binder] (body_usage, binds_so_far)
331 | isNeeded env body_usage binder
332 = (combined_usage, new_bind:binds_so_far)
335 = (body_usage, binds_so_far)
337 total_usage = combineUsageDetails body_usage rhs_usage
338 (rhs_usage, rhs') = lookup binder
339 (combined_usage, tagged_binder) = tagBinder total_usage binder
342 | mentions_itself binder rhs_usage = Rec [(tagged_binder,rhs')]
343 | otherwise = NonRec tagged_binder rhs'
345 mentions_itself binder usage
346 = maybeToBool (lookupIdEnv usage binder)
348 do_final_bind sCC (body_usage, binds_so_far)
349 | any (isNeeded env body_usage) sCC
350 = (combined_usage, new_bind:binds_so_far)
353 = (body_usage, binds_so_far)
355 (rhs_usages, rhss') = unzip (map lookup sCC)
356 total_usage = foldr combineUsageDetails body_usage rhs_usages
357 (combined_usage, tagged_binders) = tagBinders total_usage sCC
359 new_bind = Rec (zipEqual "occAnalBind" tagged_binders rhss')
362 @occAnalRhs@ deals with the question of bindings where the Id is marked
363 by an INLINE pragma. For these we record that anything which occurs
364 in its RHS occurs many times. This pessimistically assumes that ths
365 inlined binder also occurs many times in its scope, but if it doesn't
366 we'll catch it next time round. At worst this costs an extra simplifier pass.
367 ToDo: try using the occurrence info for the inline'd binder.
373 -> (UsageDetails, SimplifiableCoreExpr)
375 occAnalRhs env id rhs
376 | idWantsToBeINLINEd id && not (ignoreINLINEPragma env)
377 = (mapIdEnv markMany rhs_usage, rhs')
383 (rhs_usage, rhs') = occAnal env rhs
391 -> (UsageDetails, -- Gives info only about the "interesting" Ids
392 SimplifiableCoreExpr)
396 = (unitIdEnv v (funOccurrence 0), Var v)
399 = (emptyDetails, Var v)
401 occAnal env (Lit lit) = (emptyDetails, Lit lit)
402 occAnal env (Prim op args) = (occAnalArgs env args, Prim op args)
405 We regard variables that occur as constructor arguments as "dangerousToDup":
409 f x = let y = expensive x in
411 (case z of {(p,q)->q}, case z of {(p,q)->q})
414 We feel free to duplicate the WHNF (True,y), but that means
415 that y may be duplicated thereby.
417 If we aren't careful we duplicate the (expensive x) call!
418 Constructors are rather like lambdas in this way.
421 occAnal env (Con con args) = (mapIdEnv markDangerousToDup (occAnalArgs env args),
424 occAnal env (SCC cc body)
425 = (mapIdEnv markInsideSCC usage, SCC cc body')
427 (usage, body') = occAnal env body
429 occAnal env (Coerce c ty body)
430 = (usage, Coerce c ty body')
432 (usage, body') = occAnal env body
434 occAnal env (App fun arg)
435 = (fun_usage `combineUsageDetails` arg_usage, App fun' arg)
437 (fun_usage, fun') = occAnal env fun
438 arg_usage = occAnalArg env arg
440 -- For value lambdas we do a special hack. Consider
442 -- If we did nothing, x is used inside the \y, so would be marked
443 -- as dangerous to dup. But in the common case where the abstraction
444 -- is applied to two arguments this is over-pessimistic.
445 -- So instead we don't take account of the \y when dealing with x's usage;
446 -- instead, the simplifier is careful when partially applying lambdas
448 occAnal env expr@(Lam (ValBinder binder) body)
449 = (mapIdEnv markDangerousToDup final_usage,
450 foldr ( \v b -> Lam (ValBinder v) b) body' tagged_binders)
452 (binders,body) = collectValBinders expr
453 (body_usage, body') = occAnal (env `addNewCands` binders) body
454 (final_usage, tagged_binders) = tagBinders body_usage binders
456 -- ANDY: WE MUST THINK ABOUT THIS! (ToDo)
457 occAnal env (Lam (TyBinder tyvar) body)
458 = case occAnal env body of { (body_usage, body') ->
459 (mapIdEnv markDangerousToDup body_usage,
460 Lam (TyBinder tyvar) body') }
462 -- (body_usage, body') = occAnal env body
464 occAnal env (Lam (UsageBinder _) _) = panic "OccurAnal.occAnal Lam UsageBinder"
466 occAnal env (Case scrut alts)
467 = case occAnalAlts env alts of { (alts_usage, alts') ->
468 case occAnal env scrut of { (scrut_usage, scrut') ->
470 det = scrut_usage `combineUsageDetails` alts_usage
472 if isNullIdEnv det then
473 (det, Case scrut' alts')
475 (det, Case scrut' alts') }}
477 (scrut_usage `combineUsageDetails` alts_usage,
480 (scrut_usage, scrut') = occAnal env scrut
481 (alts_usage, alts') = occAnalAlts env alts
484 occAnal env (Let bind body)
485 = case occAnal new_env body of { (body_usage, body') ->
486 case occAnalBind env bind body_usage of { (final_usage, new_binds) ->
487 (final_usage, foldr Let body' new_binds) }} -- mkCoLet* wants Core... (sigh)
489 new_env = env `addNewCands` (bindersOf bind)
490 -- (body_usage, body') = occAnal new_env body
491 -- (final_usage, new_binds) = occAnalBind env bind body_usage
497 occAnalAlts env (AlgAlts alts deflt)
498 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
499 -- Note: combine*Alts*UsageDetails...
500 AlgAlts alts' deflt')
502 (alts_usage, alts') = unzip (map do_alt alts)
503 (deflt_usage, deflt') = occAnalDeflt env deflt
505 do_alt (con, args, rhs)
506 = (final_usage, (con, tagged_args, rhs'))
508 new_env = env `addNewCands` args
509 (rhs_usage, rhs') = occAnal new_env rhs
510 (final_usage, tagged_args) = tagBinders rhs_usage args
512 occAnalAlts env (PrimAlts alts deflt)
513 = (foldr combineAltsUsageDetails deflt_usage alts_usage,
514 -- Note: combine*Alts*UsageDetails...
515 PrimAlts alts' deflt')
517 (alts_usage, alts') = unzip (map do_alt alts)
518 (deflt_usage, deflt') = occAnalDeflt env deflt
521 = (rhs_usage, (lit, rhs'))
523 (rhs_usage, rhs') = occAnal env rhs
525 occAnalDeflt env NoDefault = (emptyDetails, NoDefault)
527 occAnalDeflt env (BindDefault binder rhs)
528 = (final_usage, BindDefault tagged_binder rhs')
530 new_env = env `addNewCand` binder
531 (rhs_usage, rhs') = occAnal new_env rhs
532 (final_usage, tagged_binder) = tagBinder rhs_usage binder
539 occAnalArgs :: OccEnv -> [CoreArg] -> UsageDetails
541 occAnalArgs env atoms
542 = foldr do_one_atom emptyDetails atoms
544 do_one_atom (VarArg v) usage
545 | isCandidate env v = addOneOcc usage v (argOccurrence 0)
547 do_one_atom other_arg usage = usage
550 occAnalArg :: OccEnv -> CoreArg -> UsageDetails
552 occAnalArg env (VarArg v)
553 | isCandidate env v = unitDetails v (argOccurrence 0)
554 | otherwise = emptyDetails
555 occAnalArg _ _ = emptyDetails