2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{Tidying up Core}
7 module TidyPgm( mkBootModDetailsDs, mkBootModDetailsTc, tidyProgram ) where
9 #include "HsVersions.h"
23 import Var hiding( mkGlobalId )
43 import FastBool hiding ( fastOr )
45 import Data.List ( partition )
46 import Data.Maybe ( isJust )
47 import Data.IORef ( IORef, readIORef, writeIORef )
49 _dummy :: FS.FastString
54 Constructing the TypeEnv, Instances, Rules from which the ModIface is
55 constructed, and which goes on to subsequent modules in --make mode.
57 Most of the interface file is obtained simply by serialising the
58 TypeEnv. One important consequence is that if the *interface file*
59 has pragma info if and only if the final TypeEnv does. This is not so
60 important for *this* module, but it's essential for ghc --make:
61 subsequent compilations must not see (e.g.) the arity if the interface
62 file does not contain arity If they do, they'll exploit the arity;
63 then the arity might change, but the iface file doesn't change =>
64 recompilation does not happen => disaster.
66 For data types, the final TypeEnv will have a TyThing for the TyCon,
67 plus one for each DataCon; the interface file will contain just one
68 data type declaration, but it is de-serialised back into a collection
71 %************************************************************************
75 %************************************************************************
78 Plan A: mkBootModDetails: omit pragmas, make interfaces small
79 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
82 * Drop all WiredIn things from the TypeEnv
83 (we never want them in interface files)
85 * Retain all TyCons and Classes in the TypeEnv, to avoid
86 having to find which ones are mentioned in the
89 * Trim off the constructors of non-exported TyCons, both
90 from the TyCon and from the TypeEnv
92 * Drop non-exported Ids from the TypeEnv
94 * Tidy the types of the DFunIds of Instances,
95 make them into GlobalIds, (they already have External Names)
96 and add them to the TypeEnv
98 * Tidy the types of the (exported) Ids in the TypeEnv,
99 make them into GlobalIds (they already have External Names)
101 * Drop rules altogether
103 * Tidy the bindings, to ensure that the Caf and Arity
104 information is correct for each top-level binder; the
105 code generator needs it. And to ensure that local names have
106 distinct OccNames in case of object-file splitting
109 -- This is Plan A: make a small type env when typechecking only,
110 -- or when compiling a hs-boot file, or simply when not using -O
112 -- We don't look at the bindings at all -- there aren't any
115 mkBootModDetailsTc :: HscEnv -> TcGblEnv -> IO ModDetails
116 mkBootModDetailsTc hsc_env
117 TcGblEnv{ tcg_exports = exports,
118 tcg_type_env = type_env,
120 tcg_fam_insts = fam_insts
122 = mkBootModDetails hsc_env exports type_env insts fam_insts
124 mkBootModDetailsDs :: HscEnv -> ModGuts -> IO ModDetails
125 mkBootModDetailsDs hsc_env
126 ModGuts{ mg_exports = exports,
129 mg_fam_insts = fam_insts
131 = mkBootModDetails hsc_env exports type_env insts fam_insts
133 mkBootModDetails :: HscEnv -> [AvailInfo] -> NameEnv TyThing
134 -> [Instance] -> [FamInstEnv.FamInst] -> IO ModDetails
135 mkBootModDetails hsc_env exports type_env insts fam_insts
136 = do { let dflags = hsc_dflags hsc_env
137 ; showPass dflags "Tidy [hoot] type env"
139 ; let { insts' = tidyInstances tidyExternalId insts
140 ; dfun_ids = map instanceDFunId insts'
141 ; type_env1 = tidyBootTypeEnv (availsToNameSet exports) type_env
142 ; type_env' = extendTypeEnvWithIds type_env1 dfun_ids
144 ; return (ModDetails { md_types = type_env'
146 , md_fam_insts = fam_insts
148 , md_exports = exports
149 , md_vect_info = noVectInfo
154 tidyBootTypeEnv :: NameSet -> TypeEnv -> TypeEnv
155 tidyBootTypeEnv exports type_env
156 = tidyTypeEnv True exports type_env final_ids
158 -- Find the LocalIds in the type env that are exported
159 -- Make them into GlobalIds, and tidy their types
161 -- It's very important to remove the non-exported ones
162 -- because we don't tidy the OccNames, and if we don't remove
163 -- the non-exported ones we'll get many things with the
164 -- same name in the interface file, giving chaos.
165 final_ids = [ tidyExternalId id
166 | id <- typeEnvIds type_env
170 -- default methods have their export flag set, but everything
171 -- else doesn't (yet), because this is pre-desugaring, so we
173 keep_it id = isExportedId id || idName id `elemNameSet` exports
176 tidyExternalId :: Id -> Id
177 -- Takes an LocalId with an External Name,
178 -- makes it into a GlobalId with VanillaIdInfo, and tidies its type
179 -- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.)
181 = ASSERT2( isLocalId id && isExternalName (idName id), ppr id )
182 mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo
186 %************************************************************************
188 Plan B: tidy bindings, make TypeEnv full of IdInfo
190 %************************************************************************
192 Plan B: include pragmas, make interfaces
193 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
194 * Figure out which Ids are externally visible
196 * Tidy the bindings, externalising appropriate Ids
198 * Drop all Ids from the TypeEnv, and add all the External Ids from
199 the bindings. (This adds their IdInfo to the TypeEnv; and adds
200 floated-out Ids that weren't even in the TypeEnv before.)
202 Step 1: Figure out external Ids
203 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
204 First we figure out which Ids are "external" Ids. An
205 "external" Id is one that is visible from outside the compilation
207 a) the user exported ones
208 b) ones mentioned in the unfoldings, workers,
209 or rules of externally-visible ones
210 This exercise takes a sweep of the bindings bottom to top. Actually,
211 in Step 2 we're also going to need to know which Ids should be
212 exported with their unfoldings, so we produce not an IdSet but an
216 Step 2: Tidy the program
217 ~~~~~~~~~~~~~~~~~~~~~~~~
218 Next we traverse the bindings top to bottom. For each *top-level*
221 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,
222 reflecting the fact that from now on we regard it as a global,
225 2. Give it a system-wide Unique.
226 [Even non-exported things need system-wide Uniques because the
227 byte-code generator builds a single Name->BCO symbol table.]
229 We use the NameCache kept in the HscEnv as the
230 source of such system-wide uniques.
232 For external Ids, use the original-name cache in the NameCache
233 to ensure that the unique assigned is the same as the Id had
234 in any previous compilation run.
236 3. If it's an external Id, make it have a External Name, otherwise
237 make it have an Internal Name.
238 This is used by the code generator to decide whether
239 to make the label externally visible
241 4. Give external Ids a "tidy" OccName. This means
242 we can print them in interface files without confusing
243 "x" (unique 5) with "x" (unique 10).
245 5. Give it its UTTERLY FINAL IdInfo; in ptic,
246 * its unfolding, if it should have one
248 * its arity, computed from the number of visible lambdas
250 * its CAF info, computed from what is free in its RHS
253 Finally, substitute these new top-level binders consistently
254 throughout, including in unfoldings. We also tidy binders in
255 RHSs, so that they print nicely in interfaces.
258 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
260 (ModGuts { mg_module = mod, mg_exports = exports,
262 mg_insts = insts, mg_fam_insts = fam_insts,
264 mg_rules = imp_rules,
265 mg_vect_info = vect_info,
266 mg_dir_imps = dir_imps,
268 mg_foreign = foreign_stubs,
269 mg_hpc_info = hpc_info,
270 mg_modBreaks = modBreaks })
272 = do { let dflags = hsc_dflags hsc_env
273 ; showPass dflags "Tidy Core"
275 ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags
276 ; ext_ids = findExternalIds omit_prags binds
279 | otherwise = findExternalRules binds imp_rules ext_ids
280 -- findExternalRules filters imp_rules to avoid binders that
281 -- aren't externally visible; but the externally-visible binders
282 -- are computed (by findExternalIds) assuming that all orphan
283 -- rules are exported (they get their Exported flag set in the desugarer)
284 -- So in fact we may export more than we need.
285 -- (It's a sort of mutual recursion.)
288 ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids
291 ; let { export_set = availsToNameSet exports
292 ; final_ids = [ id | id <- bindersOfBinds tidy_binds,
293 isExternalName (idName id)]
294 ; tidy_type_env = tidyTypeEnv omit_prags export_set type_env
296 ; tidy_insts = tidyInstances (lookup_dfun tidy_type_env) insts
297 -- A DFunId will have a binding in tidy_binds, and so
298 -- will now be in final_env, replete with IdInfo
299 -- Its name will be unchanged since it was born, but
300 -- we want Global, IdInfo-rich (or not) DFunId in the
303 ; tidy_rules = tidyRules tidy_env ext_rules
304 -- You might worry that the tidy_env contains IdInfo-rich stuff
305 -- and indeed it does, but if omit_prags is on, ext_rules is
308 ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
311 ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
312 ; dumpIfSet_core dflags Opt_D_dump_simpl
314 (pprRules tidy_rules)
316 ; let dir_imp_mods = map fst (moduleEnvElts dir_imps)
318 ; return (CgGuts { cg_module = mod,
319 cg_tycons = alg_tycons,
320 cg_binds = tidy_binds,
321 cg_dir_imps = dir_imp_mods,
322 cg_foreign = foreign_stubs,
323 cg_dep_pkgs = dep_pkgs deps,
324 cg_hpc_info = hpc_info,
325 cg_modBreaks = modBreaks },
327 ModDetails { md_types = tidy_type_env,
328 md_rules = tidy_rules,
329 md_insts = tidy_insts,
330 md_fam_insts = fam_insts,
331 md_exports = exports,
332 md_vect_info = vect_info -- is already tidy
336 lookup_dfun :: TypeEnv -> Var -> Id
337 lookup_dfun type_env dfun_id
338 = case lookupTypeEnv type_env (idName dfun_id) of
339 Just (AnId dfun_id') -> dfun_id'
340 _other -> pprPanic "lookup_dfun" (ppr dfun_id)
342 --------------------------
343 tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [Id] -> TypeEnv
345 -- The competed type environment is gotten from
346 -- Dropping any wired-in things, and then
347 -- a) keeping the types and classes
348 -- b) removing all Ids,
349 -- c) adding Ids with correct IdInfo, including unfoldings,
350 -- gotten from the bindings
351 -- From (c) we keep only those Ids with External names;
352 -- the CoreTidy pass makes sure these are all and only
353 -- the externally-accessible ones
354 -- This truncates the type environment to include only the
355 -- exported Ids and things needed from them, which saves space
357 tidyTypeEnv omit_prags exports type_env final_ids
358 = let type_env1 = filterNameEnv keep_it type_env
359 type_env2 = extendTypeEnvWithIds type_env1 final_ids
360 type_env3 | omit_prags = mapNameEnv (trimThing exports) type_env2
361 | otherwise = type_env2
365 -- We keep GlobalIds, because they won't appear
366 -- in the bindings from which final_ids are derived!
367 -- (The bindings bind LocalIds.)
368 keep_it thing | isWiredInThing thing = False
369 keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops)
370 keep_it _other = True -- Keep all TyCons, DataCons, and Classes
372 --------------------------
373 isWiredInThing :: TyThing -> Bool
374 isWiredInThing thing = isWiredInName (getName thing)
376 --------------------------
377 trimThing :: NameSet -> TyThing -> TyThing
378 -- Trim off inessentials, for boot files and no -O
379 trimThing exports (ATyCon tc)
380 | not (mustExposeTyCon exports tc)
381 = ATyCon (makeTyConAbstract tc)
383 trimThing _exports (AnId id)
384 | not (isImplicitId id)
385 = AnId (id `setIdInfo` vanillaIdInfo)
387 trimThing _exports other_thing
391 mustExposeTyCon :: NameSet -- Exports
392 -> TyCon -- The tycon
393 -> Bool -- Can its rep be hidden?
394 -- We are compiling without -O, and thus trying to write as little as
395 -- possible into the interface file. But we must expose the details of
396 -- any data types whose constructors or fields are exported
397 mustExposeTyCon exports tc
398 | not (isAlgTyCon tc) -- Synonyms
400 | isEnumerationTyCon tc -- For an enumeration, exposing the constructors
401 = True -- won't lead to the need for further exposure
402 -- (This includes data types with no constructors.)
403 | isOpenTyCon tc -- Open type family
406 | otherwise -- Newtype, datatype
407 = any exported_con (tyConDataCons tc)
408 -- Expose rep if any datacon or field is exported
410 || (isNewTyCon tc && isFFITy (snd (newTyConRhs tc)))
411 -- Expose the rep for newtypes if the rep is an FFI type.
412 -- For a very annoying reason. 'Foreign import' is meant to
413 -- be able to look through newtypes transparently, but it
414 -- can only do that if it can "see" the newtype representation
416 exported_con con = any (`elemNameSet` exports)
417 (dataConName con : dataConFieldLabels con)
419 tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance]
420 tidyInstances tidy_dfun ispecs
423 tidy ispec = setInstanceDFunId ispec $
424 tidy_dfun (instanceDFunId ispec)
428 %************************************************************************
430 \subsection{Step 1: finding externals}
432 %************************************************************************
435 findExternalIds :: Bool
437 -> IdEnv Bool -- In domain => external
438 -- Range = True <=> show unfolding
439 -- Step 1 from the notes above
440 findExternalIds omit_prags binds
442 = mkVarEnv [ (id,False) | id <- bindersOfBinds binds, isExportedId id ]
445 = foldr find emptyVarEnv binds
447 find (NonRec id rhs) needed
448 | need_id needed id = addExternal (id,rhs) needed
450 find (Rec prs) needed = find_prs prs needed
452 -- For a recursive group we have to look for a fixed point
454 | null needed_prs = needed
455 | otherwise = find_prs other_prs new_needed
457 (needed_prs, other_prs) = partition (need_pr needed) prs
458 new_needed = foldr addExternal needed needed_prs
460 -- The 'needed' set contains the Ids that are needed by earlier
461 -- interface file emissions. If the Id isn't in this set, and isn't
462 -- exported, there's no need to emit anything
463 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
464 need_pr needed_set (id,_) = need_id needed_set id
466 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
467 -- The Id is needed; extend the needed set
468 -- with it and its dependents (free vars etc)
469 addExternal (id,rhs) needed
470 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
473 add_occ id needed | id `elemVarEnv` needed = needed
474 | otherwise = extendVarEnv needed id False
475 -- "False" because we don't know we need the Id's unfolding
476 -- Don't override existing bindings; we might have already set it to True
478 new_needed_ids = worker_ids `unionVarSet`
479 unfold_ids `unionVarSet`
483 dont_inline = isNeverActive (inlinePragInfo idinfo)
484 loop_breaker = isNonRuleLoopBreaker (occInfo idinfo)
485 bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
486 spec_ids = specInfoFreeVars (specInfo idinfo)
487 worker_info = workerInfo idinfo
489 -- Stuff to do with the Id's unfolding
490 -- The simplifier has put an up-to-date unfolding
491 -- in the IdInfo, but the RHS will do just as well
492 unfolding = unfoldingInfo idinfo
493 rhs_is_small = not (neverUnfold unfolding)
495 -- We leave the unfolding there even if there is a worker
496 -- In GHCI the unfolding is used by importers
497 -- When writing an interface file, we omit the unfolding
498 -- if there is a worker
499 show_unfold = not bottoming_fn && -- Not necessary
502 rhs_is_small -- Small enough
504 unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
505 | otherwise = emptyVarSet
507 worker_ids = case worker_info of
508 HasWorker work_id _ -> unitVarSet work_id
509 _otherwise -> emptyVarSet
514 findExternalRules :: [CoreBind]
515 -> [CoreRule] -- Non-local rules (i.e. ones for imported fns)
516 -> IdEnv a -- Ids that are exported, so we need their rules
518 -- The complete rules are gotten by combining
519 -- a) the non-local rules
520 -- b) rules embedded in the top-level Ids
521 findExternalRules binds non_local_rules ext_ids
522 = filter (not . internal_rule) (non_local_rules ++ local_rules)
525 | id <- bindersOfBinds binds,
526 id `elemVarEnv` ext_ids,
527 rule <- idCoreRules id
531 = any internal_id (varSetElems (ruleLhsFreeIds rule))
532 -- Don't export a rule whose LHS mentions a locally-defined
533 -- Id that is completely internal (i.e. not visible to an
536 internal_id id = not (id `elemVarEnv` ext_ids)
541 %************************************************************************
543 \subsection{Step 2: top-level tidying}
545 %************************************************************************
549 -- TopTidyEnv: when tidying we need to know
550 -- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.
551 -- These may have arisen because the
552 -- renamer read in an interface file mentioning M.$wf, say,
553 -- and assigned it unique r77. If, on this compilation, we've
554 -- invented an Id whose name is $wf (but with a different unique)
555 -- we want to rename it to have unique r77, so that we can do easy
556 -- comparisons with stuff from the interface file
558 -- * occ_env: The TidyOccEnv, which tells us which local occurrences
561 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
563 tidyTopBinds :: HscEnv
566 -> IdEnv Bool -- Domain = Ids that should be external
567 -- True <=> their unfolding is external too
569 -> IO (TidyEnv, [CoreBind])
571 tidyTopBinds hsc_env mod type_env ext_ids binds
572 = tidy init_env binds
574 nc_var = hsc_NC hsc_env
576 -- We also make sure to avoid any exported binders. Consider
577 -- f{-u1-} = 1 -- Local decl
579 -- f{-u2-} = 2 -- Exported decl
581 -- The second exported decl must 'get' the name 'f', so we
582 -- have to put 'f' in the avoids list before we get to the first
583 -- decl. tidyTopId then does a no-op on exported binders.
584 init_env = (initTidyOccEnv avoids, emptyVarEnv)
585 avoids = [getOccName name | bndr <- typeEnvIds type_env,
586 let name = idName bndr,
588 -- In computing our "avoids" list, we must include
590 -- all things with global names (assigned once and for
591 -- all by the renamer)
592 -- since their names are "taken".
593 -- The type environment is a convenient source of such things.
595 this_pkg = thisPackage (hsc_dflags hsc_env)
597 tidy env [] = return (env, [])
598 tidy env (b:bs) = do { (env1, b') <- tidyTopBind this_pkg mod nc_var ext_ids env b
599 ; (env2, bs') <- tidy env1 bs
600 ; return (env2, b':bs') }
602 ------------------------
603 tidyTopBind :: PackageId
605 -> IORef NameCache -- For allocating new unique names
606 -> IdEnv Bool -- Domain = Ids that should be external
607 -- True <=> their unfolding is external too
608 -> TidyEnv -> CoreBind
609 -> IO (TidyEnv, CoreBind)
611 tidyTopBind this_pkg mod nc_var ext_ids (occ_env1,subst1) (NonRec bndr rhs)
612 = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr
613 ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs)
614 ; subst2 = extendVarEnv subst1 bndr bndr'
615 ; tidy_env2 = (occ_env2, subst2) }
616 ; return (tidy_env2, NonRec bndr' rhs') }
618 caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs
620 tidyTopBind this_pkg mod nc_var ext_ids (occ_env1,subst1) (Rec prs)
621 = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs
622 ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info)
624 ; subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs')
625 ; tidy_env2 = (occ_env2, subst2) }
626 ; return (tidy_env2, Rec prs') }
630 -- the CafInfo for a recursive group says whether *any* rhs in
631 -- the group may refer indirectly to a CAF (because then, they all do).
633 | or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs)
634 | (bndr,rhs) <- prs ] = MayHaveCafRefs
635 | otherwise = NoCafRefs
637 --------------------------------------------------------------------
639 -- This is where we set names to local/global based on whether they really are
640 -- externally visible (see comment at the top of this module). If the name
641 -- was previously local, we have to give it a unique occurrence name if
642 -- we intend to externalise it.
643 tidyTopNames :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv
644 -> [Id] -> IO (TidyOccEnv, [Name])
645 tidyTopNames _mod _nc_var _ext_ids occ_env [] = return (occ_env, [])
646 tidyTopNames mod nc_var ext_ids occ_env (id:ids)
647 = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id
648 ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids
649 ; return (occ_env2, name:names) }
651 tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv
652 -> Id -> IO (TidyOccEnv, Name)
653 tidyTopName mod nc_var ext_ids occ_env id
654 | global && internal = return (occ_env, localiseName name)
656 | global && external = return (occ_env, name)
657 -- Global names are assumed to have been allocated by the renamer,
658 -- so they already have the "right" unique
659 -- And it's a system-wide unique too
661 -- Now we get to the real reason that all this is in the IO Monad:
662 -- we have to update the name cache in a nice atomic fashion
664 | local && internal = do { nc <- readIORef nc_var
665 ; let (nc', new_local_name) = mk_new_local nc
666 ; writeIORef nc_var nc'
667 ; return (occ_env', new_local_name) }
668 -- Even local, internal names must get a unique occurrence, because
669 -- if we do -split-objs we externalise the name later, in the code generator
671 -- Similarly, we must make sure it has a system-wide Unique, because
672 -- the byte-code generator builds a system-wide Name->BCO symbol table
674 | local && external = do { nc <- readIORef nc_var
675 ; let (nc', new_external_name) = mk_new_external nc
676 ; writeIORef nc_var nc'
677 ; return (occ_env', new_external_name) }
679 | otherwise = panic "tidyTopName"
682 external = id `elemVarEnv` ext_ids
683 global = isExternalName name
685 internal = not external
686 loc = nameSrcSpan name
688 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
690 mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc)
692 (us1, us2) = splitUniqSupply (nsUniqs nc)
693 uniq = uniqFromSupply us1
695 mk_new_external nc = allocateGlobalBinder nc mod occ' loc
696 -- If we want to externalise a currently-local name, check
697 -- whether we have already assigned a unique for it.
698 -- If so, use it; if not, extend the table.
699 -- All this is done by allcoateGlobalBinder.
700 -- This is needed when *re*-compiling a module in GHCi; we must
701 -- use the same name for externally-visible things as we did before.
704 -----------------------------------------------------------
705 tidyTopPair :: VarEnv Bool
706 -> TidyEnv -- The TidyEnv is used to tidy the IdInfo
707 -- It is knot-tied: don't look at it!
710 -> (Id, CoreExpr) -- Binder and RHS before tidying
712 -- This function is the heart of Step 2
713 -- The rec_tidy_env is the one to use for the IdInfo
714 -- It's necessary because when we are dealing with a recursive
715 -- group, a variable late in the group might be mentioned
716 -- in the IdInfo of one early in the group
718 tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs)
721 bndr' = mkGlobalId details name' ty' idinfo'
722 -- Preserve the GlobalIdDetails of existing global-ids
723 details = case globalIdDetails bndr of
724 NotGlobalId -> VanillaGlobal
725 old_details -> old_details
726 ty' = tidyTopType (idType bndr)
727 rhs' = tidyExpr rhs_tidy_env rhs
729 idinfo' = tidyTopIdInfo (isJust maybe_external)
730 idinfo unfold_info worker_info
733 -- Expose an unfolding if ext_ids tells us to
734 -- Remember that ext_ids maps an Id to a Bool:
735 -- True to show the unfolding, False to hide it
736 maybe_external = lookupVarEnv ext_ids bndr
737 show_unfold = maybe_external `orElse` False
738 unfold_info | show_unfold = mkTopUnfolding rhs'
739 | otherwise = noUnfolding
740 worker_info = tidyWorker rhs_tidy_env show_unfold (workerInfo idinfo)
742 -- Usually the Id will have an accurate arity on it, because
743 -- the simplifier has just run, but not always.
744 -- One case I found was when the last thing the simplifier
745 -- did was to let-bind a non-atomic argument and then float
746 -- it to the top level. So it seems more robust just to
748 arity = exprArity rhs
751 -- tidyTopIdInfo creates the final IdInfo for top-level
752 -- binders. There are two delicate pieces:
754 -- * Arity. After CoreTidy, this arity must not change any more.
755 -- Indeed, CorePrep must eta expand where necessary to make
756 -- the manifest arity equal to the claimed arity.
758 -- * CAF info. This must also remain valid through to code generation.
759 -- We add the info here so that it propagates to all
760 -- occurrences of the binders in RHSs, and hence to occurrences in
761 -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
762 -- CoreToStg makes use of this when constructing SRTs.
763 tidyTopIdInfo :: Bool -> IdInfo -> Unfolding
764 -> WorkerInfo -> ArityInfo -> CafInfo
766 tidyTopIdInfo is_external idinfo unfold_info worker_info arity caf_info
767 | not is_external -- For internal Ids (not externally visible)
768 = vanillaIdInfo -- we only need enough info for code generation
769 -- Arity and strictness info are enough;
770 -- c.f. CoreTidy.tidyLetBndr
771 `setCafInfo` caf_info
773 `setAllStrictnessInfo` newStrictnessInfo idinfo
775 | otherwise -- Externally-visible Ids get the whole lot
777 `setCafInfo` caf_info
779 `setAllStrictnessInfo` newStrictnessInfo idinfo
780 `setInlinePragInfo` inlinePragInfo idinfo
781 `setUnfoldingInfo` unfold_info
782 `setWorkerInfo` worker_info
783 -- NB: we throw away the Rules
784 -- They have already been extracted by findExternalRules
788 ------------ Worker --------------
789 tidyWorker :: TidyEnv -> Bool -> WorkerInfo -> WorkerInfo
790 tidyWorker _tidy_env _show_unfold NoWorker
792 tidyWorker tidy_env show_unfold (HasWorker work_id wrap_arity)
793 | show_unfold = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
794 | otherwise = NoWorker
795 -- NB: do *not* expose the worker if show_unfold is off,
796 -- because that means this thing is a loop breaker or
797 -- marked NOINLINE or something like that
798 -- This is important: if you expose the worker for a loop-breaker
799 -- then you can make the simplifier go into an infinite loop, because
800 -- in effect the unfolding is exposed. See Trac #1709
802 -- You might think that if show_unfold is False, then the thing should
803 -- not be w/w'd in the first place. But a legitimate reason is this:
804 -- the function returns bottom
805 -- In this case, show_unfold will be false (we don't expose unfoldings
806 -- for bottoming functions), but we might still have a worker/wrapper
807 -- split (see Note [Worker-wrapper for bottoming functions] in WorkWrap.lhs
810 %************************************************************************
812 \subsection{Figuring out CafInfo for an expression}
814 %************************************************************************
816 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
817 We mark such things as `MayHaveCafRefs' because this information is
818 used to decide whether a particular closure needs to be referenced
821 There are two reasons for setting MayHaveCafRefs:
822 a) The RHS is a CAF: a top-level updatable thunk.
823 b) The RHS refers to something that MayHaveCafRefs
825 Possible improvement: In an effort to keep the number of CAFs (and
826 hence the size of the SRTs) down, we could also look at the expression and
827 decide whether it requires a small bounded amount of heap, so we can ignore
828 it as a CAF. In these cases however, we would need to use an additional
829 CAF list to keep track of non-collectable CAFs.
832 hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
833 hasCafRefs this_pkg p arity expr
834 | is_caf || mentions_cafs
836 | otherwise = NoCafRefs
838 mentions_cafs = isFastTrue (cafRefs p expr)
839 is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
841 -- NB. we pass in the arity of the expression, which is expected
842 -- to be calculated by exprArity. This is because exprArity
843 -- knows how much eta expansion is going to be done by
844 -- CorePrep later on, and we don't want to duplicate that
845 -- knowledge in rhsIsStatic below.
847 cafRefs :: VarEnv Id -> Expr a -> FastBool
849 -- imported Ids first:
850 | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id))
851 -- now Ids local to this module:
853 case lookupVarEnv p id of
854 Just id' -> fastBool (mayHaveCafRefs (idCafInfo id'))
855 Nothing -> fastBool False
857 cafRefs _ (Lit _) = fastBool False
858 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
859 cafRefs p (Lam _ e) = cafRefs p e
860 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
861 cafRefs p (Case e _bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
862 cafRefs p (Note _n e) = cafRefs p e
863 cafRefs p (Cast e _co) = cafRefs p e
864 cafRefs _ (Type _) = fastBool False
866 cafRefss :: VarEnv Id -> [Expr a] -> FastBool
867 cafRefss _ [] = fastBool False
868 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
870 fastOr :: FastBool -> (a -> FastBool) -> a -> FastBool
871 -- hack for lazy-or over FastBool.
872 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))