2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section{Tidying up Core}
7 module TidyPgm( mkBootModDetails, tidyProgram ) where
9 #include "HsVersions.h"
11 import DynFlags ( DynFlag(..), DynFlags(..), dopt )
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, isNaughtyRecordSelector,
24 idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo
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, mapNameEnv )
37 import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
38 import Type ( tidyTopType )
39 import TcType ( isFFITy )
40 import DataCon ( dataConName, dataConFieldLabels, dataConWrapId_maybe )
41 import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon,
42 newTyConRep, tyConSelIds, isAlgTyCon,
43 isEnumerationTyCon, isOpenTyCon )
44 import Class ( classSelIds )
45 import Module ( Module )
46 import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..),
47 TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons,
48 extendTypeEnvWithIds, lookupTypeEnv,
49 mkDetailsFamInstCache,
50 ModGuts(..), TyThing(..), ModDetails(..),
53 import Maybes ( orElse, mapCatMaybes )
54 import ErrUtils ( showPass, dumpIfSet_core )
55 import PackageConfig ( PackageId )
56 import UniqSupply ( splitUniqSupply, uniqFromSupply )
57 import List ( partition )
58 import Maybe ( isJust )
60 import DATA_IOREF ( IORef, readIORef, writeIORef )
61 import FastTypes hiding ( fastOr )
65 Constructing the TypeEnv, Instances, Rules from which the ModIface is
66 constructed, and which goes on to subsequent modules in --make mode.
68 Most of the interface file is obtained simply by serialising the
69 TypeEnv. One important consequence is that if the *interface file*
70 has pragma info if and only if the final TypeEnv does. This is not so
71 important for *this* module, but it's essential for ghc --make:
72 subsequent compilations must not see (e.g.) the arity if the interface
73 file does not contain arity If they do, they'll exploit the arity;
74 then the arity might change, but the iface file doesn't change =>
75 recompilation does not happen => disaster.
77 For data types, the final TypeEnv will have a TyThing for the TyCon,
78 plus one for each DataCon; the interface file will contain just one
79 data type declaration, but it is de-serialised back into a collection
82 %************************************************************************
86 %************************************************************************
89 Plan A: mkBootModDetails: omit pragmas, make interfaces small
90 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
93 * Drop all WiredIn things from the TypeEnv
94 (we never want them in interface files)
96 * Retain all TyCons and Classes in the TypeEnv, to avoid
97 having to find which ones are mentioned in the
100 * Trim off the constructors of non-exported TyCons, both
101 from the TyCon and from the TypeEnv
103 * Drop non-exported Ids from the TypeEnv
105 * Tidy the types of the DFunIds of Instances,
106 make them into GlobalIds, (they already have External Names)
107 and add them to the TypeEnv
109 * Tidy the types of the (exported) Ids in the TypeEnv,
110 make them into GlobalIds (they already have External Names)
112 * Drop rules altogether
114 * Tidy the bindings, to ensure that the Caf and Arity
115 information is correct for each top-level binder; the
116 code generator needs it. And to ensure that local names have
117 distinct OccNames in case of object-file splitting
120 mkBootModDetails :: HscEnv -> ModGuts -> IO ModDetails
121 -- This is Plan A: make a small type env when typechecking only,
122 -- or when compiling a hs-boot file, or simply when not using -O
124 -- We don't look at the bindings at all -- there aren't any
127 mkBootModDetails hsc_env (ModGuts { mg_module = mod,
128 mg_exports = exports,
131 = do { let dflags = hsc_dflags hsc_env
132 ; showPass dflags "Tidy [hoot] type env"
134 ; let { ispecs' = tidyInstances tidyExternalId ispecs
135 ; type_env1 = filterNameEnv (not . isWiredInThing) type_env
136 ; type_env2 = mapNameEnv tidyBootThing type_env1
137 ; type_env' = extendTypeEnvWithIds type_env2
138 (map instanceDFunId ispecs')
140 ; return (ModDetails { md_types = type_env',
142 md_fam_insts = mkDetailsFamInstCache type_env',
144 md_exports = exports })
148 isWiredInThing :: TyThing -> Bool
149 isWiredInThing thing = isWiredInName (getName thing)
151 tidyBootThing :: TyThing -> TyThing
152 -- Just externalise the Ids; keep everything
153 tidyBootThing (AnId id) | isLocalId id = AnId (tidyExternalId id)
154 tidyBootThing thing = thing
156 tidyExternalId :: Id -> Id
157 -- Takes an LocalId with an External Name,
158 -- makes it into a GlobalId with VanillaIdInfo, and tidies its type
159 -- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.)
161 = ASSERT2( isLocalId id && isExternalName (idName id), ppr id )
162 mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo
166 %************************************************************************
168 Plan B: tidy bindings, make TypeEnv full of IdInfo
170 %************************************************************************
172 Plan B: include pragmas, make interfaces
173 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
174 * Figure out which Ids are externally visible
176 * Tidy the bindings, externalising appropriate Ids
178 * Drop all Ids from the TypeEnv, and add all the External Ids from
179 the bindings. (This adds their IdInfo to the TypeEnv; and adds
180 floated-out Ids that weren't even in the TypeEnv before.)
182 Step 1: Figure out external Ids
183 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
184 First we figure out which Ids are "external" Ids. An
185 "external" Id is one that is visible from outside the compilation
187 a) the user exported ones
188 b) ones mentioned in the unfoldings, workers,
189 or rules of externally-visible ones
190 This exercise takes a sweep of the bindings bottom to top. Actually,
191 in Step 2 we're also going to need to know which Ids should be
192 exported with their unfoldings, so we produce not an IdSet but an
196 Step 2: Tidy the program
197 ~~~~~~~~~~~~~~~~~~~~~~~~
198 Next we traverse the bindings top to bottom. For each *top-level*
201 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal,
202 reflecting the fact that from now on we regard it as a global,
205 2. Give it a system-wide Unique.
206 [Even non-exported things need system-wide Uniques because the
207 byte-code generator builds a single Name->BCO symbol table.]
209 We use the NameCache kept in the HscEnv as the
210 source of such system-wide uniques.
212 For external Ids, use the original-name cache in the NameCache
213 to ensure that the unique assigned is the same as the Id had
214 in any previous compilation run.
216 3. If it's an external Id, make it have a External Name, otherwise
217 make it have an Internal Name.
218 This is used by the code generator to decide whether
219 to make the label externally visible
221 4. Give external Ids a "tidy" OccName. This means
222 we can print them in interface files without confusing
223 "x" (unique 5) with "x" (unique 10).
225 5. Give it its UTTERLY FINAL IdInfo; in ptic,
226 * its unfolding, if it should have one
228 * its arity, computed from the number of visible lambdas
230 * its CAF info, computed from what is free in its RHS
233 Finally, substitute these new top-level binders consistently
234 throughout, including in unfoldings. We also tidy binders in
235 RHSs, so that they print nicely in interfaces.
238 tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails)
240 mod_impl@(ModGuts { mg_module = mod, mg_exports = exports,
241 mg_types = type_env, mg_insts = insts_tc,
243 mg_rules = imp_rules,
244 mg_dir_imps = dir_imps, mg_deps = deps,
245 mg_foreign = foreign_stubs })
247 = do { let dflags = hsc_dflags hsc_env
248 ; showPass dflags "Tidy Core"
250 ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags
251 ; ext_ids = findExternalIds omit_prags binds
254 | otherwise = findExternalRules binds imp_rules ext_ids
255 -- findExternalRules filters imp_rules to avoid binders that
256 -- aren't externally visible; but the externally-visible binders
257 -- are computed (by findExternalIds) assuming that all orphan
258 -- rules are exported (they get their Exported flag set in the desugarer)
259 -- So in fact we may export more than we need.
260 -- (It's a sort of mutual recursion.)
263 ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env mod type_env ext_ids binds
265 ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds
266 ; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc
267 -- A DFunId will have a binding in tidy_binds, and so
268 -- will now be in final_env, replete with IdInfo
269 -- Its name will be unchanged since it was born, but
270 -- we want Global, IdInfo-rich (or not) DFunId in the tidy_ispecs
272 ; tidy_rules = tidyRules tidy_env ext_rules
273 -- You might worry that the tidy_env contains IdInfo-rich stuff
274 -- and indeed it does, but if omit_prags is on, ext_rules is empty
276 ; implicit_binds = getImplicitBinds type_env
277 ; all_tidy_binds = implicit_binds ++ tidy_binds
278 ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env)
281 ; endPass dflags "Tidy Core" Opt_D_dump_simpl all_tidy_binds
282 ; dumpIfSet_core dflags Opt_D_dump_simpl
284 (pprRules tidy_rules)
286 ; return (CgGuts { cg_module = mod,
287 cg_tycons = alg_tycons,
288 cg_binds = all_tidy_binds,
289 cg_dir_imps = dir_imps,
290 cg_foreign = foreign_stubs,
291 cg_dep_pkgs = dep_pkgs deps },
293 ModDetails { md_types = tidy_type_env,
294 md_rules = tidy_rules,
295 md_insts = tidy_ispecs,
296 md_fam_insts = mkDetailsFamInstCache
298 md_exports = exports })
301 lookup_dfun type_env dfun_id
302 = case lookupTypeEnv type_env (idName dfun_id) of
303 Just (AnId dfun_id') -> dfun_id'
304 other -> pprPanic "lookup_dfun" (ppr dfun_id)
306 tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv
308 -- The competed type environment is gotten from
309 -- Dropping any wired-in things, and then
310 -- a) keeping the types and classes
311 -- b) removing all Ids,
312 -- c) adding Ids with correct IdInfo, including unfoldings,
313 -- gotten from the bindings
314 -- From (c) we keep only those Ids with External names;
315 -- the CoreTidy pass makes sure these are all and only
316 -- the externally-accessible ones
317 -- This truncates the type environment to include only the
318 -- exported Ids and things needed from them, which saves space
320 tidyTypeEnv omit_prags exports type_env tidy_binds
321 = let type_env1 = filterNameEnv keep_it type_env
322 type_env2 = extendTypeEnvWithIds type_env1 final_ids
323 type_env3 | omit_prags = mapNameEnv trim_thing type_env2
324 | otherwise = type_env2
328 final_ids = [ id | id <- bindersOfBinds tidy_binds,
329 isExternalName (idName id)]
331 -- We keep GlobalIds, because they won't appear
332 -- in the bindings from which final_ids are derived!
333 -- (The bindings bind LocalIds.)
334 keep_it thing | isWiredInThing thing = False
335 keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops)
336 keep_it other = True -- Keep all TyCons, DataCons, and Classes
340 ATyCon tc | mustExposeTyCon exports tc -> thing
341 | otherwise -> ATyCon (makeTyConAbstract tc)
343 AnId id | isImplicitId id -> thing
344 | otherwise -> AnId (id `setIdInfo` vanillaIdInfo)
348 mustExposeTyCon :: NameSet -- Exports
349 -> TyCon -- The tycon
350 -> Bool -- Can its rep be hidden?
351 -- We are compiling without -O, and thus trying to write as little as
352 -- possible into the interface file. But we must expose the details of
353 -- any data types whose constructors or fields are exported
354 mustExposeTyCon exports tc
355 | not (isAlgTyCon tc) -- Synonyms
357 | isEnumerationTyCon tc -- For an enumeration, exposing the constructors
358 = True -- won't lead to the need for further exposure
359 -- (This includes data types with no constructors.)
360 | isOpenTyCon tc -- open type family
362 | otherwise -- Newtype, datatype
363 = any exported_con (tyConDataCons tc)
364 -- Expose rep if any datacon or field is exported
366 || (isNewTyCon tc && isFFITy (snd (newTyConRep tc)))
367 -- Expose the rep for newtypes if the rep is an FFI type.
368 -- For a very annoying reason. 'Foreign import' is meant to
369 -- be able to look through newtypes transparently, but it
370 -- can only do that if it can "see" the newtype representation
372 exported_con con = any (`elemNameSet` exports)
373 (dataConName con : dataConFieldLabels con)
375 tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance]
376 tidyInstances tidy_dfun ispecs
379 tidy ispec = setInstanceDFunId ispec $
380 tidy_dfun (instanceDFunId ispec)
382 getImplicitBinds :: TypeEnv -> [CoreBind]
383 getImplicitBinds type_env
384 = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env)
385 ++ concatMap other_implicit_ids (typeEnvElts type_env))
386 -- Put the constructor wrappers first, because
387 -- other implicit bindings (notably the fromT functions arising
388 -- from generics) use the constructor wrappers. At least that's
389 -- what External Core likes
391 implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc)
393 other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc)
394 -- The "naughty" ones are not real functions at all
395 -- They are there just so we can get decent error messages
396 -- See Note [Naughty record selectors] in MkId.lhs
397 other_implicit_ids (AClass cl) = classSelIds cl
398 other_implicit_ids other = []
400 get_defn :: Id -> CoreBind
401 get_defn id = NonRec id (tidyExpr emptyTidyEnv rhs)
403 rhs = unfoldingTemplate (idUnfolding id)
404 -- Don't forget to tidy the body ! Otherwise you get silly things like
405 -- \ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl
409 %************************************************************************
411 \subsection{Step 1: finding externals}
413 %************************************************************************
416 findExternalIds :: Bool
418 -> IdEnv Bool -- In domain => external
419 -- Range = True <=> show unfolding
420 -- Step 1 from the notes above
421 findExternalIds omit_prags binds
423 = mkVarEnv [ (id,False) | id <- bindersOfBinds binds, isExportedId id ]
426 = foldr find emptyVarEnv binds
428 find (NonRec id rhs) needed
429 | need_id needed id = addExternal (id,rhs) needed
431 find (Rec prs) needed = find_prs prs needed
433 -- For a recursive group we have to look for a fixed point
435 | null needed_prs = needed
436 | otherwise = find_prs other_prs new_needed
438 (needed_prs, other_prs) = partition (need_pr needed) prs
439 new_needed = foldr addExternal needed needed_prs
441 -- The 'needed' set contains the Ids that are needed by earlier
442 -- interface file emissions. If the Id isn't in this set, and isn't
443 -- exported, there's no need to emit anything
444 need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id
445 need_pr needed_set (id,rhs) = need_id needed_set id
447 addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool
448 -- The Id is needed; extend the needed set
449 -- with it and its dependents (free vars etc)
450 addExternal (id,rhs) needed
451 = extendVarEnv (foldVarSet add_occ needed new_needed_ids)
454 add_occ id needed = extendVarEnv needed id False
455 -- "False" because we don't know we need the Id's unfolding
456 -- We'll override it later when we find the binding site
458 new_needed_ids = worker_ids `unionVarSet`
459 unfold_ids `unionVarSet`
463 dont_inline = isNeverActive (inlinePragInfo idinfo)
464 loop_breaker = isLoopBreaker (occInfo idinfo)
465 bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
466 spec_ids = specInfoFreeVars (specInfo idinfo)
467 worker_info = workerInfo idinfo
469 -- Stuff to do with the Id's unfolding
470 -- The simplifier has put an up-to-date unfolding
471 -- in the IdInfo, but the RHS will do just as well
472 unfolding = unfoldingInfo idinfo
473 rhs_is_small = not (neverUnfold unfolding)
475 -- We leave the unfolding there even if there is a worker
476 -- In GHCI the unfolding is used by importers
477 -- When writing an interface file, we omit the unfolding
478 -- if there is a worker
479 show_unfold = not bottoming_fn && -- Not necessary
482 rhs_is_small -- Small enough
484 unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
485 | otherwise = emptyVarSet
487 worker_ids = case worker_info of
488 HasWorker work_id _ -> unitVarSet work_id
489 otherwise -> emptyVarSet
494 findExternalRules :: [CoreBind]
495 -> [CoreRule] -- Non-local rules (i.e. ones for imported fns)
496 -> IdEnv a -- Ids that are exported, so we need their rules
498 -- The complete rules are gotten by combining
499 -- a) the non-local rules
500 -- b) rules embedded in the top-level Ids
501 findExternalRules binds non_local_rules ext_ids
502 = filter (not . internal_rule) (non_local_rules ++ local_rules)
505 | id <- bindersOfBinds binds,
506 id `elemVarEnv` ext_ids,
507 rule <- idCoreRules id
511 = any internal_id (varSetElems (ruleLhsFreeIds rule))
512 -- Don't export a rule whose LHS mentions a locally-defined
513 -- Id that is completely internal (i.e. not visible to an
516 internal_id id = not (id `elemVarEnv` ext_ids)
521 %************************************************************************
523 \subsection{Step 2: top-level tidying}
525 %************************************************************************
529 -- TopTidyEnv: when tidying we need to know
530 -- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.
531 -- These may have arisen because the
532 -- renamer read in an interface file mentioning M.$wf, say,
533 -- and assigned it unique r77. If, on this compilation, we've
534 -- invented an Id whose name is $wf (but with a different unique)
535 -- we want to rename it to have unique r77, so that we can do easy
536 -- comparisons with stuff from the interface file
538 -- * occ_env: The TidyOccEnv, which tells us which local occurrences
541 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
543 tidyTopBinds :: HscEnv
546 -> IdEnv Bool -- Domain = Ids that should be external
547 -- True <=> their unfolding is external too
549 -> IO (TidyEnv, [CoreBind])
551 tidyTopBinds hsc_env mod type_env ext_ids binds
552 = tidy init_env binds
554 nc_var = hsc_NC hsc_env
556 -- We also make sure to avoid any exported binders. Consider
557 -- f{-u1-} = 1 -- Local decl
559 -- f{-u2-} = 2 -- Exported decl
561 -- The second exported decl must 'get' the name 'f', so we
562 -- have to put 'f' in the avoids list before we get to the first
563 -- decl. tidyTopId then does a no-op on exported binders.
564 init_env = (initTidyOccEnv avoids, emptyVarEnv)
565 avoids = [getOccName name | bndr <- typeEnvIds type_env,
566 let name = idName bndr,
568 -- In computing our "avoids" list, we must include
570 -- all things with global names (assigned once and for
571 -- all by the renamer)
572 -- since their names are "taken".
573 -- The type environment is a convenient source of such things.
575 this_pkg = thisPackage (hsc_dflags hsc_env)
577 tidy env [] = return (env, [])
578 tidy env (b:bs) = do { (env1, b') <- tidyTopBind this_pkg mod nc_var ext_ids env b
579 ; (env2, bs') <- tidy env1 bs
580 ; return (env2, b':bs') }
582 ------------------------
583 tidyTopBind :: PackageId
585 -> IORef NameCache -- For allocating new unique names
586 -> IdEnv Bool -- Domain = Ids that should be external
587 -- True <=> their unfolding is external too
588 -> TidyEnv -> CoreBind
589 -> IO (TidyEnv, CoreBind)
591 tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs)
592 = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr
593 ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs)
594 ; subst2 = extendVarEnv subst1 bndr bndr'
595 ; tidy_env2 = (occ_env2, subst2) }
596 ; return (tidy_env2, NonRec bndr' rhs') }
598 caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs
600 tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
601 = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs
602 ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info)
604 ; subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs')
605 ; tidy_env2 = (occ_env2, subst2) }
606 ; return (tidy_env2, Rec prs') }
610 -- the CafInfo for a recursive group says whether *any* rhs in
611 -- the group may refer indirectly to a CAF (because then, they all do).
613 | or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs)
614 | (bndr,rhs) <- prs ] = MayHaveCafRefs
615 | otherwise = NoCafRefs
617 --------------------------------------------------------------------
619 -- This is where we set names to local/global based on whether they really are
620 -- externally visible (see comment at the top of this module). If the name
621 -- was previously local, we have to give it a unique occurrence name if
622 -- we intend to externalise it.
623 tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, [])
624 tidyTopNames mod nc_var ext_ids occ_env (id:ids)
625 = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id
626 ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids
627 ; return (occ_env2, name:names) }
629 tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv
630 -> Id -> IO (TidyOccEnv, Name)
631 tidyTopName mod nc_var ext_ids occ_env id
632 | global && internal = return (occ_env, localiseName name)
634 | global && external = return (occ_env, name)
635 -- Global names are assumed to have been allocated by the renamer,
636 -- so they already have the "right" unique
637 -- And it's a system-wide unique too
639 -- Now we get to the real reason that all this is in the IO Monad:
640 -- we have to update the name cache in a nice atomic fashion
642 | local && internal = do { nc <- readIORef nc_var
643 ; let (nc', new_local_name) = mk_new_local nc
644 ; writeIORef nc_var nc'
645 ; return (occ_env', new_local_name) }
646 -- Even local, internal names must get a unique occurrence, because
647 -- if we do -split-objs we externalise the name later, in the code generator
649 -- Similarly, we must make sure it has a system-wide Unique, because
650 -- the byte-code generator builds a system-wide Name->BCO symbol table
652 | local && external = do { nc <- readIORef nc_var
653 ; let (nc', new_external_name) = mk_new_external nc
654 ; writeIORef nc_var nc'
655 ; return (occ_env', new_external_name) }
658 external = id `elemVarEnv` ext_ids
659 global = isExternalName name
661 internal = not external
662 mb_parent = nameParent_maybe name
663 loc = nameSrcLoc name
665 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
667 mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc)
669 (us1, us2) = splitUniqSupply (nsUniqs nc)
670 uniq = uniqFromSupply us1
672 mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc
673 -- If we want to externalise a currently-local name, check
674 -- whether we have already assigned a unique for it.
675 -- If so, use it; if not, extend the table.
676 -- All this is done by allcoateGlobalBinder.
677 -- This is needed when *re*-compiling a module in GHCi; we must
678 -- use the same name for externally-visible things as we did before.
681 -----------------------------------------------------------
682 tidyTopPair :: VarEnv Bool
683 -> TidyEnv -- The TidyEnv is used to tidy the IdInfo
684 -- It is knot-tied: don't look at it!
687 -> (Id, CoreExpr) -- Binder and RHS before tidying
689 -- This function is the heart of Step 2
690 -- The rec_tidy_env is the one to use for the IdInfo
691 -- It's necessary because when we are dealing with a recursive
692 -- group, a variable late in the group might be mentioned
693 -- in the IdInfo of one early in the group
695 tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs)
696 | isGlobalId bndr -- Injected binding for record selector, etc
697 = (bndr, tidyExpr rhs_tidy_env rhs)
701 bndr' = mkVanillaGlobal name' ty' idinfo'
702 ty' = tidyTopType (idType bndr)
703 rhs' = tidyExpr rhs_tidy_env rhs
704 idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external)
705 (idInfo bndr) unfold_info arity
708 -- Expose an unfolding if ext_ids tells us to
709 -- Remember that ext_ids maps an Id to a Bool:
710 -- True to show the unfolding, False to hide it
711 maybe_external = lookupVarEnv ext_ids bndr
712 show_unfold = maybe_external `orElse` False
713 unfold_info | show_unfold = mkTopUnfolding rhs'
714 | otherwise = noUnfolding
716 -- Usually the Id will have an accurate arity on it, because
717 -- the simplifier has just run, but not always.
718 -- One case I found was when the last thing the simplifier
719 -- did was to let-bind a non-atomic argument and then float
720 -- it to the top level. So it seems more robust just to
722 arity = exprArity rhs
725 -- tidyTopIdInfo creates the final IdInfo for top-level
726 -- binders. There are two delicate pieces:
728 -- * Arity. After CoreTidy, this arity must not change any more.
729 -- Indeed, CorePrep must eta expand where necessary to make
730 -- the manifest arity equal to the claimed arity.
732 -- * CAF info. This must also remain valid through to code generation.
733 -- We add the info here so that it propagates to all
734 -- occurrences of the binders in RHSs, and hence to occurrences in
735 -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
736 -- CoreToStg makes use of this when constructing SRTs.
738 tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info
739 | not is_external -- For internal Ids (not externally visible)
740 = vanillaIdInfo -- we only need enough info for code generation
741 -- Arity and strictness info are enough;
742 -- c.f. CoreTidy.tidyLetBndr
743 `setCafInfo` caf_info
745 `setAllStrictnessInfo` newStrictnessInfo idinfo
747 | otherwise -- Externally-visible Ids get the whole lot
749 `setCafInfo` caf_info
751 `setAllStrictnessInfo` newStrictnessInfo idinfo
752 `setInlinePragInfo` inlinePragInfo idinfo
753 `setUnfoldingInfo` unfold_info
754 `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo)
755 -- NB: we throw away the Rules
756 -- They have already been extracted by findExternalRules
760 ------------ Worker --------------
761 tidyWorker tidy_env (HasWorker work_id wrap_arity)
762 = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
763 tidyWorker tidy_env other
767 %************************************************************************
769 \subsection{Figuring out CafInfo for an expression}
771 %************************************************************************
773 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
774 We mark such things as `MayHaveCafRefs' because this information is
775 used to decide whether a particular closure needs to be referenced
778 There are two reasons for setting MayHaveCafRefs:
779 a) The RHS is a CAF: a top-level updatable thunk.
780 b) The RHS refers to something that MayHaveCafRefs
782 Possible improvement: In an effort to keep the number of CAFs (and
783 hence the size of the SRTs) down, we could also look at the expression and
784 decide whether it requires a small bounded amount of heap, so we can ignore
785 it as a CAF. In these cases however, we would need to use an additional
786 CAF list to keep track of non-collectable CAFs.
789 hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
790 hasCafRefs this_pkg p arity expr
791 | is_caf || mentions_cafs = MayHaveCafRefs
792 | otherwise = NoCafRefs
794 mentions_cafs = isFastTrue (cafRefs p expr)
795 is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
796 -- NB. we pass in the arity of the expression, which is expected
797 -- to be calculated by exprArity. This is because exprArity
798 -- knows how much eta expansion is going to be done by
799 -- CorePrep later on, and we don't want to duplicate that
800 -- knowledge in rhsIsStatic below.
803 -- imported Ids first:
804 | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id))
805 -- now Ids local to this module:
807 case lookupVarEnv p id of
808 Just id' -> fastBool (mayHaveCafRefs (idCafInfo id'))
809 Nothing -> fastBool False
811 cafRefs p (Lit l) = fastBool False
812 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
813 cafRefs p (Lam x e) = cafRefs p e
814 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
815 cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
816 cafRefs p (Note n e) = cafRefs p e
817 cafRefs p (Cast e co) = cafRefs p e
818 cafRefs p (Type t) = fastBool False
820 cafRefss p [] = fastBool False
821 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
823 -- hack for lazy-or over FastBool.
824 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))