diff options
Diffstat (limited to 'compiler/main/TidyPgm.lhs')
| -rw-r--r-- | compiler/main/TidyPgm.lhs | 816 |
1 files changed, 816 insertions, 0 deletions
diff --git a/compiler/main/TidyPgm.lhs b/compiler/main/TidyPgm.lhs new file mode 100644 index 0000000000..86e55f9e06 --- /dev/null +++ b/compiler/main/TidyPgm.lhs @@ -0,0 +1,816 @@ +% +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% +\section{Tidying up Core} + +\begin{code} +module TidyPgm( mkBootModDetails, tidyProgram ) where + +#include "HsVersions.h" + +import DynFlags ( DynFlag(..), dopt ) +import Packages ( HomeModules ) +import CoreSyn +import CoreUnfold ( noUnfolding, mkTopUnfolding ) +import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars ) +import CoreTidy ( tidyExpr, tidyVarOcc, tidyRules ) +import PprCore ( pprRules ) +import CoreLint ( showPass, endPass ) +import CoreUtils ( exprArity, rhsIsStatic ) +import VarEnv +import VarSet +import Var ( Id, Var ) +import Id ( idType, idInfo, idName, idCoreRules, isGlobalId, + isExportedId, mkVanillaGlobal, isLocalId, isNaughtyRecordSelector, + idArity, idCafInfo, idUnfolding, isImplicitId, setIdInfo + ) +import IdInfo {- loads of stuff -} +import InstEnv ( Instance, DFunId, instanceDFunId, setInstanceDFunId ) +import NewDemand ( isBottomingSig, topSig ) +import BasicTypes ( Arity, isNeverActive ) +import Name ( Name, getOccName, nameOccName, mkInternalName, + localiseName, isExternalName, nameSrcLoc, nameParent_maybe, + isWiredInName, getName + ) +import NameSet ( NameSet, elemNameSet ) +import IfaceEnv ( allocateGlobalBinder ) +import NameEnv ( filterNameEnv, mapNameEnv ) +import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) +import Type ( tidyTopType ) +import TcType ( isFFITy ) +import DataCon ( dataConName, dataConFieldLabels, dataConWrapId_maybe ) +import TyCon ( TyCon, makeTyConAbstract, tyConDataCons, isNewTyCon, + newTyConRep, tyConSelIds, isAlgTyCon, isEnumerationTyCon ) +import Class ( classSelIds ) +import Module ( Module ) +import HscTypes ( HscEnv(..), NameCache( nsUniqs ), CgGuts(..), + TypeEnv, typeEnvIds, typeEnvElts, typeEnvTyCons, + extendTypeEnvWithIds, lookupTypeEnv, + ModGuts(..), TyThing(..), ModDetails(..), Dependencies(..) + ) +import Maybes ( orElse, mapCatMaybes ) +import ErrUtils ( showPass, dumpIfSet_core ) +import UniqSupply ( splitUniqSupply, uniqFromSupply ) +import List ( partition ) +import Maybe ( isJust ) +import Outputable +import DATA_IOREF ( IORef, readIORef, writeIORef ) +import FastTypes hiding ( fastOr ) +\end{code} + + +Constructing the TypeEnv, Instances, Rules from which the ModIface is +constructed, and which goes on to subsequent modules in --make mode. + +Most of the interface file is obtained simply by serialising the +TypeEnv. One important consequence is that if the *interface file* +has pragma info if and only if the final TypeEnv does. This is not so +important for *this* module, but it's essential for ghc --make: +subsequent compilations must not see (e.g.) the arity if the interface +file does not contain arity If they do, they'll exploit the arity; +then the arity might change, but the iface file doesn't change => +recompilation does not happen => disaster. + +For data types, the final TypeEnv will have a TyThing for the TyCon, +plus one for each DataCon; the interface file will contain just one +data type declaration, but it is de-serialised back into a collection +of TyThings. + +%************************************************************************ +%* * + Plan A: simpleTidyPgm +%* * +%************************************************************************ + + +Plan A: mkBootModDetails: omit pragmas, make interfaces small +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Ignore the bindings + +* Drop all WiredIn things from the TypeEnv + (we never want them in interface files) + +* Retain all TyCons and Classes in the TypeEnv, to avoid + having to find which ones are mentioned in the + types of exported Ids + +* Trim off the constructors of non-exported TyCons, both + from the TyCon and from the TypeEnv + +* Drop non-exported Ids from the TypeEnv + +* Tidy the types of the DFunIds of Instances, + make them into GlobalIds, (they already have External Names) + and add them to the TypeEnv + +* Tidy the types of the (exported) Ids in the TypeEnv, + make them into GlobalIds (they already have External Names) + +* Drop rules altogether + +* Tidy the bindings, to ensure that the Caf and Arity + information is correct for each top-level binder; the + code generator needs it. And to ensure that local names have + distinct OccNames in case of object-file splitting + +\begin{code} +mkBootModDetails :: HscEnv -> ModGuts -> IO ModDetails +-- This is Plan A: make a small type env when typechecking only, +-- or when compiling a hs-boot file, or simply when not using -O +-- +-- We don't look at the bindings at all -- there aren't any +-- for hs-boot files + +mkBootModDetails hsc_env (ModGuts { mg_module = mod, + mg_exports = exports, + mg_types = type_env, + mg_insts = ispecs }) + = do { let dflags = hsc_dflags hsc_env + ; showPass dflags "Tidy [hoot] type env" + + ; let { ispecs' = tidyInstances tidyExternalId ispecs + ; type_env1 = filterNameEnv (not . isWiredInThing) type_env + ; type_env2 = mapNameEnv tidyBootThing type_env1 + ; type_env' = extendTypeEnvWithIds type_env2 + (map instanceDFunId ispecs') + } + ; return (ModDetails { md_types = type_env', + md_insts = ispecs', + md_rules = [], + md_exports = exports }) + } + where + +isWiredInThing :: TyThing -> Bool +isWiredInThing thing = isWiredInName (getName thing) + +tidyBootThing :: TyThing -> TyThing +-- Just externalise the Ids; keep everything +tidyBootThing (AnId id) | isLocalId id = AnId (tidyExternalId id) +tidyBootThing thing = thing + +tidyExternalId :: Id -> Id +-- Takes an LocalId with an External Name, +-- makes it into a GlobalId with VanillaIdInfo, and tidies its type +-- (NB: vanillaIdInfo makes a conservative assumption about Caf-hood.) +tidyExternalId id + = ASSERT2( isLocalId id && isExternalName (idName id), ppr id ) + mkVanillaGlobal (idName id) (tidyTopType (idType id)) vanillaIdInfo +\end{code} + + +%************************************************************************ +%* * + Plan B: tidy bindings, make TypeEnv full of IdInfo +%* * +%************************************************************************ + +Plan B: include pragmas, make interfaces +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +* Figure out which Ids are externally visible + +* Tidy the bindings, externalising appropriate Ids + +* Drop all Ids from the TypeEnv, and add all the External Ids from + the bindings. (This adds their IdInfo to the TypeEnv; and adds + floated-out Ids that weren't even in the TypeEnv before.) + +Step 1: Figure out external Ids +~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ +First we figure out which Ids are "external" Ids. An +"external" Id is one that is visible from outside the compilation +unit. These are + a) the user exported ones + b) ones mentioned in the unfoldings, workers, + or rules of externally-visible ones +This exercise takes a sweep of the bindings bottom to top. Actually, +in Step 2 we're also going to need to know which Ids should be +exported with their unfoldings, so we produce not an IdSet but an +IdEnv Bool + + +Step 2: Tidy the program +~~~~~~~~~~~~~~~~~~~~~~~~ +Next we traverse the bindings top to bottom. For each *top-level* +binder + + 1. Make it into a GlobalId; its IdDetails becomes VanillaGlobal, + reflecting the fact that from now on we regard it as a global, + not local, Id + + 2. Give it a system-wide Unique. + [Even non-exported things need system-wide Uniques because the + byte-code generator builds a single Name->BCO symbol table.] + + We use the NameCache kept in the HscEnv as the + source of such system-wide uniques. + + For external Ids, use the original-name cache in the NameCache + to ensure that the unique assigned is the same as the Id had + in any previous compilation run. + + 3. If it's an external Id, make it have a External Name, otherwise + make it have an Internal Name. + This is used by the code generator to decide whether + to make the label externally visible + + 4. Give external Ids a "tidy" OccName. This means + we can print them in interface files without confusing + "x" (unique 5) with "x" (unique 10). + + 5. Give it its UTTERLY FINAL IdInfo; in ptic, + * its unfolding, if it should have one + + * its arity, computed from the number of visible lambdas + + * its CAF info, computed from what is free in its RHS + + +Finally, substitute these new top-level binders consistently +throughout, including in unfoldings. We also tidy binders in +RHSs, so that they print nicely in interfaces. + +\begin{code} +tidyProgram :: HscEnv -> ModGuts -> IO (CgGuts, ModDetails) +tidyProgram hsc_env + mod_impl@(ModGuts { mg_module = mod, mg_exports = exports, + mg_types = type_env, mg_insts = insts_tc, + mg_binds = binds, + mg_rules = imp_rules, + mg_dir_imps = dir_imps, mg_deps = deps, + mg_home_mods = home_mods, + mg_foreign = foreign_stubs }) + + = do { let dflags = hsc_dflags hsc_env + ; showPass dflags "Tidy Core" + + ; let { omit_prags = dopt Opt_OmitInterfacePragmas dflags + ; ext_ids = findExternalIds omit_prags binds + ; ext_rules + | omit_prags = [] + | otherwise = findExternalRules binds imp_rules ext_ids + -- findExternalRules filters imp_rules to avoid binders that + -- aren't externally visible; but the externally-visible binders + -- are computed (by findExternalIds) assuming that all orphan + -- rules are exported (they get their Exported flag set in the desugarer) + -- So in fact we may export more than we need. + -- (It's a sort of mutual recursion.) + } + + ; (tidy_env, tidy_binds) <- tidyTopBinds hsc_env home_mods mod type_env ext_ids binds + + ; let { tidy_type_env = tidyTypeEnv omit_prags exports type_env tidy_binds + ; tidy_ispecs = tidyInstances (lookup_dfun tidy_type_env) insts_tc + -- A DFunId will have a binding in tidy_binds, and so + -- will now be in final_env, replete with IdInfo + -- Its name will be unchanged since it was born, but + -- we want Global, IdInfo-rich (or not) DFunId in the tidy_ispecs + + ; tidy_rules = tidyRules tidy_env ext_rules + -- You might worry that the tidy_env contains IdInfo-rich stuff + -- and indeed it does, but if omit_prags is on, ext_rules is empty + + ; implicit_binds = getImplicitBinds type_env + ; alg_tycons = filter isAlgTyCon (typeEnvTyCons type_env) + } + + ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds + ; dumpIfSet_core dflags Opt_D_dump_simpl + "Tidy Core Rules" + (pprRules tidy_rules) + + ; return (CgGuts { cg_module = mod, + cg_tycons = alg_tycons, + cg_binds = implicit_binds ++ tidy_binds, + cg_dir_imps = dir_imps, + cg_foreign = foreign_stubs, + cg_home_mods = home_mods, + cg_dep_pkgs = dep_pkgs deps }, + + ModDetails { md_types = tidy_type_env, + md_rules = tidy_rules, + md_insts = tidy_ispecs, + md_exports = exports }) + } + +lookup_dfun type_env dfun_id + = case lookupTypeEnv type_env (idName dfun_id) of + Just (AnId dfun_id') -> dfun_id' + other -> pprPanic "lookup_dfun" (ppr dfun_id) + +tidyTypeEnv :: Bool -> NameSet -> TypeEnv -> [CoreBind] -> TypeEnv + +-- The competed type environment is gotten from +-- Dropping any wired-in things, and then +-- a) keeping the types and classes +-- b) removing all Ids, +-- c) adding Ids with correct IdInfo, including unfoldings, +-- gotten from the bindings +-- From (c) we keep only those Ids with External names; +-- the CoreTidy pass makes sure these are all and only +-- the externally-accessible ones +-- This truncates the type environment to include only the +-- exported Ids and things needed from them, which saves space + +tidyTypeEnv omit_prags exports type_env tidy_binds + = let type_env1 = filterNameEnv keep_it type_env + type_env2 = extendTypeEnvWithIds type_env1 final_ids + type_env3 | omit_prags = mapNameEnv trim_thing type_env2 + | otherwise = type_env2 + in + type_env3 + where + final_ids = [ id | id <- bindersOfBinds tidy_binds, + isExternalName (idName id)] + + -- We keep GlobalIds, because they won't appear + -- in the bindings from which final_ids are derived! + -- (The bindings bind LocalIds.) + keep_it thing | isWiredInThing thing = False + keep_it (AnId id) = isGlobalId id -- Keep GlobalIds (e.g. class ops) + keep_it other = True -- Keep all TyCons, DataCons, and Classes + + trim_thing thing + = case thing of + ATyCon tc | mustExposeTyCon exports tc -> thing + | otherwise -> ATyCon (makeTyConAbstract tc) + + AnId id | isImplicitId id -> thing + | otherwise -> AnId (id `setIdInfo` vanillaIdInfo) + + other -> thing + +mustExposeTyCon :: NameSet -- Exports + -> TyCon -- The tycon + -> Bool -- Can its rep be hidden? +-- We are compiling without -O, and thus trying to write as little as +-- possible into the interface file. But we must expose the details of +-- any data types whose constructors or fields are exported +mustExposeTyCon exports tc + | not (isAlgTyCon tc) -- Synonyms + = True + | isEnumerationTyCon tc -- For an enumeration, exposing the constructors + = True -- won't lead to the need for further exposure + -- (This includes data types with no constructors.) + | otherwise -- Newtype, datatype + = any exported_con (tyConDataCons tc) + -- Expose rep if any datacon or field is exported + + || (isNewTyCon tc && isFFITy (snd (newTyConRep tc))) + -- Expose the rep for newtypes if the rep is an FFI type. + -- For a very annoying reason. 'Foreign import' is meant to + -- be able to look through newtypes transparently, but it + -- can only do that if it can "see" the newtype representation + where + exported_con con = any (`elemNameSet` exports) + (dataConName con : dataConFieldLabels con) + +tidyInstances :: (DFunId -> DFunId) -> [Instance] -> [Instance] +tidyInstances tidy_dfun ispecs + = map tidy ispecs + where + tidy ispec = setInstanceDFunId ispec $ + tidy_dfun (instanceDFunId ispec) + +getImplicitBinds :: TypeEnv -> [CoreBind] +getImplicitBinds type_env + = map get_defn (concatMap implicit_con_ids (typeEnvTyCons type_env) + ++ concatMap other_implicit_ids (typeEnvElts type_env)) + -- Put the constructor wrappers first, because + -- other implicit bindings (notably the fromT functions arising + -- from generics) use the constructor wrappers. At least that's + -- what External Core likes + where + implicit_con_ids tc = mapCatMaybes dataConWrapId_maybe (tyConDataCons tc) + + other_implicit_ids (ATyCon tc) = filter (not . isNaughtyRecordSelector) (tyConSelIds tc) + -- The "naughty" ones are not real functions at all + -- They are there just so we can get decent error messages + -- See Note [Naughty record selectors] in MkId.lhs + other_implicit_ids (AClass cl) = classSelIds cl + other_implicit_ids other = [] + + get_defn :: Id -> CoreBind + get_defn id = NonRec id (tidyExpr emptyTidyEnv rhs) + where + rhs = unfoldingTemplate (idUnfolding id) + -- Don't forget to tidy the body ! Otherwise you get silly things like + -- \ tpl -> case tpl of tpl -> (tpl,tpl) -> tpl +\end{code} + + +%************************************************************************ +%* * +\subsection{Step 1: finding externals} +%* * +%************************************************************************ + +\begin{code} +findExternalIds :: Bool + -> [CoreBind] + -> IdEnv Bool -- In domain => external + -- Range = True <=> show unfolding + -- Step 1 from the notes above +findExternalIds omit_prags binds + | omit_prags + = mkVarEnv [ (id,False) | id <- bindersOfBinds binds, isExportedId id ] + + | otherwise + = foldr find emptyVarEnv binds + where + find (NonRec id rhs) needed + | need_id needed id = addExternal (id,rhs) needed + | otherwise = needed + find (Rec prs) needed = find_prs prs needed + + -- For a recursive group we have to look for a fixed point + find_prs prs needed + | null needed_prs = needed + | otherwise = find_prs other_prs new_needed + where + (needed_prs, other_prs) = partition (need_pr needed) prs + new_needed = foldr addExternal needed needed_prs + + -- The 'needed' set contains the Ids that are needed by earlier + -- interface file emissions. If the Id isn't in this set, and isn't + -- exported, there's no need to emit anything + need_id needed_set id = id `elemVarEnv` needed_set || isExportedId id + need_pr needed_set (id,rhs) = need_id needed_set id + +addExternal :: (Id,CoreExpr) -> IdEnv Bool -> IdEnv Bool +-- The Id is needed; extend the needed set +-- with it and its dependents (free vars etc) +addExternal (id,rhs) needed + = extendVarEnv (foldVarSet add_occ needed new_needed_ids) + id show_unfold + where + add_occ id needed = extendVarEnv needed id False + -- "False" because we don't know we need the Id's unfolding + -- We'll override it later when we find the binding site + + new_needed_ids = worker_ids `unionVarSet` + unfold_ids `unionVarSet` + spec_ids + + idinfo = idInfo id + dont_inline = isNeverActive (inlinePragInfo idinfo) + loop_breaker = isLoopBreaker (occInfo idinfo) + bottoming_fn = isBottomingSig (newStrictnessInfo idinfo `orElse` topSig) + spec_ids = specInfoFreeVars (specInfo idinfo) + worker_info = workerInfo idinfo + + -- Stuff to do with the Id's unfolding + -- The simplifier has put an up-to-date unfolding + -- in the IdInfo, but the RHS will do just as well + unfolding = unfoldingInfo idinfo + rhs_is_small = not (neverUnfold unfolding) + + -- We leave the unfolding there even if there is a worker + -- In GHCI the unfolding is used by importers + -- When writing an interface file, we omit the unfolding + -- if there is a worker + show_unfold = not bottoming_fn && -- Not necessary + not dont_inline && + not loop_breaker && + rhs_is_small -- Small enough + + unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs + | otherwise = emptyVarSet + + worker_ids = case worker_info of + HasWorker work_id _ -> unitVarSet work_id + otherwise -> emptyVarSet +\end{code} + + +\begin{code} +findExternalRules :: [CoreBind] + -> [CoreRule] -- Non-local rules (i.e. ones for imported fns) + -> IdEnv a -- Ids that are exported, so we need their rules + -> [CoreRule] + -- The complete rules are gotten by combining + -- a) the non-local rules + -- b) rules embedded in the top-level Ids +findExternalRules binds non_local_rules ext_ids + = filter (not . internal_rule) (non_local_rules ++ local_rules) + where + local_rules = [ rule + | id <- bindersOfBinds binds, + id `elemVarEnv` ext_ids, + rule <- idCoreRules id + ] + + internal_rule rule + = any internal_id (varSetElems (ruleLhsFreeIds rule)) + -- Don't export a rule whose LHS mentions a locally-defined + -- Id that is completely internal (i.e. not visible to an + -- importing module) + + internal_id id = not (id `elemVarEnv` ext_ids) +\end{code} + + + +%************************************************************************ +%* * +\subsection{Step 2: top-level tidying} +%* * +%************************************************************************ + + +\begin{code} +-- TopTidyEnv: when tidying we need to know +-- * nc_var: The NameCache, containing a unique supply and any pre-ordained Names. +-- These may have arisen because the +-- renamer read in an interface file mentioning M.$wf, say, +-- and assigned it unique r77. If, on this compilation, we've +-- invented an Id whose name is $wf (but with a different unique) +-- we want to rename it to have unique r77, so that we can do easy +-- comparisons with stuff from the interface file +-- +-- * occ_env: The TidyOccEnv, which tells us which local occurrences +-- are 'used' +-- +-- * subst_env: A Var->Var mapping that substitutes the new Var for the old + +tidyTopBinds :: HscEnv + -> HomeModules + -> Module + -> TypeEnv + -> IdEnv Bool -- Domain = Ids that should be external + -- True <=> their unfolding is external too + -> [CoreBind] + -> IO (TidyEnv, [CoreBind]) + +tidyTopBinds hsc_env hmods mod type_env ext_ids binds + = tidy init_env binds + where + nc_var = hsc_NC hsc_env + + -- We also make sure to avoid any exported binders. Consider + -- f{-u1-} = 1 -- Local decl + -- ... + -- f{-u2-} = 2 -- Exported decl + -- + -- The second exported decl must 'get' the name 'f', so we + -- have to put 'f' in the avoids list before we get to the first + -- decl. tidyTopId then does a no-op on exported binders. + init_env = (initTidyOccEnv avoids, emptyVarEnv) + avoids = [getOccName name | bndr <- typeEnvIds type_env, + let name = idName bndr, + isExternalName name] + -- In computing our "avoids" list, we must include + -- all implicit Ids + -- all things with global names (assigned once and for + -- all by the renamer) + -- since their names are "taken". + -- The type environment is a convenient source of such things. + + tidy env [] = return (env, []) + tidy env (b:bs) = do { (env1, b') <- tidyTopBind hmods mod nc_var ext_ids env b + ; (env2, bs') <- tidy env1 bs + ; return (env2, b':bs') } + +------------------------ +tidyTopBind :: HomeModules + -> Module + -> IORef NameCache -- For allocating new unique names + -> IdEnv Bool -- Domain = Ids that should be external + -- True <=> their unfolding is external too + -> TidyEnv -> CoreBind + -> IO (TidyEnv, CoreBind) + +tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (NonRec bndr rhs) + = do { (occ_env2, name') <- tidyTopName mod nc_var ext_ids occ_env1 bndr + ; let { (bndr', rhs') = tidyTopPair ext_ids tidy_env2 caf_info name' (bndr, rhs) + ; subst2 = extendVarEnv subst1 bndr bndr' + ; tidy_env2 = (occ_env2, subst2) } + ; return (tidy_env2, NonRec bndr' rhs') } + where + caf_info = hasCafRefs hmods subst1 (idArity bndr) rhs + +tidyTopBind hmods mod nc_var ext_ids tidy_env1@(occ_env1,subst1) (Rec prs) + = do { (occ_env2, names') <- tidyTopNames mod nc_var ext_ids occ_env1 bndrs + ; let { prs' = zipWith (tidyTopPair ext_ids tidy_env2 caf_info) + names' prs + ; subst2 = extendVarEnvList subst1 (bndrs `zip` map fst prs') + ; tidy_env2 = (occ_env2, subst2) } + ; return (tidy_env2, Rec prs') } + where + bndrs = map fst prs + + -- the CafInfo for a recursive group says whether *any* rhs in + -- the group may refer indirectly to a CAF (because then, they all do). + caf_info + | or [ mayHaveCafRefs (hasCafRefs hmods subst1 (idArity bndr) rhs) + | (bndr,rhs) <- prs ] = MayHaveCafRefs + | otherwise = NoCafRefs + +-------------------------------------------------------------------- +-- tidyTopName +-- This is where we set names to local/global based on whether they really are +-- externally visible (see comment at the top of this module). If the name +-- was previously local, we have to give it a unique occurrence name if +-- we intend to externalise it. +tidyTopNames mod nc_var ext_ids occ_env [] = return (occ_env, []) +tidyTopNames mod nc_var ext_ids occ_env (id:ids) + = do { (occ_env1, name) <- tidyTopName mod nc_var ext_ids occ_env id + ; (occ_env2, names) <- tidyTopNames mod nc_var ext_ids occ_env1 ids + ; return (occ_env2, name:names) } + +tidyTopName :: Module -> IORef NameCache -> VarEnv Bool -> TidyOccEnv + -> Id -> IO (TidyOccEnv, Name) +tidyTopName mod nc_var ext_ids occ_env id + | global && internal = return (occ_env, localiseName name) + + | global && external = return (occ_env, name) + -- Global names are assumed to have been allocated by the renamer, + -- so they already have the "right" unique + -- And it's a system-wide unique too + + -- Now we get to the real reason that all this is in the IO Monad: + -- we have to update the name cache in a nice atomic fashion + + | local && internal = do { nc <- readIORef nc_var + ; let (nc', new_local_name) = mk_new_local nc + ; writeIORef nc_var nc' + ; return (occ_env', new_local_name) } + -- Even local, internal names must get a unique occurrence, because + -- if we do -split-objs we externalise the name later, in the code generator + -- + -- Similarly, we must make sure it has a system-wide Unique, because + -- the byte-code generator builds a system-wide Name->BCO symbol table + + | local && external = do { nc <- readIORef nc_var + ; let (nc', new_external_name) = mk_new_external nc + ; writeIORef nc_var nc' + ; return (occ_env', new_external_name) } + where + name = idName id + external = id `elemVarEnv` ext_ids + global = isExternalName name + local = not global + internal = not external + mb_parent = nameParent_maybe name + loc = nameSrcLoc name + + (occ_env', occ') = tidyOccName occ_env (nameOccName name) + + mk_new_local nc = (nc { nsUniqs = us2 }, mkInternalName uniq occ' loc) + where + (us1, us2) = splitUniqSupply (nsUniqs nc) + uniq = uniqFromSupply us1 + + mk_new_external nc = allocateGlobalBinder nc mod occ' mb_parent loc + -- If we want to externalise a currently-local name, check + -- whether we have already assigned a unique for it. + -- If so, use it; if not, extend the table. + -- All this is done by allcoateGlobalBinder. + -- This is needed when *re*-compiling a module in GHCi; we must + -- use the same name for externally-visible things as we did before. + + +----------------------------------------------------------- +tidyTopPair :: VarEnv Bool + -> TidyEnv -- The TidyEnv is used to tidy the IdInfo + -- It is knot-tied: don't look at it! + -> CafInfo + -> Name -- New name + -> (Id, CoreExpr) -- Binder and RHS before tidying + -> (Id, CoreExpr) + -- This function is the heart of Step 2 + -- The rec_tidy_env is the one to use for the IdInfo + -- It's necessary because when we are dealing with a recursive + -- group, a variable late in the group might be mentioned + -- in the IdInfo of one early in the group + +tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) + | isGlobalId bndr -- Injected binding for record selector, etc + = (bndr, tidyExpr rhs_tidy_env rhs) + | otherwise + = (bndr', rhs') + where + bndr' = mkVanillaGlobal name' ty' idinfo' + ty' = tidyTopType (idType bndr) + rhs' = tidyExpr rhs_tidy_env rhs + idinfo' = tidyTopIdInfo rhs_tidy_env (isJust maybe_external) + (idInfo bndr) unfold_info arity + caf_info + + -- Expose an unfolding if ext_ids tells us to + -- Remember that ext_ids maps an Id to a Bool: + -- True to show the unfolding, False to hide it + maybe_external = lookupVarEnv ext_ids bndr + show_unfold = maybe_external `orElse` False + unfold_info | show_unfold = mkTopUnfolding rhs' + | otherwise = noUnfolding + + -- Usually the Id will have an accurate arity on it, because + -- the simplifier has just run, but not always. + -- One case I found was when the last thing the simplifier + -- did was to let-bind a non-atomic argument and then float + -- it to the top level. So it seems more robust just to + -- fix it here. + arity = exprArity rhs + + +-- tidyTopIdInfo creates the final IdInfo for top-level +-- binders. There are two delicate pieces: +-- +-- * Arity. After CoreTidy, this arity must not change any more. +-- Indeed, CorePrep must eta expand where necessary to make +-- the manifest arity equal to the claimed arity. +-- +-- * CAF info. This must also remain valid through to code generation. +-- We add the info here so that it propagates to all +-- occurrences of the binders in RHSs, and hence to occurrences in +-- unfoldings, which are inside Ids imported by GHCi. Ditto RULES. +-- CoreToStg makes use of this when constructing SRTs. + +tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info + | not is_external -- For internal Ids (not externally visible) + = vanillaIdInfo -- we only need enough info for code generation + -- Arity and strictness info are enough; + -- c.f. CoreTidy.tidyLetBndr + `setCafInfo` caf_info + `setArityInfo` arity + `setAllStrictnessInfo` newStrictnessInfo idinfo + + | otherwise -- Externally-visible Ids get the whole lot + = vanillaIdInfo + `setCafInfo` caf_info + `setArityInfo` arity + `setAllStrictnessInfo` newStrictnessInfo idinfo + `setInlinePragInfo` inlinePragInfo idinfo + `setUnfoldingInfo` unfold_info + `setWorkerInfo` tidyWorker tidy_env (workerInfo idinfo) + -- NB: we throw away the Rules + -- They have already been extracted by findExternalRules + + + +------------ Worker -------------- +tidyWorker tidy_env (HasWorker work_id wrap_arity) + = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity +tidyWorker tidy_env other + = NoWorker +\end{code} + +%************************************************************************ +%* * +\subsection{Figuring out CafInfo for an expression} +%* * +%************************************************************************ + +hasCafRefs decides whether a top-level closure can point into the dynamic heap. +We mark such things as `MayHaveCafRefs' because this information is +used to decide whether a particular closure needs to be referenced +in an SRT or not. + +There are two reasons for setting MayHaveCafRefs: + a) The RHS is a CAF: a top-level updatable thunk. + b) The RHS refers to something that MayHaveCafRefs + +Possible improvement: In an effort to keep the number of CAFs (and +hence the size of the SRTs) down, we could also look at the expression and +decide whether it requires a small bounded amount of heap, so we can ignore +it as a CAF. In these cases however, we would need to use an additional +CAF list to keep track of non-collectable CAFs. + +\begin{code} +hasCafRefs :: HomeModules -> VarEnv Var -> Arity -> CoreExpr -> CafInfo +hasCafRefs hmods p arity expr + | is_caf || mentions_cafs = MayHaveCafRefs + | otherwise = NoCafRefs + where + mentions_cafs = isFastTrue (cafRefs p expr) + is_caf = not (arity > 0 || rhsIsStatic hmods expr) + -- NB. we pass in the arity of the expression, which is expected + -- to be calculated by exprArity. This is because exprArity + -- knows how much eta expansion is going to be done by + -- CorePrep later on, and we don't want to duplicate that + -- knowledge in rhsIsStatic below. + +cafRefs p (Var id) + -- imported Ids first: + | not (isLocalId id) = fastBool (mayHaveCafRefs (idCafInfo id)) + -- now Ids local to this module: + | otherwise = + case lookupVarEnv p id of + Just id' -> fastBool (mayHaveCafRefs (idCafInfo id')) + Nothing -> fastBool False + +cafRefs p (Lit l) = fastBool False +cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a +cafRefs p (Lam x e) = cafRefs p e +cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e +cafRefs p (Case e bndr _ alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts) +cafRefs p (Note n e) = cafRefs p e +cafRefs p (Type t) = fastBool False + +cafRefss p [] = fastBool False +cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es + +-- hack for lazy-or over FastBool. +fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) +\end{code} |