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, isNonRuleLoopBreaker )
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 | id `elemVarEnv` needed = needed
455 | otherwise = extendVarEnv needed id False
456 -- "False" because we don't know we need the Id's unfolding
457 -- Don't override existing bindings; we might have already set it to True
459 new_needed_ids = worker_ids `unionVarSet`
460 unfold_ids `unionVarSet`
464 dont_inline = isNeverActive (inlinePragInfo idinfo)
465 loop_breaker = isNonRuleLoopBreaker (occInfo idinfo)
466 bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig)
467 spec_ids = specInfoFreeVars (specInfo idinfo)
468 worker_info = workerInfo idinfo
470 -- Stuff to do with the Id's unfolding
471 -- The simplifier has put an up-to-date unfolding
472 -- in the IdInfo, but the RHS will do just as well
473 unfolding = unfoldingInfo idinfo
474 rhs_is_small = not (neverUnfold unfolding)
476 -- We leave the unfolding there even if there is a worker
477 -- In GHCI the unfolding is used by importers
478 -- When writing an interface file, we omit the unfolding
479 -- if there is a worker
480 show_unfold = not bottoming_fn && -- Not necessary
483 rhs_is_small -- Small enough
485 unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs
486 | otherwise = emptyVarSet
488 worker_ids = case worker_info of
489 HasWorker work_id _ -> unitVarSet work_id
490 otherwise -> emptyVarSet
495 findExternalRules :: [CoreBind]
496 -> [CoreRule] -- Non-local rules (i.e. ones for imported fns)
497 -> IdEnv a -- Ids that are exported, so we need their rules
499 -- The complete rules are gotten by combining
500 -- a) the non-local rules
501 -- b) rules embedded in the top-level Ids
502 findExternalRules binds non_local_rules ext_ids
503 = filter (not . internal_rule) (non_local_rules ++ local_rules)
506 | id <- bindersOfBinds binds,
507 id `elemVarEnv` ext_ids,
508 rule <- idCoreRules id
512 = any internal_id (varSetElems (ruleLhsFreeIds rule))
513 -- Don't export a rule whose LHS mentions a locally-defined
514 -- Id that is completely internal (i.e. not visible to an
517 internal_id id = not (id `elemVarEnv` ext_ids)
522 %************************************************************************
524 \subsection{Step 2: top-level tidying}
526 %************************************************************************
530 -- TopTidyEnv: when tidying we need to know
531 -- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names.
532 -- These may have arisen because the
533 -- renamer read in an interface file mentioning M.$wf, say,
534 -- and assigned it unique r77. If, on this compilation, we've
535 -- invented an Id whose name is $wf (but with a different unique)
536 -- we want to rename it to have unique r77, so that we can do easy
537 -- comparisons with stuff from the interface file
539 -- * occ_env: The TidyOccEnv, which tells us which local occurrences
542 -- * subst_env: A Var->Var mapping that substitutes the new Var for the old
544 tidyTopBinds :: HscEnv
547 -> IdEnv Bool -- Domain = Ids that should be external
548 -- True <=> their unfolding is external too
550 -> IO (TidyEnv, [CoreBind])
552 tidyTopBinds hsc_env mod type_env ext_ids binds
553 = tidy init_env binds
555 nc_var = hsc_NC hsc_env
557 -- We also make sure to avoid any exported binders. Consider
558 -- f{-u1-} = 1 -- Local decl
560 -- f{-u2-} = 2 -- Exported decl
562 -- The second exported decl must 'get' the name 'f', so we
563 -- have to put 'f' in the avoids list before we get to the first
564 -- decl. tidyTopId then does a no-op on exported binders.
565 init_env = (initTidyOccEnv avoids, emptyVarEnv)
566 avoids = [getOccName name | bndr <- typeEnvIds type_env,
567 let name = idName bndr,
569 -- In computing our "avoids" list, we must include
571 -- all things with global names (assigned once and for
572 -- all by the renamer)
573 -- since their names are "taken".
574 -- The type environment is a convenient source of such things.
576 this_pkg = thisPackage (hsc_dflags hsc_env)
578 tidy env [] = return (env, [])
579 tidy env (b:bs) = do { (env1, b') <- tidyTopBind this_pkg mod nc_var ext_ids env b
580 ; (env2, bs') <- tidy env1 bs
581 ; return (env2, b':bs') }
583 ------------------------
584 tidyTopBind :: PackageId
586 -> IORef NameCache -- For allocating new unique names
587 -> IdEnv Bool -- Domain = Ids that should be external
588 -- True <=> their unfolding is external too
589 -> TidyEnv -> CoreBind
590 -> IO (TidyEnv, CoreBind)
592 tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs)
593 = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr
594 ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs)
595 ; subst2 = extendVarEnv subst1 bndr bndr'
596 ; tidy_env2 = (occ_env2, subst2) }
597 ; return (tidy_env2, NonRec bndr' rhs') }
599 caf_info = hasCafRefs this_pkg subst1 (idArity bndr) rhs
601 tidyTopBind this_pkg mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs)
602 = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs
603 ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info)
605 ; subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs')
606 ; tidy_env2 = (occ_env2, subst2) }
607 ; return (tidy_env2, Rec prs') }
611 -- the CafInfo for a recursive group says whether *any* rhs in
612 -- the group may refer indirectly to a CAF (because then, they all do).
614 | or [ mayHaveCafRefs (hasCafRefs this_pkg subst1 (idArity bndr) rhs)
615 | (bndr,rhs) <- prs ] = MayHaveCafRefs
616 | otherwise = NoCafRefs
618 --------------------------------------------------------------------
620 -- This is where we set names to local/global based on whether they really are
621 -- externally visible (see comment at the top of this module). If the name
622 -- was previously local, we have to give it a unique occurrence name if
623 -- we intend to externalise it.
624 tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, [])
625 tidyTopNames mod nc_var ext_ids occ_env (id:ids)
626 = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id
627 ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids
628 ; return (occ_env2, name:names) }
630 tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv
631 -> Id -> IO (TidyOccEnv, Name)
632 tidyTopName mod nc_var ext_ids occ_env id
633 | global && internal = return (occ_env, localiseName name)
635 | global && external = return (occ_env, name)
636 -- Global names are assumed to have been allocated by the renamer,
637 -- so they already have the "right" unique
638 -- And it's a system-wide unique too
640 -- Now we get to the real reason that all this is in the IO Monad:
641 -- we have to update the name cache in a nice atomic fashion
643 | local && internal = do { nc <- readIORef nc_var
644 ; let (nc', new_local_name) = mk_new_local nc
645 ; writeIORef nc_var nc'
646 ; return (occ_env', new_local_name) }
647 -- Even local, internal names must get a unique occurrence, because
648 -- if we do -split-objs we externalise the name later, in the code generator
650 -- Similarly, we must make sure it has a system-wide Unique, because
651 -- the byte-code generator builds a system-wide Name->BCO symbol table
653 | local && external = do { nc <- readIORef nc_var
654 ; let (nc', new_external_name) = mk_new_external nc
655 ; writeIORef nc_var nc'
656 ; return (occ_env', new_external_name) }
659 external = id `elemVarEnv` ext_ids
660 global = isExternalName name
662 internal = not external
663 mb_parent = nameParent_maybe name
664 loc = nameSrcLoc name
666 (occ_env', occ') = tidyOccName occ_env (nameOccName name)
668 mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc)
670 (us1, us2) = splitUniqSupply (nsUniqs nc)
671 uniq = uniqFromSupply us1
673 mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc
674 -- If we want to externalise a currently-local name, check
675 -- whether we have already assigned a unique for it.
676 -- If so, use it; if not, extend the table.
677 -- All this is done by allcoateGlobalBinder.
678 -- This is needed when *re*-compiling a module in GHCi; we must
679 -- use the same name for externally-visible things as we did before.
682 -----------------------------------------------------------
683 tidyTopPair :: VarEnv Bool
684 -> TidyEnv -- The TidyEnv is used to tidy the IdInfo
685 -- It is knot-tied: don't look at it!
688 -> (Id, CoreExpr) -- Binder and RHS before tidying
690 -- This function is the heart of Step 2
691 -- The rec_tidy_env is the one to use for the IdInfo
692 -- It's necessary because when we are dealing with a recursive
693 -- group, a variable late in the group might be mentioned
694 -- in the IdInfo of one early in the group
696 tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs)
697 | isGlobalId bndr -- Injected binding for record selector, etc
698 = (bndr, tidyExpr rhs_tidy_env rhs)
702 bndr' = mkVanillaGlobal name' ty' idinfo'
703 ty' = tidyTopType (idType bndr)
704 rhs' = tidyExpr rhs_tidy_env rhs
705 idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external)
706 (idInfo bndr) unfold_info arity
709 -- Expose an unfolding if ext_ids tells us to
710 -- Remember that ext_ids maps an Id to a Bool:
711 -- True to show the unfolding, False to hide it
712 maybe_external = lookupVarEnv ext_ids bndr
713 show_unfold = maybe_external `orElse` False
714 unfold_info | show_unfold = mkTopUnfolding rhs'
715 | otherwise = noUnfolding
717 -- Usually the Id will have an accurate arity on it, because
718 -- the simplifier has just run, but not always.
719 -- One case I found was when the last thing the simplifier
720 -- did was to let-bind a non-atomic argument and then float
721 -- it to the top level. So it seems more robust just to
723 arity = exprArity rhs
726 -- tidyTopIdInfo creates the final IdInfo for top-level
727 -- binders. There are two delicate pieces:
729 -- * Arity. After CoreTidy, this arity must not change any more.
730 -- Indeed, CorePrep must eta expand where necessary to make
731 -- the manifest arity equal to the claimed arity.
733 -- * CAF info. This must also remain valid through to code generation.
734 -- We add the info here so that it propagates to all
735 -- occurrences of the binders in RHSs, and hence to occurrences in
736 -- unfoldings, which are inside Ids imported by GHCi. Ditto RULES.
737 -- CoreToStg makes use of this when constructing SRTs.
739 tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info
740 | not is_external -- For internal Ids (not externally visible)
741 = vanillaIdInfo -- we only need enough info for code generation
742 -- Arity and strictness info are enough;
743 -- c.f. CoreTidy.tidyLetBndr
744 `setCafInfo` caf_info
746 `setAllStrictnessInfo` newStrictnessInfo idinfo
748 | otherwise -- Externally-visible Ids get the whole lot
750 `setCafInfo` caf_info
752 `setAllStrictnessInfo` newStrictnessInfo idinfo
753 `setInlinePragInfo` inlinePragInfo idinfo
754 `setUnfoldingInfo` unfold_info
755 `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo)
756 -- NB: we throw away the Rules
757 -- They have already been extracted by findExternalRules
761 ------------ Worker --------------
762 tidyWorker tidy_env (HasWorker work_id wrap_arity)
763 = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
764 tidyWorker tidy_env other
768 %************************************************************************
770 \subsection{Figuring out CafInfo for an expression}
772 %************************************************************************
774 hasCafRefs decides whether a top-level closure can point into the dynamic heap.
775 We mark such things as `MayHaveCafRefs' because this information is
776 used to decide whether a particular closure needs to be referenced
779 There are two reasons for setting MayHaveCafRefs:
780 a) The RHS is a CAF: a top-level updatable thunk.
781 b) The RHS refers to something that MayHaveCafRefs
783 Possible improvement: In an effort to keep the number of CAFs (and
784 hence the size of the SRTs) down, we could also look at the expression and
785 decide whether it requires a small bounded amount of heap, so we can ignore
786 it as a CAF. In these cases however, we would need to use an additional
787 CAF list to keep track of non-collectable CAFs.
790 hasCafRefs :: PackageId -> VarEnv Var -> Arity -> CoreExpr -> CafInfo
791 hasCafRefs this_pkg p arity expr
792 | is_caf || mentions_cafs = MayHaveCafRefs
793 | otherwise = NoCafRefs
795 mentions_cafs = isFastTrue (cafRefs p expr)
796 is_caf = not (arity > 0 || rhsIsStatic this_pkg expr)
797 -- NB. we pass in the arity of the expression, which is expected
798 -- to be calculated by exprArity. This is because exprArity
799 -- knows how much eta expansion is going to be done by
800 -- CorePrep later on, and we don't want to duplicate that
801 -- knowledge in rhsIsStatic below.
804 -- imported Ids first:
805 | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id))
806 -- now Ids local to this module:
808 case lookupVarEnv p id of
809 Just id' -> fastBool (mayHaveCafRefs (idCafInfo id'))
810 Nothing -> fastBool False
812 cafRefs p (Lit l) = fastBool False
813 cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a
814 cafRefs p (Lam x e) = cafRefs p e
815 cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e
816 cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts)
817 cafRefs p (Note n e) = cafRefs p e
818 cafRefs p (Cast e co) = cafRefs p e
819 cafRefs p (Type t) = fastBool False
821 cafRefss p [] = fastBool False
822 cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es
824 -- hack for lazy-or over FastBool.
825 fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x))