2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{Tidying up Core}
7 module TidyPgm( simpleTidyPgm, optTidyPgm ) where
9 #include "HsVersions.h"
11 import DynFlags ( DynFlags, DynFlag(..) )
13 import CoreUnfold ( noUnfolding, mkTopUnfolding )
14 import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars )
15 import CoreTidy ( tidyExpr, tidyVarOcc, tidyRules )
16 import PprCore ( pprRules )
17 import CoreLint ( showPass, endPass )
18 import CoreUtils ( exprArity, rhsIsStatic )
21 import Var ( Id, Var )
22 import Id ( idType, idInfo, idName, idCoreRules, isGlobalId,
23 isExportedId, mkVanillaGlobal, isLocalId,
26 import IdInfo {- loads of stuff -}
27 import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId )
28 import NewDemand ( isBottomingSig, topSig )
29 import BasicTypes ( Arity, isNeverActive )
30 import Name ( Name, getOccName, nameOccName, mkInternalName,
31 localiseName, isExternalName, nameSrcLoc, nameParent_maybe,
32 isWiredInName, getName
34 import NameSet ( NameSet, elemNameSet )
35 import IfaceEnv ( allocateGlobalBinder )
36 import NameEnv ( filterNameEnv )
37 import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
38 import Type ( tidyTopType )
39 import TcType ( isFFITy )
40 import DataCon ( dataConName, dataConFieldLabels )
41 import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, newTyConRep )
42 import Module ( Module )
43 import HscTypes ( HscEnv(..), NameCache( nsUniqs ),
44 TypeEnv, typeEnvIds, typeEnvElts, extendTypeEnvWithIds, mkTypeEnv,
45 ModGuts(..), ModGuts, TyThing(..)
47 import Maybes ( orElse, mapCatMaybes )
48 import ErrUtils ( showPass, dumpIfSet_core )
49 import UniqSupply ( splitUniqSupply, uniqFromSupply )
50 import List ( partition )
51 import Maybe ( isJust )
53 import DATA_IOREF ( IORef, readIORef, writeIORef )
54 import FastTypes hiding ( fastOr )
58 Constructing the TypeEnv, Instances, Rules from which the ModIface is
59 constructed, and which goes on to subsequent modules in --make mode.
61 Most of the interface file is obtained simply by serialising the
62 TypeEnv. One important consequence is that if the *interface file*
63 has pragma info if and only if the final TypeEnv does. This is not so
64 important for *this* module, but it's essential for ghc --make:
65 subsequent compilations must not see (e.g.) the arity if the interface
66 file does not contain arity If they do, they'll exploit the arity;
67 then the arity might change, but the iface file doesn't change =>
68 recompilation does not happen => disaster.
70 For data types, the final TypeEnv will have a TyThing for the TyCon,
71 plus one for each DataCon; the interface file will contain just one
72 data type declaration, but it is de-serialised back into a collection
75 %************************************************************************
79 %************************************************************************
82 Plan A: simpleTidyPgm: omit pragmas, make interfaces small
83 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
86 * Drop all WiredIn things from the TypeEnv
87 (we never want them in interface files)
88 (why are they there? I think mainly as a memo
89 to avoid repeatedly checking that we've loaded their
90 home interface; but I'm not certain)
92 * Retain all TyCons and Classes in the TypeEnv, to avoid
93 having to find which ones are mentioned in the
96 * Trim off the constructors of non-exported TyCons, both
97 from the TyCon and from the TypeEnv
99 * Drop non-exported Ids from the TypeEnv
101 * Tidy the types of the DFunIds of Instances,
102 make them into GlobalIds, (they already have External Names)
103 and add them to the TypeEnv
105 * Tidy the types of the (exported) Ids in the TypeEnv,
106 make them into GlobalIds (they already have External Names)
108 * Drop rules altogether
110 * Leave the bindings untouched. There's no need to make the Ids
111 in the bindings into Globals, think, ever.
115 simpleTidyPgm :: HscEnv -> ModGuts -> IO ModGuts
116 -- This is Plan A: make a small type env when typechecking only,
117 -- or when compiling a hs-boot file, or simply when not using -O
119 simpleTidyPgm hsc_env mod_impl@(ModGuts { mg_exports = exports,
122 = do { let dflags = hsc_dflags hsc_env
123 ; showPass dflags "Tidy Type Env"
125 ; let { ispecs' = tidyInstances tidyExternalId ispecs
127 ; things' = mapCatMaybes (tidyThing exports)
128 (typeEnvElts type_env)
130 ; type_env' = extendTypeEnvWithIds (mkTypeEnv things')
131 (map instanceDFunId ispecs')
134 ; return (mod_impl { mg_types = type_env'
139 tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance]
140 tidyInstances tidy_dfun ispecs
143 tidy ispec = setInstanceDFunId ispec (tidy_dfun (instanceDFunId ispec))
145 tidyThing :: NameSet -- Exports
146 -> TyThing -> Maybe TyThing -- Nothing => drop it
147 tidyThing exports thing
148 | isWiredInName (getName thing)
152 AClass cl -> Just thing
155 | mustExposeTyCon exports tc -> Just thing
156 | otherwise -> Just (ATyCon (makeTyConAbstract tc))
159 | getName dc `elemNameSet` exports -> Just thing
160 | otherwise -> Nothing
163 | not (getName id `elemNameSet` exports) -> Nothing
164 | not (isLocalId id) -> Just thing -- Implicit Ids such as class ops,
165 -- data-con wrappers etc
166 | otherwise -> Just (AnId (tidyExternalId id))
168 tidyExternalId :: Id -> Id
169 -- Takes an LocalId with an External Name,
170 -- makes it into a GlobalId with VanillaIdInfo, and tidies its type
171 -- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.)
173 = ASSERT2( isLocalId id && isExternalName (idName id), ppr id )
174 mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo
176 mustExposeTyCon :: NameSet -- Exports
177 -> TyCon -- The tycon
178 -> Bool -- Can its rep be hidden?
179 -- We are compiling without -O, and thus trying to write as little as
180 -- possible into the interface file. But we must expose the details of
181 -- any data types whose constructors or fields are exported
182 mustExposeTyCon exports tc
183 = any exported_con (tyConDataCons tc)
184 -- Expose rep if any datacon or field is exported
186 || (isNewTyCon tc && isFFITy (snd (newTyConRep tc)))
187 -- Expose the rep for newtypes if the rep is an FFI type.
188 -- For a very annoying reason. 'Foreign import' is meant to
189 -- be able to look through newtypes transparently, but it
190 -- can only do that if it can "see" the newtype representation
192 exported_con con = any (`elemNameSet` exports)
193 (dataConName con : dataConFieldLabels con)
197 %************************************************************************
199 Plan B: tidy bindings, make TypeEnv full of IdInfo
201 %************************************************************************
203 Plan B: include pragmas, make interfaces
204 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
205 * Figure out which Ids are externally visible
207 * Tidy the bindings, externalising appropriate Ids
209 * Drop all Ids from the TypeEnv, and add all the External Ids from
210 the bindings. (This adds their IdInfo to the TypeEnv; and adds
211 floated-out Ids that weren't even in the TypeEnv before.)
213 Step 1: Figure out external Ids
214 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
215 First we figure out which Ids are "external" Ids. An
216 "external" Id is one that is visible from outside the compilation
218 a) the user exported ones
219 b) ones mentioned in the unfoldings, workers,
220 or rules of externally-visible ones
221 This exercise takes a sweep of the bindings bottom to top. Actually,
222 in Step 2 we're also going to need to know which Ids should be
223 exported with their unfoldings, so we produce not an IdSet but an
227 Step 2: Tidy the program
228 ~~~~~~~~~~~~~~~~~~~~~~~~
229 Next we traverse the bindings top to bottom. For each *top-level*
232 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,
233 reflecting the fact that from now on we regard it as a global,
236 2. Give it a system-wide Unique.
237 [Even non-exported things need system-wide Uniques because the
238 byte-code generator builds a single Name->BCO symbol table.]
240 We use the NameCache kept in the HscEnv as the
241 source of such system-wide uniques.
243 For external Ids, use the original-name cache in the NameCache
244 to ensure that the unique assigned is the same as the Id had
245 in any previous compilation run.
247 3. If it's an external Id, make it have a External Name, otherwise
248 make it have an Internal Name.
249 This is used by the code generator to decide whether
250 to make the label externally visible
252 4. Give external Ids a "tidy" OccName. This means
253 we can print them in interface files without confusing
254 "x" (unique 5) with "x" (unique 10).
256 5. Give it its UTTERLY FINAL IdInfo; in ptic,
257 * its unfolding, if it should have one
259 * its arity, computed from the number of visible lambdas
261 * its CAF info, computed from what is free in its RHS
264 Finally, substitute these new top-level binders consistently
265 throughout, including in unfoldings. We also tidy binders in
266 RHSs, so that they print nicely in interfaces.
269 optTidyPgm :: HscEnv -> ModGuts -> IO ModGuts
272 mod_impl@(ModGuts { mg_module = mod,
273 mg_types = env_tc, mg_insts = insts_tc,
275 mg_rules = imp_rules })
276 = do { let dflags = hsc_dflags hsc_env
277 ; showPass dflags "Tidy Core"
279 ; let ext_ids = findExternalIds binds_in
280 ; let ext_rules = findExternalRules binds_in imp_rules ext_ids
281 -- findExternalRules filters imp_rules to avoid binders that
282 -- aren't externally visible; but the externally-visible binders
283 -- are computed (by findExternalIds) assuming that all orphan
284 -- rules are exported (they get their Exported flag set in the desugarer)
285 -- So in fact we may export more than we need.
286 -- (It's a sort of mutual recursion.)
288 ; (final_env, tidy_binds) <- tidyTopBinds hsc_env mod env_tc
291 ; let { tidy_rules = tidyRules final_env ext_rules
292 ; tidy_type_env = tidyTypeEnv env_tc tidy_binds
293 ; tidy_ispecs = tidyInstances (tidyVarOcc final_env) insts_tc
294 -- A DFunId will have a binding in tidy_binds, and so
295 -- will now be in final_env, replete with IdInfo
296 -- Its name will be unchanged since it was born, but
297 -- we want Global, IdInfo-rich DFunId in the tidy_ispecs
300 ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
301 ; dumpIfSet_core dflags Opt_D_dump_simpl
303 (pprRules tidy_rules)
305 ; return (mod_impl { mg_types = tidy_type_env,
306 mg_rules = tidy_rules,
307 mg_insts = tidy_ispecs,
308 mg_binds = tidy_binds })
312 tidyTypeEnv :: TypeEnv -- From typechecker
313 -> [CoreBind] -- Final Ids
316 -- The competed type environment is gotten from
317 -- Dropping any wired-in things, and then
318 -- a) keeping the types and classes
319 -- b) removing all Ids,
320 -- c) adding Ids with correct IdInfo, including unfoldings,
321 -- gotten from the bindings
322 -- From (c) we keep only those Ids with External names;
323 -- the CoreTidy pass makes sure these are all and only
324 -- the externally-accessible ones
325 -- This truncates the type environment to include only the
326 -- exported Ids and things needed from them, which saves space
328 tidyTypeEnv type_env tidy_binds
329 = extendTypeEnvWithIds (filterNameEnv keep_it type_env) final_ids
332 | bind <- tidy_binds,
333 id <- bindersOf bind,
334 isExternalName (idName id)]
336 -- We keep GlobalIds, because they won't appear
337 -- in the bindings from which final_ids are derived!
338 -- (The bindings bind LocalIds.)
339 keep_it thing | isWiredInName (getName thing) = False
340 keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops)
341 keep_it other = True -- Keep all TyCons, DataCons, and Classes
344 %************************************************************************
346 \subsection{Step 1: finding externals}
348 %************************************************************************
351 findExternalIds :: [CoreBind]
352 -> IdEnv Bool -- In domain => external
353 -- Range = True <=> show unfolding
354 -- Step 1 from the notes above
355 findExternalIds binds
356 = foldr find emptyVarEnv binds
358 find (NonRec id rhs) needed
359 | need_id needed id = addExternal (id,rhs) needed
361 find (Rec prs) needed = find_prs prs needed
363 -- For a recursive group we have to look for a fixed point
365 | null needed_prs = needed
366 | otherwise = find_prs other_prs new_needed
368 (needed_prs, other_prs) = partition (need_pr needed) prs
369 new_needed = foldr addExternal needed needed_prs
371 -- The 'needed' set contains the Ids that are needed by earlier
372 -- interface file emissions. If the Id isn't in this set, and isn't
373 -- exported, there's no need to emit anything
374 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
375 need_pr needed_set (id,rhs) = need_id needed_set id
377 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
378 -- The Id is needed; extend the needed set
379 -- with it and its dependents (free vars etc)
380 addExternal (id,rhs) needed
381 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
384 add_occ id needed = extendVarEnv needed id False
385 -- "False" because we don't know we need the Id's unfolding
386 -- We'll override it later when we find the binding site
388 new_needed_ids = worker_ids `unionVarSet`
389 unfold_ids `unionVarSet`
393 dont_inline = isNeverActive (inlinePragInfo idinfo)
394 loop_breaker = isLoopBreaker (occInfo idinfo)
395 bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
396 spec_ids = specInfoFreeVars (specInfo idinfo)
397 worker_info = workerInfo idinfo
399 -- Stuff to do with the Id's unfolding
400 -- The simplifier has put an up-to-date unfolding
401 -- in the IdInfo, but the RHS will do just as well
402 unfolding = unfoldingInfo idinfo
403 rhs_is_small = not (neverUnfold unfolding)
405 -- We leave the unfolding there even if there is a worker
406 -- In GHCI the unfolding is used by importers
407 -- When writing an interface file, we omit the unfolding
408 -- if there is a worker
409 show_unfold = not bottoming_fn && -- Not necessary
412 rhs_is_small -- Small enough
414 unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
415 | otherwise = emptyVarSet
417 worker_ids = case worker_info of
418 HasWorker work_id _ -> unitVarSet work_id
419 otherwise -> emptyVarSet
424 findExternalRules :: [CoreBind]
425 -> [CoreRule] -- Non-local rules (i.e. ones for imported fns)
426 -> IdEnv a -- Ids that are exported, so we need their rules
428 -- The complete rules are gotten by combining
429 -- a) the non-local rules
430 -- b) rules embedded in the top-level Ids
431 findExternalRules binds non_local_rules ext_ids
432 = filter (not . internal_rule) (non_local_rules ++ local_rules)
435 | id <- bindersOfBinds binds,
436 id `elemVarEnv` ext_ids,
437 rule <- idCoreRules id
441 = any internal_id (varSetElems (ruleLhsFreeIds rule))
442 -- Don't export a rule whose LHS mentions a locally-defined
443 -- Id that is completely internal (i.e. not visible to an
446 internal_id id = not (id `elemVarEnv` ext_ids)
451 %************************************************************************
453 \subsection{Step 2: top-level tidying}
455 %************************************************************************
459 -- TopTidyEnv: when tidying we need to know
460 -- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.
461 -- These may have arisen because the
462 -- renamer read in an interface file mentioning M.$wf, say,
463 -- and assigned it unique r77. If, on this compilation, we've
464 -- invented an Id whose name is $wf (but with a different unique)
465 -- we want to rename it to have unique r77, so that we can do easy
466 -- comparisons with stuff from the interface file
468 -- * occ_env: The TidyOccEnv, which tells us which local occurrences
471 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
473 tidyTopBinds :: HscEnv
476 -> IdEnv Bool -- Domain = Ids that should be external
477 -- True <=> their unfolding is external too
479 -> IO (TidyEnv, [CoreBind])
481 tidyTopBinds hsc_env mod env_tc ext_ids binds
484 dflags = hsc_dflags hsc_env
485 nc_var = hsc_NC hsc_env
487 -- We also make sure to avoid any exported binders. Consider
488 -- f{-u1-} = 1 -- Local decl
490 -- f{-u2-} = 2 -- Exported decl
492 -- The second exported decl must 'get' the name 'f', so we
493 -- have to put 'f' in the avoids list before we get to the first
494 -- decl. tidyTopId then does a no-op on exported binders.
495 init_env = (initTidyOccEnv avoids, emptyVarEnv)
496 avoids = [getOccName name | bndr <- typeEnvIds env_tc,
497 let name = idName bndr,
499 -- In computing our "avoids" list, we must include
501 -- all things with global names (assigned once and for
502 -- all by the renamer)
503 -- since their names are "taken".
504 -- The type environment is a convenient source of such things.
506 go env [] = return (env, [])
507 go env (b:bs) = do { (env1, b') <- tidyTopBind dflags mod nc_var ext_ids env b
508 ; (env2, bs') <- go env1 bs
509 ; return (env2, b':bs') }
511 ------------------------
512 tidyTopBind :: DynFlags
514 -> IORef NameCache -- For allocating new unique names
515 -> IdEnv Bool -- Domain = Ids that should be external
516 -- True <=> their unfolding is external too
517 -> TidyEnv -> CoreBind
518 -> IO (TidyEnv, CoreBind)
520 tidyTopBind dflags mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs)
521 = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr
522 ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs)
523 ; subst2 = extendVarEnv subst1 bndr bndr'
524 ; tidy_env2 = (occ_env2, subst2) }
525 ; return (tidy_env2, NonRec bndr' rhs') }
527 caf_info = hasCafRefs dflags subst1 (idArity bndr) rhs
529 tidyTopBind dflags mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
530 = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs
531 ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info)
533 ; subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs')
534 ; tidy_env2 = (occ_env2, subst2) }
535 ; return (tidy_env2, Rec prs') }
539 -- the CafInfo for a recursive group says whether *any* rhs in
540 -- the group may refer indirectly to a CAF (because then, they all do).
542 | or [ mayHaveCafRefs (hasCafRefs dflags subst1 (idArity bndr) rhs)
543 | (bndr,rhs) <- prs ] = MayHaveCafRefs
544 | otherwise = NoCafRefs
546 --------------------------------------------------------------------
548 -- This is where we set names to local/global based on whether they really are
549 -- externally visible (see comment at the top of this module). If the name
550 -- was previously local, we have to give it a unique occurrence name if
551 -- we intend to externalise it.
552 tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, [])
553 tidyTopNames mod nc_var ext_ids occ_env (id:ids)
554 = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id
555 ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids
556 ; return (occ_env2, name:names) }
558 tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv
559 -> Id -> IO (TidyOccEnv, Name)
560 tidyTopName mod nc_var ext_ids occ_env id
561 | global && internal = return (occ_env, localiseName name)
563 | global && external = return (occ_env, name)
564 -- Global names are assumed to have been allocated by the renamer,
565 -- so they already have the "right" unique
566 -- And it's a system-wide unique too
568 -- Now we get to the real reason that all this is in the IO Monad:
569 -- we have to update the name cache in a nice atomic fashion
571 | local && internal = do { nc <- readIORef nc_var
572 ; let (nc', new_local_name) = mk_new_local nc
573 ; writeIORef nc_var nc'
574 ; return (occ_env', new_local_name) }
575 -- Even local, internal names must get a unique occurrence, because
576 -- if we do -split-objs we externalise the name later, in the code generator
578 -- Similarly, we must make sure it has a system-wide Unique, because
579 -- the byte-code generator builds a system-wide Name->BCO symbol table
581 | local && external = do { nc <- readIORef nc_var
582 ; let (nc', new_external_name) = mk_new_external nc
583 ; writeIORef nc_var nc'
584 ; return (occ_env', new_external_name) }
587 external = id `elemVarEnv` ext_ids
588 global = isExternalName name
590 internal = not external
591 mb_parent = nameParent_maybe name
592 loc = nameSrcLoc name
594 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
596 mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc)
598 (us1, us2) = splitUniqSupply (nsUniqs nc)
599 uniq = uniqFromSupply us1
601 mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc
602 -- If we want to externalise a currently-local name, check
603 -- whether we have already assigned a unique for it.
604 -- If so, use it; if not, extend the table.
605 -- All this is done by allcoateGlobalBinder.
606 -- This is needed when *re*-compiling a module in GHCi; we must
607 -- use the same name for externally-visible things as we did before.
610 -----------------------------------------------------------
611 tidyTopPair :: VarEnv Bool
612 -> TidyEnv -- The TidyEnv is used to tidy the IdInfo
613 -- It is knot-tied: don't look at it!
616 -> (Id, CoreExpr) -- Binder and RHS before tidying
618 -- This function is the heart of Step 2
619 -- The rec_tidy_env is the one to use for the IdInfo
620 -- It's necessary because when we are dealing with a recursive
621 -- group, a variable late in the group might be mentioned
622 -- in the IdInfo of one early in the group
624 tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs)
625 = ASSERT(isLocalId bndr) -- "all Ids defined in this module are local
626 -- until the CoreTidy phase" --GHC comentary
629 bndr' = mkVanillaGlobal name' ty' idinfo'
630 ty' = tidyTopType (idType bndr)
631 rhs' = tidyExpr rhs_tidy_env rhs
632 idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external)
633 (idInfo bndr) unfold_info arity
636 -- Expose an unfolding if ext_ids tells us to
637 -- Remember that ext_ids maps an Id to a Bool:
638 -- True to show the unfolding, False to hide it
639 maybe_external = lookupVarEnv ext_ids bndr
640 show_unfold = maybe_external `orElse` False
641 unfold_info | show_unfold = mkTopUnfolding rhs'
642 | otherwise = noUnfolding
644 -- Usually the Id will have an accurate arity on it, because
645 -- the simplifier has just run, but not always.
646 -- One case I found was when the last thing the simplifier
647 -- did was to let-bind a non-atomic argument and then float
648 -- it to the top level. So it seems more robust just to
650 arity = exprArity rhs
653 -- tidyTopIdInfo creates the final IdInfo for top-level
654 -- binders. There are two delicate pieces:
656 -- * Arity. After CoreTidy, this arity must not change any more.
657 -- Indeed, CorePrep must eta expand where necessary to make
658 -- the manifest arity equal to the claimed arity.
660 -- * CAF info. This must also remain valid through to code generation.
661 -- We add the info here so that it propagates to all
662 -- occurrences of the binders in RHSs, and hence to occurrences in
663 -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
664 -- CoreToStg makes use of this when constructing SRTs.
666 tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info
667 | not is_external -- For internal Ids (not externally visible)
668 = vanillaIdInfo -- we only need enough info for code generation
669 -- Arity and strictness info are enough;
670 -- c.f. CoreTidy.tidyLetBndr
671 `setCafInfo` caf_info
673 `setAllStrictnessInfo` newStrictnessInfo idinfo
675 | otherwise -- Externally-visible Ids get the whole lot
677 `setCafInfo` caf_info
679 `setAllStrictnessInfo` newStrictnessInfo idinfo
680 `setInlinePragInfo` inlinePragInfo idinfo
681 `setUnfoldingInfo` unfold_info
682 `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo)
683 -- NB: we throw away the Rules
684 -- They have already been extracted by findExternalRules
688 ------------ Worker --------------
689 tidyWorker tidy_env (HasWorker work_id wrap_arity)
690 = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
691 tidyWorker tidy_env other
695 %************************************************************************
697 \subsection{Figuring out CafInfo for an expression}
699 %************************************************************************
701 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
702 We mark such things as `MayHaveCafRefs' because this information is
703 used to decide whether a particular closure needs to be referenced
706 There are two reasons for setting MayHaveCafRefs:
707 a) The RHS is a CAF: a top-level updatable thunk.
708 b) The RHS refers to something that MayHaveCafRefs
710 Possible improvement: In an effort to keep the number of CAFs (and
711 hence the size of the SRTs) down, we could also look at the expression and
712 decide whether it requires a small bounded amount of heap, so we can ignore
713 it as a CAF. In these cases however, we would need to use an additional
714 CAF list to keep track of non-collectable CAFs.
717 hasCafRefs :: DynFlags -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
718 hasCafRefs dflags p arity expr
719 | is_caf || mentions_cafs = MayHaveCafRefs
720 | otherwise = NoCafRefs
722 mentions_cafs = isFastTrue (cafRefs p expr)
723 is_caf = not (arity > 0 || rhsIsStatic dflags expr)
724 -- NB. we pass in the arity of the expression, which is expected
725 -- to be calculated by exprArity. This is because exprArity
726 -- knows how much eta expansion is going to be done by
727 -- CorePrep later on, and we don't want to duplicate that
728 -- knowledge in rhsIsStatic below.
731 -- imported Ids first:
732 | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id))
733 -- now Ids local to this module:
735 case lookupVarEnv p id of
736 Just id' -> fastBool (mayHaveCafRefs (idCafInfo id'))
737 Nothing -> fastBool False
739 cafRefs p (Lit l) = fastBool False
740 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
741 cafRefs p (Lam x e) = cafRefs p e
742 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
743 cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
744 cafRefs p (Note n e) = cafRefs p e
745 cafRefs p (Type t) = fastBool False
747 cafRefss p [] = fastBool False
748 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
750 -- hack for lazy-or over FastBool.
751 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))