X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FTidyPgm.lhs;h=ee4b5bbda5c513adc4f47a311638e0e22b20f4c7;hb=281bcf70ef27e49f4b0c22ce56f93fa924d6ccbd;hp=26a2fde6d6103481fea199153202a50c6f3dc7be;hpb=4e70004befab3a019f9de39fc4d0ab8dca518b38;p=ghc-hetmet.git diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index 26a2fde..ee4b5bb 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -8,14 +8,14 @@ module TidyPgm( tidyCorePgm, tidyCoreExpr ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) +import CmdLineOpts ( DynFlags, DynFlag(..), dopt ) import CoreSyn -import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) -import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars ) +import CoreUnfold ( noUnfolding, mkTopUnfolding ) +import CoreFVs ( ruleLhsFreeIds, exprSomeFreeVars ) import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules ) import PprCore ( pprIdRules ) import CoreLint ( showPass, endPass ) -import CoreUtils ( exprArity, rhsIsNonUpd ) +import CoreUtils ( exprArity, rhsIsStatic ) import VarEnv import VarSet import Var ( Id, Var ) @@ -26,27 +26,25 @@ import Id ( idType, idInfo, idName, idCoreRules, import IdInfo {- loads of stuff -} import NewDemand ( isBottomingSig, topSig ) import BasicTypes ( Arity, isNeverActive ) -import Name ( getOccName, nameOccName, mkInternalName, - localiseName, isExternalName, nameSrcLoc +import Name ( Name, getOccName, nameOccName, mkInternalName, + localiseName, isExternalName, nameSrcLoc, nameParent_maybe ) -import RnEnv ( lookupOrigNameCache, newExternalName ) +import IfaceEnv ( allocateGlobalBinder ) import NameEnv ( lookupNameEnv, filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType ) import Module ( Module ) -import HscTypes ( PersistentCompilerState( pcs_nc ), - NameCache( nsNames, nsUniqs ), +import HscTypes ( HscEnv(..), NameCache( nsUniqs ), TypeEnv, extendTypeEnvList, typeEnvIds, ModGuts(..), ModGuts, TyThing(..) ) import Maybes ( orElse ) import ErrUtils ( showPass, dumpIfSet_core ) -import UniqFM ( mapUFM ) import UniqSupply ( splitUniqSupply, uniqFromSupply ) import List ( partition ) -import Util ( mapAccumL ) import Maybe ( isJust ) import Outputable +import DATA_IOREF ( IORef, readIORef, writeIORef ) import FastTypes hiding ( fastOr ) \end{code} @@ -86,7 +84,7 @@ binder [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 PersistentCompilerState as the + 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 @@ -118,24 +116,25 @@ throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code} -tidyCorePgm :: DynFlags - -> PersistentCompilerState - -> ModGuts - -> IO (PersistentCompilerState, ModGuts) +tidyCorePgm :: HscEnv -> ModGuts -> IO ModGuts -tidyCorePgm dflags pcs +tidyCorePgm hsc_env mod_impl@(ModGuts { mg_module = mod, mg_types = env_tc, mg_insts = insts_tc, mg_binds = binds_in, mg_rules = orphans_in }) - = do { showPass dflags "Tidy Core" + = do { let { dflags = hsc_dflags hsc_env + ; nc_var = hsc_NC hsc_env } + ; showPass dflags "Tidy Core" - ; let ext_ids = findExternalSet binds_in orphans_in - ; let ext_rules = findExternalRules binds_in orphans_in ext_ids + ; let omit_iface_prags = dopt Opt_OmitInterfacePragmas dflags + ; let ext_ids = findExternalSet omit_iface_prags binds_in + ; let ext_rules = findExternalRules omit_iface_prags binds_in orphans_in ext_ids -- findExternalRules filters ext_rules to avoid binders that -- aren't externally visible; but the externally-visible binders -- are computed (by findExternalSet) assuming that all orphan - -- rules are exported. So in fact we may export more than we - -- need. (It's a sort of mutual recursion.) + -- 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.) -- We also make sure to avoid any exported binders. Consider -- f{-u1-} = 1 -- Local decl @@ -145,9 +144,8 @@ tidyCorePgm dflags pcs -- 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. - ; let orig_ns = pcs_nc pcs - init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv) - avoids = [getOccName name | bndr <- typeEnvIds env_tc, + ; let init_env = (initTidyOccEnv avoids, emptyVarEnv) + avoids = [getOccName name | bndr <- typeEnvIds env_tc, let name = idName bndr, isExternalName name] -- In computing our "avoids" list, we must include @@ -157,22 +155,20 @@ tidyCorePgm dflags pcs -- since their names are "taken". -- The type environment is a convenient source of such things. - ; let ((orig_ns', occ_env, subst_env), tidy_binds) - = mapAccumL (tidyTopBind mod ext_ids) - init_tidy_env binds_in + ; (final_env, tidy_binds) + <- tidyTopBinds dflags mod nc_var ext_ids init_env binds_in - ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules + ; let tidy_rules = tidyIdRules final_env ext_rules - ; let pcs' = pcs { pcs_nc = orig_ns' } - - ; let tidy_type_env = mkFinalTypeEnv env_tc tidy_binds + ; let tidy_type_env = mkFinalTypeEnv omit_iface_prags env_tc tidy_binds -- Dfuns are local Ids that might have -- changed their unique during tidying. Remember -- to lookup the id in the TypeEnv too, because -- those Ids have had their IdInfo stripped if -- necessary. - ; let lookup_dfun_id id = + ; let (_, subst_env ) = final_env + lookup_dfun_id id = case lookupVarEnv subst_env id of Nothing -> dfun_panic Just id -> @@ -194,7 +190,7 @@ tidyCorePgm dflags pcs "Tidy Core Rules" (pprIdRules tidy_rules) - ; return (pcs', tidy_result) + ; return tidy_result } tidyCoreExpr :: CoreExpr -> IO CoreExpr @@ -209,7 +205,8 @@ tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr) %************************************************************************ \begin{code} -mkFinalTypeEnv :: TypeEnv -- From typechecker +mkFinalTypeEnv :: Bool -- Omit interface pragmas + -> TypeEnv -- From typechecker -> [CoreBind] -- Final Ids -> TypeEnv @@ -218,7 +215,7 @@ mkFinalTypeEnv :: TypeEnv -- From typechecker -- b) removing all Ids, -- c) adding Ids with correct IdInfo, including unfoldings, -- gotten from the bindings --- From (c) we keep only those Ids with Global names; +-- 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 @@ -228,7 +225,7 @@ mkFinalTypeEnv :: TypeEnv -- From typechecker -- in interface files, because they are needed by importing modules when -- using the compilation manager -mkFinalTypeEnv type_env tidy_binds +mkFinalTypeEnv omit_iface_prags type_env tidy_binds = extendTypeEnvList (filterNameEnv keep_it type_env) final_ids where final_ids = [ AnId (strip_id_info id) @@ -237,8 +234,8 @@ mkFinalTypeEnv type_env tidy_binds isExternalName (idName id)] strip_id_info id - | opt_OmitInterfacePragmas = id `setIdInfo` vanillaIdInfo - | otherwise = id + | omit_iface_prags = id `setIdInfo` vanillaIdInfo + | otherwise = id -- If the interface file has no pragma info then discard all -- info right here. -- @@ -264,35 +261,40 @@ mkFinalTypeEnv type_env tidy_binds \end{code} \begin{code} -findExternalRules :: [CoreBind] +findExternalRules :: Bool -- Omit interface pragmas + -> [CoreBind] -> [IdCoreRule] -- Orphan rules -> IdEnv a -- Ids that are exported, so we need their rules -> [IdCoreRule] -- The complete rules are gotten by combining -- a) the orphan rules -- b) rules embedded in the top-level Ids -findExternalRules binds orphan_rules ext_ids - | opt_OmitInterfacePragmas = [] +findExternalRules omit_iface_prags binds orphan_rules ext_ids + | omit_iface_prags = [] | otherwise - = filter needed_rule (orphan_rules ++ local_rules) + = filter (not . internal_rule) (orphan_rules ++ local_rules) where local_rules = [ rule | id <- bindersOfBinds binds, id `elemVarEnv` ext_ids, rule <- idCoreRules id ] - needed_rule (id, rule) - = not (isBuiltinRule rule) + internal_rule (IdCoreRule id is_orphan rule) + = isBuiltinRule rule -- We can't print builtin rules in interface files -- Since they are built in, an importing module -- will have access to them anyway - && not (any internal_id (varSetElems (ruleLhsFreeIds rule))) + || (not is_orphan && internal_id id) + -- Rule for an Id in this module; internal if the + -- Id is not exported + + || any internal_id (varSetElems (ruleLhsFreeIds rule)) -- Don't export a rule whose LHS mentions an Id that -- is completely internal (i.e. not visible to an -- importing module) - internal_id id = isLocalId id && not (id `elemVarEnv` ext_ids) + internal_id id = not (id `elemVarEnv` ext_ids) \end{code} %************************************************************************ @@ -302,25 +304,16 @@ findExternalRules binds orphan_rules ext_ids %************************************************************************ \begin{code} -findExternalSet :: [CoreBind] -> [IdCoreRule] +findExternalSet :: Bool -- Omit interface pragmas + -> [CoreBind] -> IdEnv Bool -- In domain => external -- Range = True <=> show unfolding -- Step 1 from the notes above -findExternalSet binds orphan_rules - = foldr find init_needed binds +findExternalSet omit_iface_prags binds + = foldr find emptyVarEnv binds where - orphan_rule_ids :: IdSet - orphan_rule_ids = unionVarSets [ ruleRhsFreeVars rule - | (_, rule) <- orphan_rules] - init_needed :: IdEnv Bool - init_needed = mapUFM (\_ -> False) orphan_rule_ids - -- The mapUFM is a bit cheesy. It is a cheap way - -- to turn the set of orphan_rule_ids, which we use to initialise - -- the sweep, into a mapping saying 'don't expose unfolding' - -- (When we come to the binding site we may change our mind, of course.) - find (NonRec id rhs) needed - | need_id needed id = addExternal (id,rhs) needed + | need_id needed id = addExternal omit_iface_prags (id,rhs) needed | otherwise = needed find (Rec prs) needed = find_prs prs needed @@ -330,7 +323,7 @@ findExternalSet binds orphan_rules | otherwise = find_prs other_prs new_needed where (needed_prs, other_prs) = partition (need_pr needed) prs - new_needed = foldr addExternal needed needed_prs + new_needed = foldr (addExternal omit_iface_prags) 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 @@ -338,10 +331,10 @@ findExternalSet binds orphan_rules 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 +addExternal :: Bool -> (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 +addExternal omit_iface_prags (id,rhs) needed = extendVarEnv (foldVarSet add_occ needed new_needed_ids) id show_unfold where @@ -349,10 +342,10 @@ addExternal (id,rhs) needed -- "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 | opt_OmitInterfacePragmas = emptyVarSet - | otherwise = worker_ids `unionVarSet` - unfold_ids `unionVarSet` - spec_ids + new_needed_ids | omit_iface_prags = emptyVarSet + | otherwise = worker_ids `unionVarSet` + unfold_ids `unionVarSet` + spec_ids idinfo = idInfo id dont_inline = isNeverActive (inlinePragInfo idinfo) @@ -374,8 +367,7 @@ addExternal (id,rhs) needed show_unfold = not bottoming_fn && -- Not necessary not dont_inline && not loop_breaker && - rhs_is_small && -- Small enough - okToUnfoldInHiFile rhs -- No casms etc + rhs_is_small -- Small enough unfold_ids | show_unfold = exprSomeFreeVars isLocalId rhs | otherwise = emptyVarSet @@ -394,10 +386,8 @@ addExternal (id,rhs) needed \begin{code} -type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var) - -- TopTidyEnv: when tidying we need to know --- * ns: The NameCache, containing a unique supply and any pre-ordained Names. +-- * 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 @@ -409,91 +399,153 @@ type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var) -- are 'used' -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -\end{code} - -\begin{code} -tidyTopBind :: Module - -> IdEnv Bool -- Domain = Ids that should be external +tidyTopBinds :: DynFlags + -> Module + -> IORef NameCache -- For allocating new unique names + -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too - -> TopTidyEnv -> CoreBind - -> (TopTidyEnv, CoreBind) - -tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (NonRec bndr rhs) - = ((orig,occ,subst) , NonRec bndr' rhs') + -> TidyEnv -> [CoreBind] + -> IO (TidyEnv, [CoreBind]) +tidyTopBinds dflags mod nc_var ext_ids tidy_env [] + = return (tidy_env, []) + +tidyTopBinds dflags mod nc_var ext_ids tidy_env (b:bs) + = do { (tidy_env1, b') <- tidyTopBind dflags mod nc_var ext_ids tidy_env b + ; (tidy_env2, bs') <- tidyTopBinds dflags mod nc_var ext_ids tidy_env1 bs + ; return (tidy_env2, b':bs') } + +------------------------ +tidyTopBind :: DynFlags + -> 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 dflags 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 - ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids caf_info - rec_tidy_env rhs rhs' top_tidy_env bndr - rec_tidy_env = (occ,subst) - rhs' = tidyExpr rec_tidy_env rhs - caf_info = hasCafRefs subst1 (idArity bndr') rhs' - -tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (Rec prs) - = (final_env, Rec prs') + caf_info = hasCafRefs dflags subst1 (idArity bndr) rhs + +tidyTopBind dflags 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 - (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs - rec_tidy_env = (occ,subst) - - do_one top_tidy_env (bndr,rhs) - = ((orig,occ,subst), (bndr',rhs')) - where - ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids caf_info - rec_tidy_env rhs rhs' top_tidy_env bndr - - rhs' = tidyExpr rec_tidy_env rhs + 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 subst1 (idArity bndr) rhs) + | or [ mayHaveCafRefs (hasCafRefs dflags subst1 (idArity bndr) rhs) | (bndr,rhs) <- prs ] = MayHaveCafRefs - | otherwise = NoCafRefs - -tidyTopBinder :: Module -> IdEnv Bool -> CafInfo - -> TidyEnv -- The TidyEnv is used to tidy the IdInfo - -> CoreExpr -- RHS *before* tidying - -> CoreExpr -- RHS *after* tidying - -- The TidyEnv and the after-tidying RHS are - -- both are knot-tied: don't look at them! - -> TopTidyEnv -> Id -> (TopTidyEnv, Id) - -- NB: tidyTopBinder doesn't affect the unique supply - -tidyTopBinder mod ext_ids caf_info rec_tidy_env rhs tidy_rhs - env@(ns2, occ_env2, subst_env2) id + | 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 want to + -- 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 - -- The rhs is already tidied - - = ASSERT(isLocalId id) -- "all Ids defined in this module are local - -- until the CoreTidy phase" --GHC comentary - ((orig_env', occ_env', subst_env'), id') +tidyTopPair ext_ids rhs_tidy_env caf_info name' (bndr, rhs) + = ASSERT(isLocalId bndr) -- "all Ids defined in this module are local + -- until the CoreTidy phase" --GHC comentary + (bndr', rhs') where - (orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2 - is_external - (idName id) - ty' = tidyTopType (idType id) - idinfo = tidyTopIdInfo rec_tidy_env is_external - (idInfo id) unfold_info arity - caf_info - - id' = mkVanillaGlobal name' ty' idinfo - - subst_env' = extendVarEnv subst_env2 id id' - - maybe_external = lookupVarEnv ext_ids id - is_external = isJust maybe_external + 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 tidy_rhs + unfold_info | show_unfold = mkTopUnfolding rhs' | otherwise = noUnfolding -- Usually the Id will have an accurate arity on it, because @@ -539,50 +591,6 @@ tidyTopIdInfo tidy_env is_external idinfo unfold_info arity caf_info -- They have already been extracted by findExternalRules --- 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. -tidyTopName mod ns occ_env external name - | global && internal = (ns, occ_env, localiseName name) - - | global && external = (ns, 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 - - | local && internal = (ns_w_local, 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 = case lookupOrigNameCache ns_names mod occ' of - Just orig -> (ns, occ_env', orig) - Nothing -> (ns_w_global, occ_env', new_external_name) - -- 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 (ns_w_global). - -- This is needed when *re*-compiling a module in GHCi; we want to - -- use the same name for externally-visible things as we did before. - - where - global = isExternalName name - local = not global - internal = not external - loc = nameSrcLoc name - - (occ_env', occ') = tidyOccName occ_env (nameOccName name) - - ns_names = nsNames ns - (us1, us2) = splitUniqSupply (nsUniqs ns) - uniq = uniqFromSupply us1 - new_local_name = mkInternalName uniq occ' loc - ns_w_local = ns { nsUniqs = us2 } - - (ns_w_global, new_external_name) = newExternalName ns mod occ' loc - ------------ Worker -------------- tidyWorker tidy_env (HasWorker work_id wrap_arity) @@ -613,18 +621,18 @@ 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 :: VarEnv Var -> Arity -> CoreExpr -> CafInfo -hasCafRefs p arity expr +hasCafRefs :: DynFlags -> VarEnv Var -> Arity -> CoreExpr -> CafInfo +hasCafRefs dflags p arity expr | is_caf || mentions_cafs = MayHaveCafRefs | otherwise = NoCafRefs where mentions_cafs = isFastTrue (cafRefs p expr) - is_caf = not (arity > 0 || rhsIsNonUpd expr) + is_caf = not (arity > 0 || rhsIsStatic dflags 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 rhsIsNonUpd below. + -- knowledge in rhsIsStatic below. cafRefs p (Var id) -- imported Ids first: @@ -635,13 +643,13 @@ cafRefs p (Var id) 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 +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