2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{Tidying up Core}
8 tidyCorePgm, tidyExpr, tidyCoreExpr,
12 #include "HsVersions.h"
14 import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
16 import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
17 import CoreUtils ( exprArity )
18 import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars )
19 import CoreLint ( showPass, endPass )
22 import Var ( Id, Var )
23 import Id ( idType, idInfo, idName, isExportedId,
24 idCafInfo, mkId, isLocalId, isImplicitId,
25 idFlavour, modifyIdInfo, idArity
27 import IdInfo {- loads of stuff -}
28 import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
29 localiseName, mkLocalName, isGlobalName, isDllName
31 import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
32 import Type ( tidyTopType, tidyType, tidyTyVar )
33 import Module ( Module, moduleName )
34 import PrimOp ( PrimOp(..), setCCallUnique )
35 import HscTypes ( PersistentCompilerState( pcs_PRS ),
36 PersistentRenamerState( prsOrig ),
37 NameSupply( nsNames ), OrigNameCache
40 import DataCon ( DataCon, dataConName )
41 import Literal ( isLitLitLit )
42 import FiniteMap ( lookupFM, addToFM )
43 import Maybes ( maybeToBool, orElse )
44 import ErrUtils ( showPass )
45 import PprCore ( pprIdCoreRule )
46 import SrcLoc ( noSrcLoc )
47 import UniqFM ( mapUFM )
50 import List ( partition )
51 import Util ( mapAccumL )
56 %************************************************************************
58 \subsection{What goes on}
60 %************************************************************************
66 Step 1: Figure out external Ids
67 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
68 First we figure out which Ids are "external" Ids. An
69 "external" Id is one that is visible from outside the compilation
71 a) the user exported ones
72 b) ones mentioned in the unfoldings, workers,
73 or rules of externally-visible ones
74 This exercise takes a sweep of the bindings bottom to top. Actually,
75 in Step 2 we're also going to need to know which Ids should be
76 exported with their unfoldings, so we produce not an IdSet but an
80 Step 2: Tidy the program
81 ~~~~~~~~~~~~~~~~~~~~~~~~
82 Next we traverse the bindings top to bottom. For each top-level
85 - Make all external Ids have Global names and vice versa
86 This is used by the code generator to decide whether
87 to make the label externally visible
89 - Give external ids a "tidy" occurrence name. This means
90 we can print them in interface files without confusing
91 "x" (unique 5) with "x" (unique 10).
93 - Give external Ids the same Unique as they had before
94 if the name is in the renamer's name cache
96 - Clone all local Ids. This means that Tidy Core has the property
97 that all Ids are unique, rather than the weaker guarantee of
98 no clashes which the simplifier provides.
100 - Give each dynamic CCall occurrence a fresh unique; this is
101 rather like the cloning step above.
103 - Give the Id its UTTERLY FINAL IdInfo; in ptic,
104 * Its flavour becomes ConstantId, reflecting the fact that
105 from now on we regard it as a constant, not local, Id
107 * its unfolding, if it should have one
109 * its arity, computed from the number of visible lambdas
111 * its CAF info, computed from what is free in its RHS
114 Finally, substitute these new top-level binders consistently
115 throughout, including in unfoldings. We also tidy binders in
116 RHSs, so that they print nicely in interfaces.
119 tidyCorePgm :: DynFlags -> Module
120 -> PersistentCompilerState
121 -> [CoreBind] -> [IdCoreRule]
122 -> IO (PersistentCompilerState, [CoreBind], [IdCoreRule])
123 tidyCorePgm dflags mod pcs binds_in orphans_in
124 = do { showPass dflags "Tidy Core"
126 ; let ext_ids = findExternalSet binds_in orphans_in
128 ; us <- mkSplitUniqSupply 't' -- for "tidy"
130 ; let ((us1, orig_env', occ_env, subst_env), binds_out)
131 = mapAccumL (tidyTopBind mod ext_ids)
132 (init_tidy_env us) binds_in
134 ; let (orphans_out, _)
135 = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in)
137 ; let prs' = prs { prsOrig = orig { nsNames = orig_env' } }
138 pcs' = pcs { pcs_PRS = prs' }
140 ; endPass dflags "Tidy Core" Opt_D_dump_simpl binds_out
142 ; return (pcs', binds_out, orphans_out)
145 -- We also make sure to avoid any exported binders. Consider
146 -- f{-u1-} = 1 -- Local decl
148 -- f{-u2-} = 2 -- Exported decl
150 -- The second exported decl must 'get' the name 'f', so we
151 -- have to put 'f' in the avoids list before we get to the first
152 -- decl. tidyTopId then does a no-op on exported binders.
155 orig_env = nsNames orig
157 init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
158 avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
159 isGlobalName (idName bndr)]
162 tidyCoreExpr :: CoreExpr -> IO CoreExpr
164 = do { us <- mkSplitUniqSupply 't' -- for "tidy"
165 ; let (expr',_) = initUs us (tidyExpr emptyTidyEnv expr)
171 %************************************************************************
173 \subsection{Step 1: finding externals}
175 %************************************************************************
178 findExternalSet :: [CoreBind] -> [IdCoreRule]
179 -> IdEnv Bool -- True <=> show unfolding
180 -- Step 1 from the notes above
181 findExternalSet binds orphan_rules
182 = foldr find init_needed binds
184 orphan_rule_ids :: IdSet
185 orphan_rule_ids = unionVarSets [ ruleSomeFreeVars isIdAndLocal rule
186 | (_, rule) <- orphan_rules]
187 init_needed :: IdEnv Bool
188 init_needed = mapUFM (\_ -> False) orphan_rule_ids
189 -- The mapUFM is a bit cheesy. It is a cheap way
190 -- to turn the set of orphan_rule_ids, which we use to initialise
191 -- the sweep, into a mapping saying 'don't expose unfolding'
192 -- (When we come to the binding site we may change our mind, of course.)
194 find (NonRec id rhs) needed
195 | need_id needed id = addExternal (id,rhs) needed
197 find (Rec prs) needed = find_prs prs needed
199 -- For a recursive group we have to look for a fixed point
201 | null needed_prs = needed
202 | otherwise = find_prs other_prs new_needed
204 (needed_prs, other_prs) = partition (need_pr needed) prs
205 new_needed = foldr addExternal needed needed_prs
207 -- The 'needed' set contains the Ids that are needed by earlier
208 -- interface file emissions. If the Id isn't in this set, and isn't
209 -- exported, there's no need to emit anything
210 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
211 need_pr needed_set (id,rhs) = need_id needed_set id
213 isIdAndLocal id = isId id && isLocalId id
215 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
216 -- The Id is needed; extend the needed set
217 -- with it and its dependents (free vars etc)
218 addExternal (id,rhs) needed
219 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
222 add_occ id needed = extendVarEnv needed id False
223 -- "False" because we don't know we need the Id's unfolding
224 -- We'll override it later when we find the binding site
226 new_needed_ids | opt_OmitInterfacePragmas = emptyVarSet
227 | otherwise = worker_ids `unionVarSet`
228 unfold_ids `unionVarSet`
232 dont_inline = isNeverInlinePrag (inlinePragInfo idinfo)
233 loop_breaker = isLoopBreaker (occInfo idinfo)
234 bottoming_fn = isBottomingStrictness (strictnessInfo idinfo)
235 spec_ids = rulesRhsFreeVars (specInfo idinfo)
236 worker_info = workerInfo idinfo
238 -- Stuff to do with the Id's unfolding
239 -- The simplifier has put an up-to-date unfolding
240 -- in the IdInfo, but the RHS will do just as well
241 unfolding = unfoldingInfo idinfo
242 rhs_is_small = not (neverUnfold unfolding)
244 -- We leave the unfolding there even if there is a worker
245 -- In GHCI the unfolding is used by importers
246 -- When writing an interface file, we omit the unfolding
247 -- if there is a worker
248 show_unfold = not bottoming_fn && -- Not necessary
251 rhs_is_small && -- Small enough
252 okToUnfoldInHiFile rhs -- No casms etc
254 unfold_ids | show_unfold = exprSomeFreeVars isIdAndLocal rhs
255 | otherwise = emptyVarSet
257 worker_ids = case worker_info of
258 HasWorker work_id _ -> unitVarSet work_id
259 otherwise -> emptyVarSet
263 %************************************************************************
265 \subsection{Step 2: top-level tidying}
267 %************************************************************************
271 type TopTidyEnv = (UniqSupply, OrigNameCache, TidyOccEnv, VarEnv Var)
273 -- TopTidyEnv: when tidying we need to know
274 -- * orig_env: Any pre-ordained Names. These may have arisen because the
275 -- renamer read in an interface file mentioning M.$wf, say,
276 -- and assigned it unique r77. If, on this compilation, we've
277 -- invented an Id whose name is $wf (but with a different unique)
278 -- we want to rename it to have unique r77, so that we can do easy
279 -- comparisons with stuff from the interface file
281 -- * occ_env: The TidyOccEnv, which tells us which local occurrences
284 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
286 -- * uniqsuppy: so we can clone any Ids with non-preordained names.
292 tidyTopBind :: Module
293 -> IdEnv Bool -- Domain = Ids that should be external
294 -- True <=> their unfolding is external too
295 -> TopTidyEnv -> CoreBind
296 -> (TopTidyEnv, CoreBind)
298 tidyTopBind mod ext_ids env (NonRec bndr rhs)
299 = ((us2,orig,occ,subst) , NonRec bndr' rhs')
301 ((us1,orig,occ,subst), bndr')
302 = tidyTopBinder mod ext_ids tidy_env rhs' caf_info env bndr
303 tidy_env = (occ,subst)
304 caf_info = hasCafRefs (const True) rhs'
305 (rhs',us2) = initUs us1 (tidyExpr tidy_env rhs)
307 tidyTopBind mod ext_ids env (Rec prs)
308 = (final_env, Rec prs')
310 (final_env@(_,_,occ,subst), prs') = mapAccumL do_one env prs
311 final_tidy_env = (occ,subst)
313 do_one env (bndr,rhs)
314 = ((us',orig,occ,subst), (bndr',rhs'))
316 ((us,orig,occ,subst), bndr')
317 = tidyTopBinder mod ext_ids final_tidy_env rhs' caf_info env bndr
318 (rhs', us') = initUs us (tidyExpr final_tidy_env rhs)
320 -- the CafInfo for a recursive group says whether *any* rhs in
321 -- the group may refer indirectly to a CAF (because then, they all do).
322 (bndrs, rhss) = unzip prs'
323 caf_info = hasCafRefss pred rhss
324 pred v = v `notElem` bndrs
327 tidyTopBinder :: Module -> IdEnv Bool
328 -> TidyEnv -> CoreExpr -> CafInfo
329 -- The TidyEnv is used to tidy the IdInfo
330 -- The expr is the already-tided RHS
331 -- Both are knot-tied: don't look at them!
332 -> TopTidyEnv -> Id -> (TopTidyEnv, Id)
334 tidyTopBinder mod ext_ids tidy_env rhs caf_info
335 env@(us, orig_env2, occ_env2, subst_env2) id
337 | isImplicitId id -- Don't mess with constructors,
338 = (env, id) -- record selectors, and the like
341 -- This function is the heart of Step 2
342 -- The second env is the one to use for the IdInfo
343 -- It's necessary because when we are dealing with a recursive
344 -- group, a variable late in the group might be mentioned
345 -- in the IdInfo of one early in the group
347 -- The rhs is already tidied
349 = ((us_r, orig_env', occ_env', subst_env'), id')
351 (us_l, us_r) = splitUniqSupply us
353 (orig_env', occ_env', name') = tidyTopName mod orig_env2 occ_env2
356 ty' = tidyTopType (idType id)
357 idinfo' = tidyIdInfo us_l tidy_env
358 is_external unfold_info arity_info caf_info id
360 id' = mkId name' ty' idinfo'
361 subst_env' = extendVarEnv subst_env2 id id'
363 maybe_external = lookupVarEnv ext_ids id
364 is_external = maybeToBool maybe_external
366 -- Expose an unfolding if ext_ids tells us to
367 show_unfold = maybe_external `orElse` False
368 unfold_info | show_unfold = mkTopUnfolding rhs
369 | otherwise = noUnfolding
371 arity_info = exprArity rhs
374 tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
375 | opt_OmitInterfacePragmas || not is_external
376 -- No IdInfo if the Id isn't external, or if we don't have -O
377 = mkIdInfo new_flavour caf_info
378 `setStrictnessInfo` strictnessInfo core_idinfo
379 `setArityInfo` ArityExactly arity_info
380 -- Keep strictness, arity and CAF info; it's used by the code generator
383 = let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
385 mkIdInfo new_flavour caf_info
386 `setCprInfo` cprInfo core_idinfo
387 `setStrictnessInfo` strictnessInfo core_idinfo
388 `setInlinePragInfo` inlinePragInfo core_idinfo
389 `setUnfoldingInfo` unfold_info
390 `setWorkerInfo` tidyWorker tidy_env arity_info (workerInfo core_idinfo)
392 `setArityInfo` ArityExactly arity_info
393 -- this is the final IdInfo, it must agree with the
394 -- code finally generated (i.e. NO more transformations
397 core_idinfo = idInfo id
398 new_flavour = makeConstantFlavour (flavourInfo core_idinfo)
399 -- A DFunId must stay a DFunId, so that we can gather the
400 -- DFunIds up later. Other local things become ConstantIds.
403 -- This is where we set names to local/global based on whether they really are
404 -- externally visible (see comment at the top of this module). If the name
405 -- was previously local, we have to give it a unique occurrence name if
406 -- we intend to globalise it.
407 tidyTopName mod orig_env occ_env external name
408 | global && internal = (orig_env, occ_env, localiseName name)
410 | local && internal = (orig_env, occ_env', setNameOcc name occ')
411 -- Even local, internal names must get a unique occurrence, because
412 -- if we do -split-objs we globalise the name later, n the code generator
414 | global && external = (orig_env, occ_env, name)
415 -- Global names are assumed to have been allocated by the renamer,
416 -- so they already have the "right" unique
418 | local && external = case lookupFM orig_env key of
419 Just orig -> (orig_env, occ_env', orig)
420 Nothing -> (addToFM orig_env key global_name, occ_env', global_name)
421 -- If we want to globalise a currently-local name, check
422 -- whether we have already assigned a unique for it.
423 -- If so, use it; if not, extend the table
426 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
427 key = (moduleName mod, occ')
428 global_name = globaliseName (setNameOcc name occ') mod
429 global = isGlobalName name
431 internal = not external
433 ------------ Worker --------------
434 -- We only treat a function as having a worker if
435 -- the exported arity (which is now the number of visible lambdas)
436 -- is the same as the arity at the moment of the w/w split
437 -- If so, we can safely omit the unfolding inside the wrapper, and
438 -- instead re-generate it from the type/arity/strictness info
439 -- But if the arity has changed, we just take the simple path and
440 -- put the unfolding into the interface file, forgetting the fact
441 -- that it's a wrapper.
443 -- How can this happen? Sometimes we get
444 -- f = coerce t (\x y -> $wf x y)
445 -- at the moment of w/w split; but the eta reducer turns it into
447 -- which is perfectly fine except that the exposed arity so far as
448 -- the code generator is concerned (zero) differs from the arity
449 -- when we did the split (2).
451 -- All this arises because we use 'arity' to mean "exactly how many
452 -- top level lambdas are there" in interface files; but during the
453 -- compilation of this module it means "how many things can I apply
455 tidyWorker tidy_env real_arity (HasWorker work_id wrap_arity)
456 | real_arity == wrap_arity
457 = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
458 tidyWorker tidy_env real_arity other
461 ------------ Rules --------------
462 tidyIdRules :: TidyEnv -> [IdCoreRule] -> UniqSM [IdCoreRule]
463 tidyIdRules env [] = returnUs []
464 tidyIdRules env ((fn,rule) : rules)
465 = tidyRule env rule `thenUs` \ rule ->
466 tidyIdRules env rules `thenUs` \ rules ->
467 returnUs ((tidyVarOcc env fn, rule) : rules)
469 tidyRules :: TidyEnv -> CoreRules -> UniqSM CoreRules
470 tidyRules env (Rules rules fvs)
471 = mapUs (tidyRule env) rules `thenUs` \ rules ->
472 returnUs (Rules rules (foldVarSet tidy_set_elem emptyVarSet fvs))
474 tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
476 tidyRule :: TidyEnv -> CoreRule -> UniqSM CoreRule
477 tidyRule env rule@(BuiltinRule _) = returnUs rule
478 tidyRule env (Rule name vars tpl_args rhs)
479 = tidyBndrs env vars `thenUs` \ (env', vars) ->
480 mapUs (tidyExpr env') tpl_args `thenUs` \ tpl_args ->
481 tidyExpr env' rhs `thenUs` \ rhs ->
482 returnUs (Rule name vars tpl_args rhs)
485 %************************************************************************
487 \subsection{Step 2: inner tidying
489 %************************************************************************
494 -> UniqSM (TidyEnv, CoreBind)
495 tidyBind env (NonRec bndr rhs)
496 = tidyBndrWithRhs env (bndr,rhs) `thenUs` \ (env', bndr') ->
497 tidyExpr env' rhs `thenUs` \ rhs' ->
498 returnUs (env', NonRec bndr' rhs')
500 tidyBind env (Rec prs)
501 = mapAccumLUs tidyBndrWithRhs env prs `thenUs` \ (env', bndrs') ->
502 mapUs (tidyExpr env') (map snd prs) `thenUs` \ rhss' ->
503 returnUs (env', Rec (zip bndrs' rhss'))
506 = fiddleCCall v `thenUs` \ v ->
507 returnUs (Var (tidyVarOcc env v))
509 tidyExpr env (Type ty) = returnUs (Type (tidyType env ty))
510 tidyExpr env (Lit lit) = returnUs (Lit lit)
512 tidyExpr env (App f a)
513 = tidyExpr env f `thenUs` \ f ->
514 tidyExpr env a `thenUs` \ a ->
517 tidyExpr env (Note n e)
518 = tidyExpr env e `thenUs` \ e ->
519 returnUs (Note (tidyNote env n) e)
521 tidyExpr env (Let b e)
522 = tidyBind env b `thenUs` \ (env', b') ->
523 tidyExpr env' e `thenUs` \ e ->
526 tidyExpr env (Case e b alts)
527 = tidyExpr env e `thenUs` \ e ->
528 tidyBndr env b `thenUs` \ (env', b) ->
529 mapUs (tidyAlt env') alts `thenUs` \ alts ->
530 returnUs (Case e b alts)
532 tidyExpr env (Lam b e)
533 = tidyBndr env b `thenUs` \ (env', b) ->
534 tidyExpr env' e `thenUs` \ e ->
538 tidyAlt env (con, vs, rhs)
539 = tidyBndrs env vs `thenUs` \ (env', vs) ->
540 tidyExpr env' rhs `thenUs` \ rhs ->
541 returnUs (con, vs, rhs)
543 tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
544 tidyNote env note = note
548 %************************************************************************
550 \subsection{Tidying up non-top-level binders}
552 %************************************************************************
555 tidyVarOcc (_, var_env) v = case lookupVarEnv var_env v of
559 -- tidyBndr is used for lambda and case binders
560 tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var)
562 | isTyVar var = returnUs (tidyTyVar env var)
563 | otherwise = tidyId env var vanillaIdInfo
565 tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var])
566 tidyBndrs env vars = mapAccumLUs tidyBndr env vars
568 -- tidyBndrWithRhs is used for let binders
569 tidyBndrWithRhs :: TidyEnv -> (Var, CoreExpr) -> UniqSM (TidyEnv, Var)
570 tidyBndrWithRhs env (id,rhs)
571 = tidyId env id idinfo
573 idinfo = vanillaIdInfo `setArityInfo` ArityExactly (exprArity rhs)
574 -- NB: This throws away the IdInfo of the Id, which we
575 -- no longer need. That means we don't need to
576 -- run over it with env, nor renumber it.
578 tidyId :: TidyEnv -> Id -> IdInfo -> UniqSM (TidyEnv, Id)
579 tidyId env@(tidy_env, var_env) id idinfo
580 = -- Non-top-level variables
581 getUniqueUs `thenUs` \ uniq ->
583 -- Give the Id a fresh print-name, *and* rename its type
584 -- The SrcLoc isn't important now,
585 -- though we could extract it from the Id
586 name' = mkLocalName uniq occ' noSrcLoc
587 (tidy_env', occ') = tidyOccName tidy_env (getOccName id)
588 ty' = tidyType (tidy_env,var_env) (idType id)
589 id' = mkId name' ty' idinfo
590 var_env' = extendVarEnv var_env id id'
592 returnUs ((tidy_env', var_env'), id')
596 = case idFlavour id of
597 PrimOpId (CCallOp ccall) ->
598 -- Make a guaranteed unique name for a dynamic ccall.
599 getUniqueUs `thenUs` \ uniq ->
600 returnUs (modifyIdInfo (`setFlavourInfo`
601 PrimOpId (CCallOp (setCCallUnique ccall uniq))) id)
606 %************************************************************************
608 \subsection{Figuring out CafInfo for an expression}
610 %************************************************************************
612 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
613 We mark such things as `MayHaveCafRefs' because this information is
614 used to decide whether a particular closure needs to be referenced
617 There are two reasons for setting MayHaveCafRefs:
618 a) The RHS is a CAF: a top-level updatable thunk.
619 b) The RHS refers to something that MayHaveCafRefs
621 Possible improvement: In an effort to keep the number of CAFs (and
622 hence the size of the SRTs) down, we could also look at the expression and
623 decide whether it requires a small bounded amount of heap, so we can ignore
624 it as a CAF. In these cases however, we would need to use an additional
625 CAF list to keep track of non-collectable CAFs.
628 hasCafRefs :: (Id -> Bool) -> CoreExpr -> CafInfo
629 -- Only called for the RHS of top-level lets
630 hasCafRefss :: (Id -> Bool) -> [CoreExpr] -> CafInfo
631 -- predicate returns True for a given Id if we look at this Id when
632 -- calculating the result. Used to *avoid* looking at the CafInfo
633 -- field for an Id that is part of the current recursive group.
635 hasCafRefs p expr = if isCAF expr || isFastTrue (cafRefs p expr)
639 -- used for recursive groups. The whole group is set to
640 -- "MayHaveCafRefs" if at least one of the group is a CAF or
641 -- refers to any CAFs.
642 hasCafRefss p exprs = if any isCAF exprs || isFastTrue (cafRefss p exprs)
648 = case idCafInfo id of
649 NoCafRefs -> fastBool False
650 MayHaveCafRefs -> fastBool True
654 cafRefs p (Lit l) = fastBool False
655 cafRefs p (App f a) = cafRefs p f `fastOr` cafRefs p a
656 cafRefs p (Lam x e) = cafRefs p e
657 cafRefs p (Let b e) = cafRefss p (rhssOfBind b) `fastOr` cafRefs p e
658 cafRefs p (Case e bndr alts) = cafRefs p e `fastOr` cafRefss p (rhssOfAlts alts)
659 cafRefs p (Note n e) = cafRefs p e
660 cafRefs p (Type t) = fastBool False
662 cafRefss p [] = fastBool False
663 cafRefss p (e:es) = cafRefs p e `fastOr` cafRefss p es
666 isCAF :: CoreExpr -> Bool
667 -- Only called for the RHS of top-level lets
668 isCAF e = not (rhsIsNonUpd e)
669 {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
671 rhsIsNonUpd :: CoreExpr -> Bool
672 -- True => Value-lambda, constructor, PAP
673 -- This is a bit like CoreUtils.exprIsValue, with the following differences:
674 -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
676 -- b) (C x xs), where C is a contructors is updatable if the application is
677 -- dynamic: see isDynConApp
679 -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
681 rhsIsNonUpd (Lam b e) = isId b || rhsIsNonUpd e
682 rhsIsNonUpd (Note (SCC _) e) = False
683 rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
684 rhsIsNonUpd other_expr
687 go (Var f) n_args args = idAppIsNonUpd f n_args args
689 go (App f a) n_args args
690 | isTypeArg a = go f n_args args
691 | otherwise = go f (n_args + 1) (a:args)
693 go (Note (SCC _) f) n_args args = False
694 go (Note _ f) n_args args = go f n_args args
696 go other n_args args = False
698 idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
699 idAppIsNonUpd id n_val_args args
700 = case idFlavour id of
701 DataConId con | not (isDynConApp con args) -> True
702 other -> n_val_args < idArity id
704 isDynConApp :: DataCon -> [CoreExpr] -> Bool
705 isDynConApp con args = isDllName (dataConName con) || any isDynArg args
706 -- Top-level constructor applications can usually be allocated
707 -- statically, but they can't if
708 -- a) the constructor, or any of the arguments, come from another DLL
709 -- b) any of the arguments are LitLits
710 -- (because we can't refer to static labels in other DLLs).
711 -- If this happens we simply make the RHS into an updatable thunk,
712 -- and 'exectute' it rather than allocating it statically.
713 -- All this should match the decision in (see CoreToStg.coreToStgRhs)
716 isDynArg :: CoreExpr -> Bool
717 isDynArg (Var v) = isDllName (idName v)
718 isDynArg (Note _ e) = isDynArg e
719 isDynArg (Lit lit) = isLitLitLit lit
720 isDynArg (App e _) = isDynArg e -- must be a type app
721 isDynArg (Lam _ e) = isDynArg e -- must be a type lam