import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules )
import PprCore ( pprIdRules )
import CoreLint ( showPass, endPass )
-import CoreUtils ( exprArity )
+import CoreUtils ( exprArity, hasNoRedexes )
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,
+import BasicTypes ( Arity, isNeverActive )
+import Name ( getOccName, nameOccName, mkInternalName,
localiseName, isExternalName, nameSrcLoc
)
-import NameEnv ( filterNameEnv )
+import RnEnv ( lookupOrigNameCache, newExternalName )
+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 ( PersistentCompilerState( pcs_nc ),
+ NameCache( nsNames, 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 Util ( mapAccumL )
import Maybe ( isJust )
import Outputable
+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 PersistentCompilerState 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
+tidyCorePgm :: DynFlags
-> 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 })
+ -> ModGuts
+ -> IO (PersistentCompilerState, ModGuts)
+
+tidyCorePgm dflags pcs
+ 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"
; let ext_ids = findExternalSet binds_in orphans_in
-- 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
-
+ ; let orig_ns = pcs_nc pcs
init_tidy_env = (orig_ns, initTidyOccEnv avoids, emptyVarEnv)
avoids = [getOccName name | bndr <- typeEnvIds env_tc,
let name = idName bndr,
-- 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)
+ = mapAccumL (tidyTopBind mod ext_ids)
init_tidy_env binds_in
; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
- ; let prs' = prs { prsOrig = orig_ns' }
- pcs' = pcs { pcs_PRS = prs' }
+ ; let pcs' = pcs { pcs_nc = orig_ns' }
- ; let final_ids = [ id
- | bind <- tidy_binds
- , id <- bindersOf bind
- , isExternalName (idName id)]
+ ; let tidy_type_env = mkFinalTypeEnv 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 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 (pcs', tidy_result)
}
tidyCoreExpr :: CoreExpr -> IO CoreExpr
%************************************************************************
\begin{code}
-mkFinalTypeEnv :: TypeEnv -- From typechecker
- -> [Id] -- Final Ids
+mkFinalTypeEnv :: 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 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
+--
+-- 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 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
+ | opt_OmitInterfacePragmas = 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!
\begin{code}
-type TopTidyEnv = (NameSupply, TidyOccEnv, VarEnv Var)
+type TopTidyEnv = (NameCache, TidyOccEnv, VarEnv Var)
-- TopTidyEnv: when tidying we need to know
--- * ns: The NameSupply, containing a unique supply and any pre-ordained Names.
+-- * ns: 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
tidyTopBind :: Module
-> 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)
+tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (NonRec bndr rhs)
= ((orig,occ,subst) , NonRec bndr' rhs')
where
((orig,occ,subst), bndr')
- = tidyTopBinder mod ext_ids cg_info_env
+ = 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 cg_info_env top_tidy_env (Rec prs)
+tidyTopBind mod ext_ids top_tidy_env@(_,_,subst1) (Rec prs)
= (final_env, Rec prs')
where
(final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
= ((orig,occ,subst), (bndr',rhs'))
where
((orig,occ,subst), bndr')
- = tidyTopBinder mod ext_ids cg_info_env
+ = tidyTopBinder mod ext_ids caf_info
rec_tidy_env rhs rhs' top_tidy_env bndr
rhs' = tidyExpr rec_tidy_env rhs
-tidyTopBinder :: Module -> IdEnv Bool -> CgInfoEnv
+ -- 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
+
+tidyTopBinder :: Module -> IdEnv Bool -> CafInfo
-> TidyEnv -- The TidyEnv is used to tidy the IdInfo
-> CoreExpr -- RHS *before* tidying
-> CoreExpr -- RHS *after* tidying
-> 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
+tidyTopBinder mod ext_ids caf_info rec_tidy_env rhs tidy_rhs
env@(ns2, occ_env2, subst_env2) id
-- This function is the heart of Step 2
-- The rec_tidy_env is the one to use for the IdInfo
-- in the IdInfo of one early in the group
-- The rhs is already tidied
-
- = ((orig_env', occ_env', subst_env'), id')
+
+ = ASSERT(isLocalId id) -- "all Ids defined in this module are local
+ -- until the CoreTidy phase" --GHC comentary
+ ((orig_env', occ_env', subst_env'), id')
where
(orig_env', occ_env', name') = tidyTopName mod ns2 occ_env2
is_external
ty' = tidyTopType (idType id)
idinfo = tidyTopIdInfo rec_tidy_env is_external
(idInfo id) unfold_info arity
- (lookupCgInfo cg_info_env name')
+ caf_info
id' = mkVanillaGlobal name' ty' idinfo
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
-- 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
+ | 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
global = isExternalName name
local = not global
internal = not external
+ loc = nameSrcLoc name
(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
+ (us1, us2) = splitUniqSupply (nsUniqs ns)
uniq = uniqFromSupply us1
- loc = nameSrcLoc name
-
- new_local_name = mkInternalName uniq occ' loc
- new_external_name = mkExternalName uniq mod occ' loc
-
+ new_local_name = mkInternalName uniq occ' loc
ns_w_local = ns { nsUniqs = us2 }
- ns_w_global = ns { nsUniqs = us2, nsNames = addToFM ns_names key new_external_name }
+
+ (ns_w_global, new_external_name) = newExternalName ns mod occ' loc
------------ 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 || hasNoRedexes 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 hasNoRedexes 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