X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fmain%2FTidyPgm.lhs;h=01cdd0f0a831bd20263bf85b2e5f14fd9a8fb151;hb=57c616120454d7d4f2f1b6c339886b52ca83a394;hp=bacbee47e8cf58ba3215c5c6c08a66ef4ca9dbc3;hpb=5b016a3f9e10a7714453913a97273ca3d180d372;p=ghc-hetmet.git diff --git a/ghc/compiler/main/TidyPgm.lhs b/ghc/compiler/main/TidyPgm.lhs index bacbee4..01cdd0f 100644 --- a/ghc/compiler/main/TidyPgm.lhs +++ b/ghc/compiler/main/TidyPgm.lhs @@ -8,50 +8,48 @@ module TidyPgm( tidyCorePgm, tidyCoreExpr ) where #include "HsVersions.h" -import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas ) +import CmdLineOpts ( DynFlag(..), dopt ) import CoreSyn -import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile ) +import CoreUnfold ( noUnfolding, mkTopUnfolding ) import CoreFVs ( ruleLhsFreeIds, ruleRhsFreeVars, exprSomeFreeVars ) import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules ) import PprCore ( pprIdRules ) import CoreLint ( showPass, endPass ) -import CoreUtils ( exprArity ) +import CoreUtils ( exprArity, rhsIsStatic ) import VarEnv import VarSet import Var ( Id, Var ) import Id ( idType, idInfo, idName, idCoreRules, isExportedId, mkVanillaGlobal, isLocalId, - isImplicitId + isImplicitId, idArity, setIdInfo, idCafInfo ) import IdInfo {- loads of stuff -} import NewDemand ( isBottomingSig, topSig ) -import BasicTypes ( isNeverActive ) -import Name ( getOccName, nameOccName, mkInternalName, mkExternalName, - localiseName, isExternalName, nameSrcLoc +import BasicTypes ( Arity, isNeverActive ) +import Name ( Name, getOccName, nameOccName, mkInternalName, + localiseName, isExternalName, nameSrcLoc, nameParent_maybe ) -import NameEnv ( filterNameEnv ) +import IfaceEnv ( allocateGlobalBinder ) +import NameEnv ( lookupNameEnv, filterNameEnv ) import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName ) import Type ( tidyTopType ) -import Module ( Module, moduleName ) -import HscTypes ( PersistentCompilerState( pcs_PRS ), - PersistentRenamerState( prsOrig ), - NameSupply( nsNames, nsUniqs ), +import Module ( Module ) +import HscTypes ( HscEnv(..), NameCache( nsUniqs ), TypeEnv, extendTypeEnvList, typeEnvIds, - ModDetails(..), TyThing(..) + ModGuts(..), ModGuts, TyThing(..) ) -import FiniteMap ( lookupFM, addToFM ) 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} - %************************************************************************ %* * \subsection{What goes on} @@ -87,10 +85,10 @@ binder [Even non-exported things need system-wide Uniques because the byte-code generator builds a single Name->BCO symbol table.] - We use the NameSupply kept in the PersistentRenamerState 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 NameSupply + 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. @@ -119,20 +117,19 @@ throughout, including in unfoldings. We also tidy binders in RHSs, so that they print nicely in interfaces. \begin{code} -tidyCorePgm :: DynFlags -> Module - -> PersistentCompilerState - -> CgInfoEnv -- Information from the back end, - -- to be splatted into the IdInfo - -> ModDetails - -> IO (PersistentCompilerState, ModDetails) - -tidyCorePgm dflags mod pcs cg_info_env - (ModDetails { md_types = env_tc, md_insts = insts_tc, - md_binds = binds_in, md_rules = orphans_in }) - = do { showPass dflags "Tidy Core" - - ; let ext_ids = findExternalSet binds_in orphans_in - ; let ext_rules = findExternalRules binds_in orphans_in ext_ids +tidyCorePgm :: HscEnv -> ModGuts -> IO ModGuts + +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 { let { dflags = hsc_dflags hsc_env + ; nc_var = hsc_NC hsc_env } + ; showPass dflags "Tidy Core" + + ; let omit_iface_prags = dopt Opt_OmitInterfacePragmas dflags + ; let ext_ids = findExternalSet omit_iface_prags binds_in orphans_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 @@ -147,11 +144,8 @@ tidyCorePgm dflags mod pcs cg_info_env -- 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 prs = pcs_PRS pcs - orig_ns = prsOrig prs - - 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 @@ -161,40 +155,42 @@ tidyCorePgm dflags mod pcs cg_info_env -- 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 cg_info_env) - init_tidy_env binds_in + ; (final_env, tidy_binds) + <- tidyTopBinds 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 prs' = prs { prsOrig = orig_ns' } - pcs' = pcs { pcs_PRS = prs' } - - ; let final_ids = [ id - | bind <- tidy_binds - , id <- bindersOf bind - , isExternalName (idName id)] + ; let tidy_type_env = mkFinalTypeEnv omit_iface_prags env_tc tidy_binds -- Dfuns are local Ids that might have - -- changed their unique during tidying - ; let lookup_dfun_id id = lookupVarEnv subst_env id `orElse` - pprPanic "lookup_dfun_id" (ppr id) - + -- 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 (_, subst_env ) = final_env + lookup_dfun_id id = + case lookupVarEnv subst_env id of + Nothing -> dfun_panic + Just id -> + case lookupNameEnv tidy_type_env (idName id) of + Just (AnId id) -> id + _other -> dfun_panic + where + dfun_panic = pprPanic "lookup_dfun_id" (ppr id) - ; let tidy_type_env = mkFinalTypeEnv env_tc final_ids tidy_dfun_ids = map lookup_dfun_id insts_tc - ; let tidy_details = ModDetails { md_types = tidy_type_env, - md_rules = tidy_rules, - md_insts = tidy_dfun_ids, - md_binds = tidy_binds } + ; let tidy_result = mod_impl { mg_types = tidy_type_env, + mg_rules = tidy_rules, + mg_insts = tidy_dfun_ids, + mg_binds = tidy_binds } ; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds ; dumpIfSet_core dflags Opt_D_dump_simpl "Tidy Core Rules" (pprIdRules tidy_rules) - ; return (pcs', tidy_details) + ; return tidy_result } tidyCoreExpr :: CoreExpr -> IO CoreExpr @@ -209,28 +205,54 @@ tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr) %************************************************************************ \begin{code} -mkFinalTypeEnv :: TypeEnv -- From typechecker - -> [Id] -- Final Ids +mkFinalTypeEnv :: Bool -- Omit interface pragmas + -> TypeEnv -- From typechecker + -> [CoreBind] -- Final Ids -> TypeEnv -mkFinalTypeEnv type_env final_ids - = extendTypeEnvList (filterNameEnv keep_it type_env) - (map AnId final_ids) +-- The competed type environment is gotten from +-- 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 +-- +-- However, we do keep things like constructors, which should not appear +-- in interface files, because they are needed by importing modules when +-- using the compilation manager + +mkFinalTypeEnv omit_iface_prags type_env tidy_binds + = extendTypeEnvList (filterNameEnv keep_it type_env) final_ids where - -- The competed type environment is gotten from - -- 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 Global 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 + final_ids = [ AnId (strip_id_info id) + | bind <- tidy_binds, + id <- bindersOf bind, + isExternalName (idName id)] + + strip_id_info id + | omit_iface_prags = id `setIdInfo` vanillaIdInfo + | otherwise = id + -- If the interface file has no pragma info then discard all + -- info right here. -- - -- However, we do keep things like constructors, which should not appear - -- in interface files, because they are needed by importing modules when - -- using the compilation manager + -- This is not so important for *this* module, but it's + -- vital 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 + -- + -- This IdInfo will live long-term in the Id => vanillaIdInfo makes + -- a conservative assumption about Caf-hood + -- + -- We're not worried about occurrences of these Ids in unfoldings, + -- because in OmitInterfacePragmas mode we're stripping all the + -- unfoldings anyway. -- We keep implicit Ids, because they won't appear -- in the bindings from which final_ids are derived! @@ -239,15 +261,16 @@ mkFinalTypeEnv type_env final_ids \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) where @@ -277,11 +300,12 @@ findExternalRules binds orphan_rules ext_ids %************************************************************************ \begin{code} -findExternalSet :: [CoreBind] -> [IdCoreRule] +findExternalSet :: Bool -- omit interface pragmas + -> [CoreBind] -> [IdCoreRule] -> IdEnv Bool -- In domain => external -- Range = True <=> show unfolding -- Step 1 from the notes above -findExternalSet binds orphan_rules +findExternalSet omit_iface_prags binds orphan_rules = foldr find init_needed binds where orphan_rule_ids :: IdSet @@ -295,7 +319,7 @@ findExternalSet binds orphan_rules -- (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 @@ -305,7 +329,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 @@ -313,10 +337,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 @@ -324,10 +348,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) @@ -349,8 +373,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 @@ -369,10 +392,8 @@ addExternal (id,rhs) needed \begin{code} -type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var) - -- TopTidyEnv: when tidying we need to know --- * ns: The NameSupply, 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 @@ -384,82 +405,151 @@ type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var) -- are 'used' -- -- * subst_env: A Var->Var mapping that substitutes the new Var for the old -\end{code} +tidyTopBinds :: 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]) +tidyTopBinds mod nc_var ext_ids tidy_env [] + = return (tidy_env, []) -\begin{code} +tidyTopBinds mod nc_var ext_ids tidy_env (b:bs) + = do { (tidy_env1, b') <- tidyTopBind mod nc_var ext_ids tidy_env b + ; (tidy_env2, bs') <- tidyTopBinds mod nc_var ext_ids tidy_env1 bs + ; return (tidy_env2, b':bs') } + +------------------------ tidyTopBind :: Module - -> IdEnv Bool -- Domain = Ids that should be external + -> IORef NameCache -- For allocating new unique names + -> IdEnv Bool -- Domain = Ids that should be external -- True <=> their unfolding is external too - -> CgInfoEnv - -> TopTidyEnv -> CoreBind - -> (TopTidyEnv, CoreBind) - -tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs) - = ((orig,occ,subst) , NonRec bndr' rhs') + -> TidyEnv -> CoreBind + -> IO (TidyEnv, CoreBind) + +tidyTopBind 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 cg_info_env - rec_tidy_env rhs rhs' top_tidy_env bndr - rec_tidy_env = (occ,subst) - rhs' = tidyExpr rec_tidy_env rhs - -tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs) - = (final_env, Rec prs') + caf_info = hasCafRefs subst1 (idArity bndr) rhs + +tidyTopBind 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) + bndrs = map fst prs - do_one top_tidy_env (bndr,rhs) - = ((orig,occ,subst), (bndr',rhs')) - where - ((orig,occ,subst), bndr') - = tidyTopBinder mod ext_ids cg_info_env - rec_tidy_env rhs rhs' top_tidy_env bndr - - rhs' = tidyExpr rec_tidy_env rhs - -tidyTopBinder :: Module -> IdEnv Bool -> CgInfoEnv - -> 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 cg_info_env rec_tidy_env rhs tidy_rhs - env@(ns2, occ_env2, subst_env2) id + -- 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) + | (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 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 - - = ((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 - (lookupCgInfo cg_info_env name') - - 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 @@ -471,7 +561,6 @@ tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs tidy_rhs arity = exprArity rhs - -- tidyTopIdInfo creates the final IdInfo for top-level -- binders. There are two delicate pieces: -- @@ -479,44 +568,24 @@ tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs tidy_rhs -- Indeed, CorePrep must eta expand where necessary to make -- the manifest arity equal to the claimed arity. -- --- * CAF info, which comes from the CoreToStg pass via a knot. --- The CAF info will not be looked at by the downstream stuff: --- it *generates* it, and knot-ties it back. It will only be --- looked at by (a) MkIface when generating an interface file --- (b) In GHCi, importing modules --- Nevertheless, we add the info here so that it propagates to all +-- * 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. --- --- An alterative would be to do a second pass over the unfoldings --- of Ids, and rules, right at the top, but that would be a pain. - -tidyTopIdInfo tidy_env is_external idinfo unfold_info arity cg_info - | opt_OmitInterfacePragmas -- If the interface file has no pragma info - = hasCafIdInfo -- then discard all info right here - -- This is not so important for *this* module, but it's - -- vital 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 - -- - -- This IdInfo will live long-term in the Id => need to make - -- conservative assumption about Caf-hood +-- 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 - -- Use vanillaIdInfo (whose CafInfo is a panic) because we - -- should not need the CafInfo + `setCafInfo` caf_info `setArityInfo` arity `setAllStrictnessInfo` newStrictnessInfo idinfo | otherwise -- Externally-visible Ids get the whole lot = vanillaIdInfo - `setCgInfo` cg_info + `setCafInfo` caf_info `setArityInfo` arity `setAllStrictnessInfo` newStrictnessInfo idinfo `setInlinePragInfo` inlinePragInfo idinfo @@ -525,52 +594,6 @@ tidyTopIdInfo tidy_env is_external idinfo unfold_info arity cg_info -- NB: we throw away the Rules -- 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 lookupFM ns_names key 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 - - (occ_env', occ') = tidyOccName occ_env (nameOccName name) - key = (moduleName mod, occ') - ns_names = nsNames ns - ns_uniqs = nsUniqs ns - (us1, us2) = splitUniqSupply ns_uniqs - uniq = uniqFromSupply us1 - loc = nameSrcLoc name - - new_local_name = mkInternalName uniq occ' loc - new_external_name = mkExternalName uniq mod occ' loc - - ns_w_local = ns { nsUniqs = us2 } - ns_w_global = ns { nsUniqs = us2, nsNames = addToFM ns_names key new_external_name } ------------ Worker -------------- @@ -578,4 +601,64 @@ tidyWorker tidy_env (HasWorker work_id wrap_arity) = HasWorker (tidyVarOcc tidy_env work_id) wrap_arity tidyWorker tidy_env other = NoWorker -\end{code} \ No newline at end of file +\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 :: VarEnv Var -> Arity -> CoreExpr -> CafInfo +hasCafRefs p arity expr + | is_caf || mentions_cafs = MayHaveCafRefs + | otherwise = NoCafRefs + where + mentions_cafs = isFastTrue (cafRefs p expr) + is_caf = not (arity > 0 || rhsIsStatic 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 +-- gaw 2004 +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}