A round of space-leak fixing.
- re-instate zapping of the PersistentCompilerState at various
points during the compilation cycle in HscMain. This affects
one-shot compilation only, since in this mode the information
collected in the PCS is not required after creating the final
interface file.
- Unravel the recursive dependency between MkIface and
CoreTidy/CoreToStg. Previously the CafInfo for each binding was
calculated by CoreToStg, and fed back into the IdInfo of the Ids
generated by CoreTidy (an earlier pass). MkIface then took this
IdInfo and the bindings from CoreTidy to generate the interface;
but it couldn't do this until *after* CoreToStg, because the CafInfo
hadn't been calculated yet. The result was that the CoreTidy
output lived until after CoreToStg, and at the same time as the
CorePrep and STG syntax, which is wasted space, not to mention
the complexity and general ugliness in HscMain.
So now we calculate CafInfo directly in CoreTidy. The downside is
that we have to predict what CorePrep is going to do to the
bindings so we can tell what will turn into a CAF later, but it's
no worse than before (it turned out that we were doing this
prediction before in CoreToStg anyhow).
- The typechecker lazilly typechecks unfoldings. It turns out that
this is a good idea from a performance perspective, but it also
means that it must hang on to all the information it needs to
do the typechecking. Previously this meant holding on to the
whole of the typechecker's environment, which includes all sorts
of stuff which isn't necessary to typecheck unfoldings. By paring
down the environment captured by the lazy unfoldings, we can
save quite a bit of space in the phases after typechecking.
setIdNewStrictness, zapIdNewStrictness,
setIdWorkerInfo,
setIdSpecialisation,
- setIdCgInfo,
+ setIdCafInfo,
setIdOccInfo,
#ifdef OLD_STRICTNESS
idWorkerInfo,
idUnfolding,
idSpecialisation, idCoreRules,
- idCgInfo,
idCafInfo,
idLBVarInfo,
idOccInfo,
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
---------------------------------
- -- CG INFO
-idCgInfo :: Id -> CgInfo
-#ifdef OLD_STRICTNESS
-idCgInfo id = case cgInfo (idInfo id) of
- NoCgInfo -> pprPanic "idCgInfo" (ppr id)
- info -> info
-#else
-idCgInfo id = cgInfo (idInfo id)
-#endif
-
-setIdCgInfo :: Id -> CgInfo -> Id
-setIdCgInfo id cg_info = modifyIdInfo (`setCgInfo` cg_info) id
-
- ---------------------------------
-- CAF INFO
idCafInfo :: Id -> CafInfo
#ifdef OLD_STRICTNESS
NoCgInfo -> pprPanic "idCafInfo" (ppr id)
info -> cgCafInfo info
#else
-idCafInfo id = cgCafInfo (idCgInfo id)
+idCafInfo id = cafInfo (idInfo id)
#endif
+
+setIdCafInfo :: Id -> CafInfo -> Id
+setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
+
---------------------------------
-- CPR INFO
#ifdef OLD_STRICTNESS
GlobalIdDetails(..), notGlobalId, -- Not abstract
IdInfo, -- Abstract
- vanillaIdInfo, noCafIdInfo, hasCafIdInfo,
+ vanillaIdInfo, noCafIdInfo,
seqIdInfo, megaSeqIdInfo,
-- Zapping
-- Specialisation
specInfo, setSpecInfo,
- -- CG info
- CgInfo(..), cgInfo, setCgInfo, pprCgInfo,
- cgCafInfo, vanillaCgInfo,
- CgInfoEnv, lookupCgInfo,
-
-- CAF info
- CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs,
+ CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs,
-- Lambda-bound variable info
LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo
import CoreSyn
-import Type ( Type )
import TyCon ( TyCon )
import Class ( Class )
import PrimOp ( PrimOp )
-import NameEnv ( NameEnv, lookupNameEnv )
+#ifdef OLD_STRICTNESS
import Name ( Name )
+#endif
import Var ( Id )
import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker,
InsideLam, insideLam, notInsideLam,
`setWorkerInfo`,
`setLBVarInfo`,
`setOccInfo`,
- `setCgInfo`,
`setCafInfo`,
`setNewStrictnessInfo`,
`setAllStrictnessInfo`,
#endif
workerInfo :: WorkerInfo, -- Pointer to Worker Function
unfoldingInfo :: Unfolding, -- Its unfolding
- cgInfo :: CgInfo, -- Code generator info (arity, CAF info)
+ cafInfo :: CafInfo, -- CAF info
lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable
inlinePragInfo :: InlinePragInfo, -- Inline pragma
occInfo :: OccInfo, -- How it occurs
seqCpr (cprInfo info) `seq`
#endif
--- CgInfo is involved in a loop, so we have to be careful not to seq it
--- too early.
--- seqCg (cgInfo info) `seq`
- seqLBVar (lbvarInfo info) `seq`
+ seqCaf (cafInfo info) `seq`
+ seqLBVar (lbvarInfo info) `seq`
seqOccInfo (occInfo info)
\end{code}
setCprInfo info cp = info { cprInfo = cp }
#endif
-setArityInfo info ar = info { arityInfo = ar }
-setCgInfo info cg = info { cgInfo = cg }
+setArityInfo info ar = info { arityInfo = ar }
+setCafInfo info caf = info { cafInfo = caf }
setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb }
vanillaIdInfo :: IdInfo
vanillaIdInfo
= IdInfo {
- cgInfo = noCgInfo,
+ cafInfo = vanillaCafInfo,
arityInfo = unknownArity,
#ifdef OLD_STRICTNESS
cprInfo = NoCPRInfo,
newStrictnessInfo = Nothing
}
-hasCafIdInfo = vanillaIdInfo `setCgInfo` CgInfo MayHaveCafRefs
-noCafIdInfo = vanillaIdInfo `setCgInfo` CgInfo NoCafRefs
+noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs
-- Used for built-in type Ids in MkId.
- -- These must have a valid CgInfo set, so you can't
- -- use vanillaIdInfo!
\end{code}
%* *
%************************************************************************
-CgInfo encapsulates calling-convention information produced by the code
-generator. It is pasted into the IdInfo of each emitted Id by CoreTidy,
-but only as a thunk --- the information is only actually produced further
-downstream, by the code generator.
-
\begin{code}
-#ifndef OLD_STRICTNESS
-newtype CgInfo = CgInfo CafInfo -- We are back to only having CafRefs in CgInfo
-noCgInfo = panic "NoCgInfo!"
-#else
-data CgInfo = CgInfo CafInfo
- | NoCgInfo -- In debug mode we don't want a black hole here
- -- See Id.idCgInfo
- -- noCgInfo is used for local Ids, which shouldn't need any CgInfo
-noCgInfo = NoCgInfo
-#endif
-
-cgCafInfo (CgInfo caf_info) = caf_info
-
-setCafInfo info caf_info = info `setCgInfo` CgInfo caf_info
-
-seqCg c = c `seq` () -- fields are strict anyhow
-
-vanillaCgInfo = CgInfo MayHaveCafRefs -- Definitely safe
-
-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs).
data CafInfo
| NoCafRefs -- A function or static constructor
-- that refers to no CAFs.
+vanillaCafInfo = MayHaveCafRefs -- Definitely safe
+
mayHaveCafRefs MayHaveCafRefs = True
mayHaveCafRefs _ = False
seqCaf c = c `seq` ()
-pprCgInfo (CgInfo caf_info) = ppCafInfo caf_info
-
-ppArity 0 = empty
-ppArity n = hsep [ptext SLIT("__A"), int n]
-
-ppCafInfo NoCafRefs = ptext SLIT("__C")
+ppCafInfo NoCafRefs = ptext SLIT("NoCafRefs")
ppCafInfo MayHaveCafRefs = empty
\end{code}
-\begin{code}
-type CgInfoEnv = NameEnv CgInfo
-
-lookupCgInfo :: NameEnv CgInfo -> Name -> CgInfo
-lookupCgInfo env n = case lookupNameEnv env n of
- Just info -> info
- Nothing -> pprTrace "Urk! Not in CgInfo env" (ppr n) vanillaCgInfo
-\end{code}
-
-
%************************************************************************
%* *
\subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@}
mkTemplateLocals, mkTemplateLocalsNum, setIdLocalExported,
mkTemplateLocal, idNewStrictness, idName
)
-import IdInfo ( IdInfo, noCafIdInfo, hasCafIdInfo,
- setUnfoldingInfo,
+import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo,
setArityInfo, setSpecInfo, setCafInfo,
- setAllStrictnessInfo,
+ setAllStrictnessInfo, vanillaIdInfo,
GlobalIdDetails(..), CafInfo(..)
)
import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
pc_bottoming_Id name ty
= pcMiscPrelId name ty bottoming_info
where
- bottoming_info = hasCafIdInfo `setAllStrictnessInfo` Just strict_sig
+ bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig
-- Do *not* mark them as NoCafRefs, because they can indeed have
-- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
-- which has some CAFs
import ClosureInfo ( mkClosureLFInfo )
import CmdLineOpts ( DynFlags, DynFlag(..),
opt_SccProfilingOn, opt_EnsureSplittableC )
-import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..),
+import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..), TypeEnv,
typeEnvTyCons )
import CostCentre ( CollectedCCs )
import Id ( Id, idName, setIdName )
import OccName ( mkLocalOcc )
import PrimRep ( PrimRep(..) )
import TyCon ( isDataTyCon )
+import Module ( Module )
import BasicTypes ( TopLevelFlag(..) )
import UniqSupply ( mkSplitUniqSupply )
import ErrUtils ( dumpIfSet_dyn, showPass )
\begin{code}
codeGen :: DynFlags
- -> ModGuts
+ -> Module
+ -> TypeEnv
+ -> ForeignStubs
+ -> [Module] -- directly-imported modules
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[Id])] -- Bindings to convert, with SRTs
-> IO AbstractC -- Output
-codeGen dflags
- mod_impl@(ModGuts { mg_module = mod_name, mg_types = type_env })
+codeGen dflags this_mod type_env foreign_stubs imported_mods
cost_centre_info stg_binds
= do
showPass dflags "CodeGen"
let
tycons = typeEnvTyCons type_env
data_tycons = filter isDataTyCon tycons
- cinfo = MkCompInfo mod_name
+
+ mapM_ (\x -> seq x (return ())) data_tycons
+
+ let
+
+ cinfo = MkCompInfo this_mod
datatype_stuff = genStaticConBits cinfo data_tycons
code_stuff = initC cinfo (mapCs cgTopBinding stg_binds)
- init_stuff = mkModuleInit way cost_centre_info mod_impl
+ init_stuff = mkModuleInit way cost_centre_info this_mod
+ foreign_stubs imported_mods
abstractC = mkAbstractCs [ maybeSplitCode,
init_stuff,
mkModuleInit
:: String -- the "way"
-> CollectedCCs -- cost centre info
- -> ModGuts
+ -> Module
+ -> ForeignStubs
+ -> [Module]
-> AbstractC
-mkModuleInit way cost_centre_info
- (ModGuts { mg_module = mod,
- mg_foreign = for_stubs,
- mg_dir_imps = imported_modules })
+mkModuleInit way cost_centre_info this_mod foreign_stubs imported_mods
= let
(cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
register_foreign_exports
- = case for_stubs of
+ = case foreign_stubs of
NoStubs -> []
ForeignStubs _ _ _ fe_bndrs -> map mk_export_register fe_bndrs
CLbl (mkModuleInitLabel mod way) AddrRep
]
- register_mod_imports = map mk_import_register imported_modules
+ register_mod_imports = map mk_import_register imported_mods
in
mkAbstractCs [
cc_decls,
- CModuleInitBlock (mkPlainModuleInitLabel mod)
- (mkModuleInitLabel mod way)
+ CModuleInitBlock (mkPlainModuleInitLabel this_mod)
+ (mkModuleInitLabel this_mod way)
(mkAbstractCs (register_foreign_exports ++
cc_regs :
register_mod_imports))
isLocalId, hasNoBinding, idNewStrictness,
idUnfolding, isDataConWorkId_maybe
)
-import HscTypes ( ModGuts(..), ModGuts, typeEnvElts )
+import HscTypes ( ModGuts(..), ModGuts, TypeEnv, typeEnvElts )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
-- -----------------------------------------------------------------------------
\begin{code}
-corePrepPgm :: DynFlags -> ModGuts -> IO ModGuts
-corePrepPgm dflags mod_impl
+corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind]
+corePrepPgm dflags binds types
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
- let implicit_binds = mkImplicitBinds (mg_types mod_impl)
+ let implicit_binds = mkImplicitBinds types
-- NB: we must feed mkImplicitBinds through corePrep too
-- so that they are suitably cloned and eta-expanded
binds_out = initUs_ us (
- corePrepTopBinds (mg_binds mod_impl) `thenUs` \ floats1 ->
+ corePrepTopBinds binds `thenUs` \ floats1 ->
corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
returnUs (deFloatTop (floats1 `appOL` floats2))
)
endPass dflags "CorePrep" Opt_D_dump_prep binds_out
- return (mod_impl { mg_binds = binds_out })
+ return binds_out
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
corePrepExpr dflags expr
-- a = g y
-- x* = f a
-- And then x will actually end up case-bound
+--
+-- What happens to the CafInfo on the floated bindings? By
+-- default, all the CafInfos will be set to MayHaveCafRefs,
+-- which is safe.
+--
+-- This might be pessimistic, because eg. s1 & s2
+-- might not refer to any CAFs and the GC will end up doing
+-- more traversal than is necessary, but it's still better
+-- than not floating the bindings at all, because then
+-- the GC would have to traverse the structure in the heap
+-- instead. Given this, we decided not to try to get
+-- the CafInfo on the floated bindings correct, because
+-- it looks difficult.
--------------------------------
corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
import CoreSyn
import CoreUtils ( exprArity )
import PprCore ( pprIdRules )
-import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique, idType, idCoreRules )
-import IdInfo ( vanillaIdInfo, setArityInfo,
+import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique,
+ idType, idCoreRules )
+import IdInfo ( setArityInfo, noCafIdInfo,
newStrictnessInfo, setAllStrictnessInfo,
newDemandInfo, setNewDemandInfo )
import Type ( tidyType, tidyTyVarBndr )
-> (TidyEnv, CoreBind)
tidyBind env (NonRec bndr rhs)
- = tidyLetBndr env (bndr,rhs) =: \ (env', bndr') ->
+ = tidyLetBndr env (bndr,rhs) =: \ (env', bndr') ->
(env', NonRec bndr' (tidyExpr env' rhs))
tidyBind env (Rec prs)
- = mapAccumL tidyLetBndr env prs =: \ (env', bndrs') ->
+ = mapAccumL tidyLetBndr env prs =: \ (env', bndrs') ->
map (tidyExpr env') (map snd prs) =: \ rhss' ->
(env', Rec (zip bndrs' rhss'))
where
((tidy_env,var_env), new_id) = tidyIdBndr env id
- -- We need to keep around any interesting strictness and demand info
- -- because later on we may need to use it when converting to A-normal form.
+ -- We need to keep around any interesting strictness and
+ -- demand info because later on we may need to use it when
+ -- converting to A-normal form.
-- eg.
-- f (g x), where f is strict in its argument, will be converted
-- into case (g x) of z -> f z by CorePrep, but only if f still
-- CorePrep to turn the let into a case.
--
-- Similarly arity info for eta expansion in CorePrep
+ --
+ -- CafInfo is NoCafRefs, because this is not a top-level Id.
+ --
final_id = new_id `setIdInfo` new_info
idinfo = idInfo id
- new_info = vanillaIdInfo
+ new_info = noCafIdInfo -- NB. no CAF refs!
`setArityInfo` exprArity rhs
`setAllStrictnessInfo` newStrictnessInfo idinfo
`setNewDemandInfo` newDemandInfo idinfo
-- The SrcLoc isn't important now,
-- though we could extract it from the Id
--
- -- All nested Ids now have the same IdInfo, namely none,
+ -- All nested Ids now have the same IdInfo, namely noCafIdInfo,
-- which should save some space.
-- But note that tidyLetBndr puts some of it back.
ty' = tidyType env (idType id)
id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc
+ `setIdInfo` noCafIdInfo
var_env' = extendVarEnv var_env id id'
in
((tidy_env', var_env'), id')
\begin{code}
m =: k = m `seq` k m
\end{code}
-
-
hashExpr,
-- Equality
- cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
+ cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg,
+
+ -- CAF info
+ hasCafRefs, rhsIsNonUpd,
+
+ -- Cross-DLL references
+ isCrossDllConApp,
) where
#include "HsVersions.h"
import PprCore ( pprCoreExpr )
import Var ( Var, isId, isTyVar )
import VarEnv
-import Name ( hashName )
-import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit )
-import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon )
+import Name ( hashName, isDllName )
+import Literal ( hashLiteral, literalType, litIsDupable,
+ litIsTrivial, isZeroLit, isLitLitLit )
+import DataCon ( DataCon, dataConRepArity, dataConArgTys,
+ isExistentialDataCon, dataConTyCon, dataConName )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
- mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
- isDataConWorkId_maybe, mkSysLocal, isDataConWorkId, isBottomingId
+ mkWildId, idArity, idName, idUnfolding, idInfo,
+ isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
+ isDataConWorkId, isBottomingId, idCafInfo
)
-import IdInfo ( GlobalIdDetails(..),
- megaSeqIdInfo )
+import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo,
+ CafInfo(..), mayHaveCafRefs )
import NewDemand ( appIsBottom )
-import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
+import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
+ splitFunTy,
applyTys, isUnLiftedType, seqType, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
splitTyConApp_maybe, eqType, funResultTy, applyTy,
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast )
import TysPrim ( statePrimTyCon )
+import FastTypes hiding ( fastOr )
\end{code}
hashId :: Id -> Int
hashId id = hashName (idName id)
\end{code}
+
+%************************************************************************
+%* *
+\subsection{Cross-DLL references}
+%* *
+%************************************************************************
+
+Top-level constructor applications can usually be allocated
+statically, but they can't if
+ a) the constructor, or any of the arguments, come from another DLL
+ b) any of the arguments are LitLits
+(because we can't refer to static labels in other DLLs).
+
+If this happens we simply make the RHS into an updatable thunk,
+and 'exectute' it rather than allocating it statically.
+
+We also catch lit-lit arguments here, because those cannot be used in
+static constructors either. (litlits are deprecated, so I'm not going
+to bother cleaning up this infelicity --SDM).
+
+\begin{code}
+isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
+isCrossDllConApp con args =
+ isDllName (dataConName con) || any isCrossDllArg args
+
+isCrossDllArg :: CoreExpr -> Bool
+-- True if somewhere in the expression there's a cross-DLL reference
+isCrossDllArg (Type _) = False
+isCrossDllArg (Var v) = isDllName (idName v)
+isCrossDllArg (Note _ e) = isCrossDllArg e
+isCrossDllArg (Lit lit) = isLitLitLit lit
+isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2
+ -- must be a type app
+isCrossDllArg (Lam v e) = isCrossDllArg e
+ -- must be a type lam
+\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 :: (Var -> Bool) -> 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 || rhsIsNonUpd 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.
+
+cafRefs p (Var id)
+ | isId id && p id = fastBool (mayHaveCafRefs (idCafInfo id))
+ | otherwise = 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))
+
+
+rhsIsNonUpd :: CoreExpr -> Bool
+-- True => Value-lambda, saturated constructor
+-- This is a bit like CoreUtils.exprIsValue, with the following differences:
+-- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
+--
+-- b) (C x xs), where C is a contructors is updatable if the application is
+-- dynamic
+--
+-- c) don't look through unfolding of f in (f x).
+--
+-- When opt_RuntimeTypes is on, we keep type lambdas and treat
+-- them as making the RHS re-entrant (non-updatable).
+--
+rhsIsNonUpd (Lam b e) = isRuntimeVar b || rhsIsNonUpd e
+rhsIsNonUpd (Note (SCC _) e) = False
+rhsIsNonUpd (Note _ e) = rhsIsNonUpd e
+rhsIsNonUpd other_expr
+ = go other_expr 0 []
+ where
+ go (Var f) n_args args = idAppIsNonUpd f n_args args
+
+ go (App f a) n_args args
+ | isTypeArg a = go f n_args args
+ | otherwise = go f (n_args + 1) (a:args)
+
+ go (Note (SCC _) f) n_args args = False
+ go (Note _ f) n_args args = go f n_args args
+
+ go other n_args args = False
+
+idAppIsNonUpd :: Id -> Int -> [CoreExpr] -> Bool
+idAppIsNonUpd id n_val_args args
+ -- saturated constructors are not updatable
+ | Just con <- isDataConWorkId_maybe id,
+ n_val_args == dataConRepArity con,
+ not (isCrossDllConApp con args),
+ all exprIsAtom args
+ = True
+ -- NB. args sometimes not atomic. eg.
+ -- x = D# (1.0## /## 2.0##)
+ -- can't float because /## can fail.
+
+ | otherwise = False
+ -- Historical note: we used to make partial applications
+ -- non-updatable, so they behaved just like PAPs, but this
+ -- doesn't work too well with eval/apply so it is disabled
+ -- now.
+\end{code}
arityInfo, ppArityInfo,
specInfo, pprNewStrictness,
workerInfo, ppWorkerInfo,
- newStrictnessInfo,
+ newStrictnessInfo, cafInfo, ppCafInfo,
#ifdef OLD_STRICTNESS
cprInfo, ppCprInfo,
strictnessInfo, ppStrictnessInfo,
ppIdInfo b info
= hsep [ ppArityInfo a,
ppWorkerInfo (workerInfo info),
+ ppCafInfo (cafInfo info),
#ifdef OLD_STRICTNESS
ppStrictnessInfo s,
ppCprInfo m,
import Id
import FiniteMap
import ForeignCall ( ForeignCall(..), CCallTarget(..), CCallSpec(..) )
-import HscTypes ( ModGuts(..), ModGuts, typeEnvTyCons, typeEnvClasses )
+import HscTypes ( ModGuts(..), ModGuts,
+ TypeEnv, typeEnvTyCons, typeEnvClasses )
import CoreUtils ( exprType )
import CoreSyn
import PprCore ( pprCoreExpr )
-- Generating byte code for a complete module
byteCodeGen :: DynFlags
- -> ModGuts
+ -> [CoreBind]
+ -> TypeEnv
-> IO CompiledByteCode
-byteCodeGen dflags (ModGuts { mg_binds = binds, mg_types = type_env })
+byteCodeGen dflags binds type_env
= do showPass dflags "ByteCodeGen"
let local_tycons = typeEnvTyCons type_env
local_classes = typeEnvClasses type_env
import ErrUtils ( dumpIfSet_dyn, showPass )
import Outputable
import Pretty ( Mode(..), printDoc )
-import CmdLineOpts ( DynFlags, HscLang(..), dopt_OutName )
+import Module ( Module )
+
import Monad ( when )
import IO
\end{code}
\begin{code}
codeOutput :: DynFlags
- -> ModGuts
+ -> Module
+ -> ForeignStubs
+ -> Dependencies
-> AbstractC -- Compiled abstract C
-> IO (Bool{-stub_h_exists-}, Bool{-stub_c_exists-})
-codeOutput dflags
- (ModGuts {mg_module = mod_name,
- mg_types = type_env,
- mg_foreign = foreign_stubs,
- mg_deps = deps,
- mg_binds = core_binds})
- flat_abstractC
+codeOutput dflags this_mod foreign_stubs deps flat_abstractC
=
-- You can have C (c_output) or assembly-language (ncg_output),
-- but not both. [Allowing for both gives a space leak on
import Type ( Type )
import PrelNames ( iNTERACTIVE )
import StringBuffer ( stringToStringBuffer )
+import SrcLoc ( noSrcLoc )
import Name ( Name )
import CoreLint ( lintUnfolding )
#endif
import HsSyn
import RdrName ( nameRdrName )
-import Id ( idName )
-import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) )
import StringBuffer ( hGetStringBuffer, freeStringBuffer )
import Parser
import Lex ( ParseResult(..), ExtFlags(..), mkPState )
-import SrcLoc ( mkSrcLoc, noSrcLoc )
+import SrcLoc ( mkSrcLoc )
import TcRnDriver ( checkOldIface, tcRnModule, tcRnExtCore, tcRnIface )
import RnEnv ( extendOrigNameCache )
-import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, knownKeyNames )
import PrelRules ( builtinRules )
import MkIface ( mkIface )
-import InstEnv ( emptyInstEnv )
import Desugar
import Flattening ( flatten )
import SimplCore
import Module ( emptyModuleEnv )
import CmdLineOpts
import DriverPhases ( isExtCore_file )
-import ErrUtils ( dumpIfSet_dyn, showPass, printError )
+import ErrUtils ( dumpIfSet_dyn, showPass )
import UniqSupply ( mkSplitUniqSupply )
import Bag ( consBag, emptyBag )
import ParserCoreUtils
import FiniteMap ( emptyFM )
import Name ( nameModule )
-import NameEnv ( emptyNameEnv, mkNameEnv )
+import NameEnv ( emptyNameEnv )
import NameSet ( emptyNameSet )
import Module ( Module, ModLocation(..), showModMsg )
import FastString
import Maybes ( expectJust )
-import DATA_IOREF ( newIORef, readIORef, writeIORef )
-import UNSAFE_IO ( unsafePerformIO )
-
import Monad ( when )
import Maybe ( isJust, fromJust )
import IO
; flat_result <- _scc_ "Flattening"
flatten hsc_env pcs_tc ds_result
- ; let pcs_middle = pcs_tc
-
-{- Again, omit this because it loses the usage info
- which is needed in mkIface. Maybe we should compute
- usage info earlier.
-
- ; pcs_middle
- <- _scc_ "pcs_middle"
- if one_shot then
- do init_pcs <- initPersistentCompilerState
- init_prs <- initPersistentRenamerState
- let
- rules = pcs_rules pcs_tc
- orig_tc = prsOrig (pcs_PRS pcs_tc)
- new_prs = init_prs{ prsOrig=orig_tc }
-
- orig_tc `seq` rules `seq` new_prs `seq`
- return init_pcs{ pcs_PRS = new_prs,
- pcs_rules = rules }
- else return pcs_tc
--}
-
--- Should we remove bits of flat_result at this point?
--- ; flat_result <- case flat_result of
--- ModResult { md_binds = binds } ->
--- return ModDetails { md_binds = binds,
--- md_rules = [],
--- md_types = emptyTypeEnv,
--- md_insts = [] }
+
+ ; let -- Rule-base accumulated from imported packages
+ pkg_rule_base = eps_rule_base (pcs_EPS pcs_tc)
+
+ -- In one-shot mode, ZAP the external package state at
+ -- this point, because we aren't going to need it from
+ -- now on. We keep the name cache, however, because
+ -- tidyCore needs it.
+ pcs_middle
+ | one_shot = pcs_tc{ pcs_EPS = error "pcs_EPS missing" }
+ | otherwise = pcs_tc
+
+ ; pkg_rule_base `seq` pcs_middle `seq` return ()
-- alive at this point:
-- pcs_middle
-- flat_result
+ -- pkg_rule_base
-------------------
-- SIMPLIFY
-------------------
; simpl_result <- _scc_ "Core2Core"
- core2core hsc_env pcs_middle flat_result
+ core2core hsc_env pkg_rule_base flat_result
-------------------
-- TIDY
-------------------
- ; cg_info_ref <- newIORef Nothing ;
- ; let cg_info :: CgInfoEnv
- cg_info = unsafePerformIO $ do {
- maybe_cg_env <- readIORef cg_info_ref ;
- case maybe_cg_env of
- Just env -> return env
- Nothing -> do { printError "Urk! Looked at CgInfo too early!";
- return emptyNameEnv } }
- -- cg_info_ref will be filled in just after restOfCodeGeneration
- -- Meanwhile, tidyCorePgm is careful not to look at cg_info!
-
; (pcs_simpl, tidy_result)
<- _scc_ "CoreTidy"
- tidyCorePgm dflags pcs_middle cg_info simpl_result
+ tidyCorePgm dflags pcs_middle simpl_result
--- Space-saving ploy doesn't work so well now
--- because mkIface needs the populated PIT to
--- generate usage info. Maybe we should re-visit this.
--- ; pcs_final <- if one_shot then initPersistentCompilerState
--- else return pcs_simpl
- ; let pcs_final = pcs_simpl
+ -- ZAP the persistent compiler state altogether now if we're
+ -- in one-shot mode, to save space.
+ ; pcs_final <- if one_shot then return (error "pcs_final missing")
+ else return pcs_simpl
+
+ ; emitExternalCore dflags tidy_result
-- Alive at this point:
-- tidy_result, pcs_final
-
- -------------------
- -- PREPARE FOR CODE GENERATION
- -- Do saturation and convert to A-normal form
- ; prepd_result <- _scc_ "CorePrep"
- corePrepPgm dflags tidy_result
-
- -------------------
- -- CONVERT TO STG and COMPLETE CODE GENERATION
- ; (stub_h_exists, stub_c_exists, maybe_bcos)
- <- hscBackEnd dflags cg_info_ref prepd_result
+ -- hsc_env
-------------------
-- BUILD THE NEW ModIface and ModDetails
-- This has to happen *after* code gen so that the back-end
-- info has been set. Not yet clear if it matters waiting
-- until after code output
- ; final_iface <- _scc_ "MkFinalIface"
+ ; new_iface <- _scc_ "MkFinalIface"
mkIface hsc_env location
maybe_checked_iface tidy_result
- ; let final_details = ModDetails { md_types = mg_types tidy_result,
+
+
+ -- Space leak reduction: throw away the new interface if
+ -- we're in one-shot mode; we won't be needing it any
+ -- more.
+ ; final_iface <-
+ if one_shot then return (error "no final iface")
+ else return new_iface
+
+ -- Build the final ModDetails (except in one-shot mode, where
+ -- we won't need this information after compilation).
+ ; final_details <-
+ if one_shot then return (error "no final details")
+ else return $! ModDetails {
+ md_types = mg_types tidy_result,
md_insts = mg_insts tidy_result,
md_rules = mg_rules tidy_result }
- ; emitExternalCore dflags tidy_result
+
+ -------------------
+ -- CONVERT TO STG and COMPLETE CODE GENERATION
+ ; (stub_h_exists, stub_c_exists, maybe_bcos)
+ <- hscBackEnd dflags tidy_result
-- and the answer is ...
; return (HscRecomp pcs_final
-------------------
-- RENAME and TYPECHECK
-------------------
- ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck and Rename"
+ ; (pcs_tc, maybe_tc_result) <- _scc_ "Typecheck-Rename"
tcRnModule hsc_env pcs_ch rdr_module
; case maybe_tc_result of {
Nothing -> return (Left (HscFail pcs_ch));
}}}}}
-hscBackEnd dflags cg_info_ref prepd_result
- = case dopt_HscLang dflags of
+hscBackEnd dflags
+ ModGuts{ -- This is the last use of the ModGuts in a compilation.
+ -- From now on, we just use the bits we need.
+ mg_module = this_mod,
+ mg_binds = core_binds,
+ mg_types = type_env,
+ mg_dir_imps = dir_imps,
+ mg_foreign = foreign_stubs,
+ mg_deps = dependencies } = do {
+
+ -------------------
+ -- PREPARE FOR CODE GENERATION
+ -- Do saturation and convert to A-normal form
+ prepd_binds <- _scc_ "CorePrep"
+ corePrepPgm dflags core_binds type_env;
+
+ case dopt_HscLang dflags of
HscNothing -> return (False, False, Nothing)
HscInterpreted ->
#ifdef GHCI
do ----------------- Generate byte code ------------------
- comp_bc <- byteCodeGen dflags prepd_result
+ comp_bc <- byteCodeGen dflags core_binds type_env
- -- Fill in the code-gen info
- writeIORef cg_info_ref (Just emptyNameEnv)
-
------------------ Create f-x-dynamic C-side stuff ---
(istub_h_exists, istub_c_exists)
- <- outputForeignStubs dflags (mg_foreign prepd_result)
+ <- outputForeignStubs dflags foreign_stubs
- return ( istub_h_exists, istub_c_exists,
- Just comp_bc )
+ return ( istub_h_exists, istub_c_exists, Just comp_bc )
#else
panic "GHC not compiled with interpreter"
#endif
other ->
do
----------------- Convert to STG ------------------
- (stg_binds, cost_centre_info, stg_back_end_info)
- <- _scc_ "CoreToStg"
- myCoreToStg dflags prepd_result
-
- -- Fill in the code-gen info for the earlier tidyCorePgm
- writeIORef cg_info_ref (Just stg_back_end_info)
+ (stg_binds, cost_centre_info) <- _scc_ "CoreToStg"
+ myCoreToStg dflags this_mod prepd_binds
------------------ Code generation ------------------
abstractC <- _scc_ "CodeGen"
- codeGen dflags prepd_result
- cost_centre_info stg_binds
-
+ codeGen dflags this_mod type_env foreign_stubs
+ dir_imps cost_centre_info stg_binds
+
------------------ Code output -----------------------
(stub_h_exists, stub_c_exists)
- <- codeOutput dflags prepd_result abstractC
-
+ <- codeOutput dflags this_mod foreign_stubs
+ dependencies abstractC
+
return (stub_h_exists, stub_c_exists, Nothing)
+ }
myParseModule dflags src_filename
}}
-myCoreToStg dflags (ModGuts {mg_module = this_mod, mg_binds = tidy_binds})
+myCoreToStg dflags this_mod prepd_binds
= do
- () <- coreBindsSize tidy_binds `seq` return ()
- -- TEMP: the above call zaps some space usage allocated by the
- -- simplifier, which for reasons I don't understand, persists
- -- thoroughout code generation -- JRS
- --
- -- This is still necessary. -- SDM (10 Dec 2001)
-
stg_binds <- _scc_ "Core2Stg"
- coreToStg dflags tidy_binds
+ coreToStg dflags prepd_binds
(stg_binds2, cost_centre_info) <- _scc_ "Core2Stg"
stg2stg dflags this_mod stg_binds
- let env_rhs :: CgInfoEnv
- env_rhs = mkNameEnv [ caf_info `seq` (idName bndr, CgInfo caf_info)
- | (bind,_) <- stg_binds2,
- let caf_info
- | stgBindHasCafRefs bind = MayHaveCafRefs
- | otherwise = NoCafRefs,
- bndr <- stgBinders bind ]
-
- return (stg_binds2, cost_centre_info, env_rhs)
+ return (stg_binds2, cost_centre_info)
\end{code}
initExternalPackageState :: ExternalPackageState
initExternalPackageState
- = EPS {
- eps_decls = (emptyNameEnv, 0),
- eps_insts = (emptyBag, 0),
- eps_inst_gates = emptyNameSet,
- eps_rules = foldr add_rule (emptyBag, 0) builtinRules,
-
- eps_PIT = emptyPackageIfaceTable,
- eps_PTE = wiredInThingEnv,
- eps_inst_env = emptyInstEnv,
- eps_rule_base = emptyRuleBase }
-
+ = emptyExternalPackageState {
+ eps_rules = foldr add_rule (emptyBag, 0) builtinRules,
+ eps_PTE = wiredInThingEnv,
+ }
where
add_rule (name,rule) (rules, n_slurped)
= (gated_decl `consBag` rules, n_slurped)
HomePackageTable, HomeModInfo(..), emptyHomePackageTable,
- ExternalPackageState(..),
+ ExternalPackageState(..), emptyExternalPackageState,
PackageTypeEnv, PackageIfaceTable, emptyPackageIfaceTable,
lookupIface, lookupIfaceByModName, moduleNameToModule,
emptyModIface,
import CoreSyn ( IdCoreRule )
import PrelNames ( isBuiltInSyntaxName )
+import InstEnv ( emptyInstEnv )
+import Rules ( emptyRuleBase )
import FiniteMap
-import Bag ( Bag )
+import Bag ( Bag, emptyBag )
import Maybes ( orElse )
import Outputable
import SrcLoc ( SrcLoc, isGoodSrcLoc )
data PersistentCompilerState
= PCS {
pcs_nc :: !NameCache,
- pcs_EPS :: !ExternalPackageState
+ pcs_EPS :: ExternalPackageState
+ -- non-strict because we fill it with error in HscMain
}
\end{code}
-- for the home package we have all the instance
-- declarations anyhow
}
+
+emptyExternalPackageState = EPS {
+ eps_decls = (emptyNameEnv, 0),
+ eps_insts = (emptyBag, 0),
+ eps_inst_gates = emptyNameSet,
+ eps_rules = (emptyBag, 0),
+ eps_PIT = emptyPackageIfaceTable,
+ eps_PTE = emptyTypeEnv,
+ eps_inst_env = emptyInstEnv,
+ eps_rule_base = emptyRuleBase
+ }
\end{code}
The NameCache makes sure that there is just one Unique assigned for
)
import CmdLineOpts
-import Id ( idType, idInfo, isImplicitId, idCgInfo )
-import DataCon ( dataConName, dataConSig, dataConFieldLabels, dataConStrictMarks, dataConWrapId )
+import Id ( idType, idInfo, isImplicitId, idCafInfo )
+import DataCon ( dataConName, dataConSig, dataConFieldLabels,
+ dataConStrictMarks, dataConWrapId )
import IdInfo -- Lots
import CoreSyn ( CoreRule(..), IdCoreRule )
import CoreFVs ( ruleLhsFreeNames )
id_type = idType id
id_info = idInfo id
- cg_info = idCgInfo id
arity_info = arityInfo id_info
- caf_info = cgCafInfo cg_info
+ caf_info = idCafInfo id
hs_idinfo | opt_OmitInterfacePragmas
= []
import CoreTidy ( tidyExpr, tidyVarOcc, tidyIdRules )
import PprCore ( pprIdRules )
import CoreLint ( showPass, endPass )
-import CoreUtils ( exprArity )
+import CoreUtils ( exprArity, hasCafRefs )
import VarEnv
import VarSet
import Var ( Id, Var )
import Id ( idType, idInfo, idName, idCoreRules,
isExportedId, mkVanillaGlobal, isLocalId,
- isImplicitId
+ isImplicitId, idArity, setIdInfo
)
import IdInfo {- loads of stuff -}
import NewDemand ( isBottomingSig, topSig )
import BasicTypes ( isNeverActive )
-import Name ( getOccName, nameOccName, mkInternalName,
+import Name ( getOccName, nameOccName, mkInternalName,
localiseName, isExternalName, nameSrcLoc
)
import RnEnv ( lookupOrigNameCache, newExternalName )
-import NameEnv ( filterNameEnv )
+import NameEnv ( lookupNameEnv, filterNameEnv )
import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
import Type ( tidyTopType )
import Module ( Module )
\end{code}
-
%************************************************************************
%* *
\subsection{What goes on}
\begin{code}
tidyCorePgm :: DynFlags
-> PersistentCompilerState
- -> CgInfoEnv -- Information from the back end,
- -- to be splatted into the IdInfo
-> ModGuts
-> IO (PersistentCompilerState, ModGuts)
-tidyCorePgm dflags pcs cg_info_env
+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 })
-- 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 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_result = mod_impl { mg_types = tidy_type_env,
%************************************************************************
\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!
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 (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 (const True) (idArity bndr') rhs'
-tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs)
+tidyTopBind mod ext_ids top_tidy_env (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).
+ pred v = v `notElem` map fst prs'
+ caf_info
+ | or [ mayHaveCafRefs (hasCafRefs pred (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
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
= HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
tidyWorker tidy_env other
= NoWorker
-\end{code}
\ No newline at end of file
+\end{code}
\begin{code}
core2core :: HscEnv
- -> PersistentCompilerState
+ -> PackageRuleBase
-> ModGuts
-> IO ModGuts
-core2core hsc_env pcs
+core2core hsc_env pkg_rule_base
mod_impl@(ModGuts { mg_exports = exports,
mg_binds = binds_in,
mg_rules = rules_in })
hpt = hsc_HPT hsc_env
ghci_mode = hsc_mode hsc_env
core_todos = dopt_CoreToDo dflags
- pkg_rule_base = eps_rule_base (pcs_EPS pcs) -- Rule-base accumulated from imported packages
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
import VarSet
import VarEnv
import Maybes ( maybeToBool )
-import Name ( getOccName, isExternalName, isDllName )
-import OccName ( occNameUserString )
+import Name ( getOccName, isExternalName, nameOccName )
+import OccName ( occNameUserString, occNameFS )
import BasicTypes ( Arity )
import CmdLineOpts ( DynFlags, opt_RuntimeTypes )
-import FastTypes hiding ( fastOr )
-import Util ( listLengthCmp, mapAndUnzip )
import Outputable
infixr 9 `thenLne`
one or more CAFs, or
- NoCafRefs if it definitely doesn't
-we collect the CafInfo first by analysing the original Core expression, and
-also place this information in the environment.
+The CafInfo has already been calculated during the CoreTidy pass.
During CoreToStg, we then pin onto each binding and case expression, a
list of Ids which represents the "live" CAFs at that point. The meaning
coreTopBindToStg env body_fvs (NonRec id rhs)
= let
- (caf_info, upd) = hasCafRefs env rhs
env' = extendVarEnv env id how_bound
- how_bound = LetBound (TopLet caf_info) (manifestArity rhs)
+ how_bound = LetBound TopLet (manifestArity rhs)
(stg_rhs, fvs', lv_info) =
initLne env (
- coreToTopStgRhs body_fvs ((id,rhs), upd) `thenLne` \ (stg_rhs, fvs') ->
- freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
+ coreToTopStgRhs body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') ->
+ freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
returnLne (stg_rhs, fvs', lv_info)
)
bind = StgNonRec (mkSRT lv_info) id stg_rhs
in
ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id)
- ASSERT2(consistent caf_info bind, ppr id)
+ ASSERT2(consistentCafInfo id bind, ppr id)
-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
= let
(binders, rhss) = unzip pairs
- -- To calculate caf_info, we initially map
- -- all the binders to NoCafRefs
- extra_env = [ (b, LetBound (TopLet NoCafRefs) (manifestArity rhs))
- | (b,rhs) <- pairs ]
- env1 = extendVarEnvList env extra_env
- (caf_infos, upd_flags) = mapAndUnzip (hasCafRefs env1) rhss
- -- NB: use env1 not env'
-
- -- If any has a CAF ref, they all do
- caf_info | any mayHaveCafRefs caf_infos = MayHaveCafRefs
- | otherwise = NoCafRefs
-
- extra_env' = [ (b, LetBound (TopLet caf_info) arity)
- | (b, LetBound _ arity) <- extra_env ]
+ extra_env' = [ (b, LetBound TopLet (manifestArity rhs))
+ | (b, rhs) <- pairs ]
env' = extendVarEnvList env extra_env'
(stg_rhss, fvs', lv_info)
= initLne env' (
- mapAndUnzipLne (coreToTopStgRhs body_fvs)
- (pairs `zip` upd_flags) `thenLne` \ (stg_rhss, fvss') ->
+ mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs
+ `thenLne` \ (stg_rhss, fvss') ->
let fvs' = unionFVInfos fvss' in
freeVarsToLiveVars fvs' `thenLne` \ lv_info ->
returnLne (stg_rhss, fvs', lv_info)
bind = StgRec (mkSRT lv_info) (zip binders stg_rhss)
in
ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders)
- ASSERT2(consistent caf_info bind, ppr binders)
+ ASSERT2(consistentCafInfo (head binders) bind, ppr binders)
-- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info)
(env', fvs' `unionFVInfo` body_fvs, bind)
--- assertion helper
-consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind
+#ifdef DEBUG
+-- Assertion helper: this checks that the CafInfo on the Id matches
+-- what CoreToStg has figured out about the binding's SRT. The
+-- CafInfo will be exact in all cases except when CorePrep has
+-- floated out a binding, in which case it will be approximate.
+consistentCafInfo id bind
+ | occNameFS (nameOccName (idName id)) == FSLIT("sat")
+ = id_marked_caffy || not binding_is_caffy
+ | otherwise
+ = id_marked_caffy == binding_is_caffy
+ where
+ id_marked_caffy = mayHaveCafRefs (idCafInfo id)
+ binding_is_caffy = stgBindHasCafRefs bind
+#endif
\end{code}
\begin{code}
coreToTopStgRhs
:: FreeVarsInfo -- Free var info for the scope of the binding
- -> ((Id,CoreExpr), UpdateFlag)
+ -> (Id,CoreExpr)
-> LneM (StgRhs, FreeVarsInfo)
-coreToTopStgRhs scope_fv_info ((bndr, rhs), upd)
+coreToTopStgRhs scope_fv_info (bndr, rhs)
= coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) ->
returnLne (mkTopStgRhs upd rhs_fvs bndr_info new_rhs, rhs_fvs)
where
bndr_info = lookupFVInfo scope_fv_info bndr
-mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> StgBinderInfo
- -> StgExpr -> StgRhs
+ upd | rhsIsNonUpd rhs = SingleEntry
+ | otherwise = Updatable
+
+mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs
mkTopStgRhs upd rhs_fvs binder_info (StgLam _ bndrs body)
= StgRhsClosure noCCS binder_info
ReEntrant
bndrs body
-mkTopStgRhs ReEntrant rhs_fvs binder_info (StgConApp con args)
- -- StgConApps can be Updatable: see isCrossDllConApp below
+mkTopStgRhs upd rhs_fvs binder_info (StgConApp con args)
+ | not (isUpdatable upd) -- StgConApps can be updatable (see isCrossDllConApp)
= StgRhsCon noCCS con args
-mkTopStgRhs upd_flag rhs_fvs binder_info rhs
+mkTopStgRhs upd rhs_fvs binder_info rhs
= StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
- upd_flag
+ upd
[] rhs
\end{code}
to do it before the SRT pass to save the SRT entries associated with
any top-level PAPs.
-\begin{code}
isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args
where
arity = stgArity f (lookupBinding env f)
isPAP env _ = False
-\end{code}
%************************************************************************
| LambdaBound -- Used for both lambda and case
-data LetInfo = NestedLet LiveInfo -- For nested things, what is live if this thing is live?
- -- Invariant: the binder itself is always a member of
- -- the dynamic set of its own LiveInfo
-
- | TopLet CafInfo -- For top level things, is it a CAF, or can it refer to one?
+data LetInfo
+ = TopLet -- top level things
+ | NestedLet LiveInfo -- For nested things, what is live if this
+ -- thing is live? Invariant: the binder
+ -- itself is always a member of
+ -- the dynamic set of its own LiveInfo
isLetBound (LetBound _ _) = True
isLetBound other = False
-topLevelBound ImportBound = True
-topLevelBound (LetBound (TopLet _) _) = True
-topLevelBound other = False
+topLevelBound ImportBound = True
+topLevelBound (LetBound TopLet _) = True
+topLevelBound other = False
\end{code}
For a let(rec)-bound variable, x, we record LiveInfo, the set of
= case how_bound of
ImportBound -> unitLiveCaf v -- Only CAF imports are
-- recorded in fvs
- LetBound (TopLet caf_info) _
- | mayHaveCafRefs caf_info -> unitLiveCaf v
- | otherwise -> emptyLiveInfo
+ LetBound TopLet _
+ | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v
+ | otherwise -> emptyLiveInfo
LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v
-- (see the invariant on NestedLet)
check_eq_how_bound hb1 hb2 = False
check_eq_li (NestedLet _) (NestedLet _) = True
-check_eq_li (TopLet _) (TopLet _) = True
+check_eq_li TopLet TopLet = True
check_eq_li li1 li2 = False
#endif
\end{code}
go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr)
\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 :: IdEnv HowBound -> CoreExpr -> (CafInfo, UpdateFlag)
-hasCafRefs p expr
- | is_caf || mentions_cafs = (MayHaveCafRefs, upd_flag)
- | otherwise = (NoCafRefs, ReEntrant)
- where
- mentions_cafs = isFastTrue (cafRefs p expr)
- is_caf = not (rhsIsNonUpd p expr)
- upd_flag | is_caf = Updatable
- | otherwise = ReEntrant
-
--- The environment that cafRefs uses has top-level bindings *only*.
--- We don't bother to add local bindings as cafRefs traverses the expression
--- because they will all be for LocalIds (all nested things are LocalIds)
--- However, we must look in the env first, because some top level things
--- might be local Ids
-
-cafRefs p (Var id)
- = case lookupVarEnv p id of
- Just (LetBound (TopLet caf_info) _) -> fastBool (mayHaveCafRefs caf_info)
- Nothing | isGlobalId id -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported
- | otherwise -> fastBool False -- Nested binder
- _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env
-
-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))
-
-
-rhsIsNonUpd :: IdEnv HowBound -> CoreExpr -> Bool
- -- True => Value-lambda, constructor, PAP
- -- This is a bit like CoreUtils.exprIsValue, with the following differences:
- -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC)
- --
- -- b) (C x xs), where C is a contructors is updatable if the application is
- -- dynamic: see isDynConApp
- --
- -- c) don't look through unfolding of f in (f x). I'm suspicious of this one
-
--- This function has to line up with what the update flag
--- for the StgRhs gets set to in mkStgRhs (above)
---
--- When opt_RuntimeTypes is on, we keep type lambdas and treat
--- them as making the RHS re-entrant (non-updatable).
-rhsIsNonUpd p (Lam b e) = isRuntimeVar b || rhsIsNonUpd p e
-rhsIsNonUpd p (Note (SCC _) e) = False
-rhsIsNonUpd p (Note _ e) = rhsIsNonUpd p e
-rhsIsNonUpd p other_expr
- = go other_expr 0 []
- where
- go (Var f) n_args args = idAppIsNonUpd p f n_args args
-
- go (App f a) n_args args
- | isTypeArg a = go f n_args args
- | otherwise = go f (n_args + 1) (a:args)
-
- go (Note (SCC _) f) n_args args = False
- go (Note _ f) n_args args = go f n_args args
-
- go other n_args args = False
-
-idAppIsNonUpd :: IdEnv HowBound -> Id -> Int -> [CoreExpr] -> Bool
-idAppIsNonUpd p id n_val_args args
- | Just con <- isDataConWorkId_maybe id = not (isCrossDllConApp con args)
- | otherwise = False -- SDM: disbled. See comment with isPAP above.
- -- n_val_args < stgArity id (lookupBinding p id)
-
stgArity :: Id -> HowBound -> Arity
stgArity f (LetBound _ arity) = arity
stgArity f ImportBound = idArity f
stgArity f LambdaBound = 0
-
-isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
-isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args
--- Top-level constructor applications can usually be allocated
--- statically, but they can't if
--- a) the constructor, or any of the arguments, come from another DLL
--- b) any of the arguments are LitLits
--- (because we can't refer to static labels in other DLLs).
--- If this happens we simply make the RHS into an updatable thunk,
--- and 'exectute' it rather than allocating it statically.
--- All this should match the decision in (see CoreToStg.mkStgRhs)
-
-
-isCrossDllArg :: CoreExpr -> Bool
--- True if somewhere in the expression there's a cross-DLL reference
-isCrossDllArg (Type _) = False
-isCrossDllArg (Var v) = isDllName (idName v)
-isCrossDllArg (Note _ e) = isCrossDllArg e
-isCrossDllArg (Lit lit) = isLitLitLit lit
-isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app
-isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam
\end{code}
import CoreLint ( lintUnfolding )
import WorkWrap ( mkWrapper )
-import Id ( Id, mkVanillaGlobal, mkLocalId )
+import Id ( Id, mkVanillaGlobal, mkLocalId, idInfo )
import MkId ( mkFCallId )
import IdInfo
import TyCon ( tyConDataCons, tyConTyVars )
tcInterfaceSigs :: [RenamedTyClDecl] -- Ignore non-sig-decls in these decls
-> TcM TcGblEnv
-tcInterfaceSigs decls = fixM (tc_interface_sigs decls)
+tcInterfaceSigs decls =
+ zapEnv (fixM (tc_interface_sigs decls)) `thenM` \ (_,sig_ids) ->
+ tcExtendGlobalValEnv sig_ids getGblEnv `thenM` \ gbl_env ->
+ returnM gbl_env
-- We tie a knot so that the Ids read out of interfaces are in scope
-- when we read their pragmas.
-- What we rely on is that pragmas are typechecked lazily; if
-- bound in this module (and hence not yet processed).
-- The discarding happens when forkM finds a type error.
-tc_interface_sigs decls unf_env
+tc_interface_sigs decls ~(unf_env, _)
= sequenceM [do_one d | d@(IfaceSig {}) <- decls] `thenM` \ sig_ids ->
- tcExtendGlobalValEnv sig_ids getGblEnv
- -- Return the extended environment
+ tcExtendGlobalValEnv sig_ids getGblEnv `thenM` \ gbl_env ->
+ returnM (gbl_env, sig_ids)
where
in_scope_vars = typeEnvIds (tcg_type_env unf_env)
-- When we have hi-boot files, an unfolding might refer to
where
-- Set the CgInfo to something sensible but uninformative before
-- we start; default assumption is that it has CAFs
- init_info = hasCafIdInfo
+ init_info = vanillaIdInfo
tcPrag info HsNoCafRefs = returnM (info `setCafInfo` NoCafRefs)
tcPrag info (HsArity arity) = returnM (info `setArityInfo` arity)
-- Non-standard operations
runTcRn, fixM, tryM, ioToTcRn,
newMutVar, readMutVar, writeMutVar,
- getEnv, setEnv, updEnv, unsafeInterleaveM,
+ getEnv, setEnv, updEnv, unsafeInterleaveM, zapEnv,
-- The environment types
Env(..), TopEnv(..), TcGblEnv(..),
import HsSyn ( PendingSplice, HsOverLit, MonoBinds, RuleDecl, ForeignDecl )
import RnHsSyn ( RenamedHsExpr, RenamedPat, RenamedArithSeqInfo )
-import HscTypes ( GhciMode, ExternalPackageState, HomePackageTable, NameCache,
- GlobalRdrEnv, LocalRdrEnv, FixityEnv, TypeEnv, TyThing,
- Avails, GenAvailInfo(..), AvailInfo, availName,
- IsBootInterface, Deprecations )
+import HscTypes ( GhciMode, ExternalPackageState, HomePackageTable,
+ NameCache, GlobalRdrEnv, LocalRdrEnv, FixityEnv,
+ TypeEnv, TyThing, Avails, GenAvailInfo(..), AvailInfo,
+ availName, IsBootInterface, Deprecations,
+ ExternalPackageState(..), emptyExternalPackageState )
import Packages ( PackageName )
-import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType, TcPredType, TcKind,
- tcCmpPred, tcCmpType, tcCmpTypes )
+import TcType ( TcTyVarSet, TcType, TcTauType, TcThetaType,
+ TcPredType, TcKind, tcCmpPred, tcCmpType, tcCmpTypes )
import InstEnv ( DFunId, InstEnv )
import Name ( Name )
import NameEnv
import DATA_IOREF ( IORef, newIORef, readIORef, writeIORef )
import UNSAFE_IO ( unsafeInterleaveIO )
import FIX_IO ( fixIO )
-import EXCEPTION ( Exception )
+import EXCEPTION ( Exception(..), tryJust )
+import IO ( isUserError )
import Maybe ( mapMaybe )
import ListSetOps ( unionLists )
-import Panic ( tryMost )
\end{code}
\begin{code}
tryM :: TcRn m r -> TcRn m (Either Exception r)
-- Reflect exception into TcRn monad
-tryM (TcRn thing) = TcRn (\ env -> tryMost (thing env))
+tryM (TcRn thing) = TcRn (\ env -> tryJust tc_errors (thing env))
+ where
+#if __GLASGOW_HASKELL__ > 504
+ tc_errors e@(IOException ioe) | isUserError ioe = Just e
+#else
+ tc_errors e@(IOException _) | isUserError e = Just e
+#endif
+ tc_errors _other = Nothing
+ -- type checker failures show up as UserErrors only
\end{code}
Lazy interleave
updEnv upd (TcRn m) = TcRn (\ env -> m (upd env))
\end{code}
+\begin{code}
+zapEnv :: TcRn m a -> TcRn m a
+zapEnv act = TcRn $ \env@Env{ env_top=top, env_gbl=gbl, env_lcl=lcl } ->
+ case top of {
+ TopEnv{
+ top_mode = mode,
+ top_dflags = dflags,
+ top_hpt = hpt,
+ top_eps = eps,
+ top_us = us
+ } -> do
+
+ eps_snap <- readIORef eps
+ ref <- newIORef $! emptyExternalPackageState{ eps_PTE = eps_PTE eps_snap }
+
+ let
+ top' = TopEnv {
+ top_mode = mode,
+ top_dflags = dflags,
+ top_hpt = hpt,
+ top_eps = ref,
+ top_us = us
+ }
+
+ type_env = tcg_type_env gbl
+ mod = tcg_mod gbl
+ gbl' = TcGblEnv {
+ tcg_mod = mod,
+ tcg_type_env = type_env
+ }
+
+ env' = Env {
+ env_top = top',
+ env_gbl = gbl',
+ env_lcl = lcl
+ -- leave the rest empty
+ }
+
+ case act of { TcRn f -> f env' }
+ }
+\end{code}
%************************************************************************
%* *
-- Tie the knot
traceTc (text "starting" <+> ppr final_kinds) `thenM_`
- fixM ( \ ~(rec_details_list, _, rec_all_tyclss) ->
+ fixM ( \ ~(rec_details_list, _, _) ->
-- Step 4
let
kind_env = mkNameEnv final_kinds
rec_details = mkNameEnv rec_details_list
-- Calculate variances, and feed into buildTyConOrClass
- rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- rec_all_tyclss]
+ rec_vrcs = calcTyConArgVrcs [tc | ATyCon tc <- tyclss]
build_one = buildTyConOrClass is_rec_tycon kind_env
rec_vrcs rec_details
projects / ghc-hetmet.git / commitdiff