#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}
[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.
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
-- 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
-- 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
%************************************************************************
\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!
\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
%************************************************************************
\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
-- (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
| 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
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
-- "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)
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
\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
-- 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
arity = exprArity rhs
-
-- tidyTopIdInfo creates the final IdInfo for top-level
-- binders. There are two delicate pieces:
--
-- 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
-- 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 --------------
= 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
+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}
projects / ghc-hetmet.git / blobdiff