setIdTyGenInfo,
setIdWorkerInfo,
setIdSpecialisation,
- setIdCafInfo,
+ setIdCgInfo,
setIdCprInfo,
setIdOccInfo,
idWorkerInfo,
idUnfolding,
idSpecialisation,
+ idCgInfo,
idCafInfo,
+ idCgArity,
idCprInfo,
idLBVarInfo,
idOccInfo,
import SrcLoc ( SrcLoc )
import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques,
getNumBuiltinUniques )
-import Outputable
infixl 1 `setIdUnfolding`,
`setIdArityInfo`,
mkSpecPragmaId :: OccName -> Unique -> Type -> SrcLoc -> Id
mkSpecPragmaId occ uniq ty loc = Var.mkSpecPragmaId (mkLocalName uniq occ loc)
(addFreeTyVars ty)
- noCafIdInfo
+ vanillaIdInfo
mkGlobalId :: GlobalIdDetails -> Name -> Type -> IdInfo -> Id
mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty) info
\begin{code}
mkLocalId :: Name -> Type -> Id
-mkLocalId name ty = mkLocalIdWithInfo name ty noCafIdInfo
+mkLocalId name ty = mkLocalIdWithInfo name ty vanillaIdInfo
-- SysLocal: for an Id being created by the compiler out of thin air...
-- UserLocal: an Id with a name the user might recognize...
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
---------------------------------
+ -- CG INFO
+idCgInfo :: Id -> CgInfo
+idCgInfo id = cgInfo (idInfo id)
+
+setIdCgInfo :: Id -> CgInfo -> Id
+setIdCgInfo id cg_info = modifyIdInfo (`setCgInfo` cg_info) id
+
+ ---------------------------------
-- CAF INFO
idCafInfo :: Id -> CafInfo
-idCafInfo id = cafInfo (idInfo id)
+idCafInfo id = cgCafInfo (idCgInfo id)
+
+ ---------------------------------
+ -- CG ARITY
-setIdCafInfo :: Id -> CafInfo -> Id
-setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
+idCgArity :: Id -> Arity
+idCgArity id = cgArity (idCgInfo id)
---------------------------------
-- CPR INFO
GlobalIdDetails(..), notGlobalId, -- Not abstract
IdInfo, -- Abstract
- vanillaIdInfo, noTyGenIdInfo, noCafOrTyGenIdInfo, noCafIdInfo,
+ vanillaIdInfo, noCafNoTyGenIdInfo,
seqIdInfo, megaSeqIdInfo,
-- Zapping
-- Specialisation
specInfo, setSpecInfo,
+ -- CG info
+ CgInfo(..), cgInfo, setCgInfo, cgMayHaveCafRefs, pprCgInfo,
+ cgArity, cgCafInfo, vanillaCgInfo,
+ CgInfoEnv, lookupCgInfo,
+ setCgArity,
+
-- CAF info
- CafInfo(..), cafInfo, setCafInfo, mayHaveCafRefs, ppCafInfo,
+ CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs,
-- Constructed Product Result Info
CprInfo(..), cprInfo, setCprInfo, ppCprInfo, noCprInfo,
import CoreSyn
import Type ( Type, usOnce )
import PrimOp ( PrimOp )
+import NameEnv ( NameEnv, lookupNameEnv )
+import Name ( Name )
import Var ( Id )
import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker,
InsideLam, insideLam, notInsideLam,
`setCprInfo`,
`setWorkerInfo`,
`setLBVarInfo`,
+ `setOccInfo`,
+ `setCgInfo`,
`setCafInfo`,
- `setOccInfo`
+ `setCgArity`
-- infixl so you can say (id `set` a `set` b)
\end{code}
strictnessInfo :: StrictnessInfo, -- Strictness properties
workerInfo :: WorkerInfo, -- Pointer to Worker Function
unfoldingInfo :: Unfolding, -- Its unfolding
- cafInfo :: CafInfo, -- whether it refers (indirectly) to any CAFs
+ cgInfo :: CgInfo, -- Code generator info (arity, CAF info)
cprInfo :: CprInfo, -- Function always constructs a product result
lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable
inlinePragInfo :: InlinePragInfo, -- Inline pragma
-- Omitting this improves runtimes a little, presumably because
-- some unfoldings are not calculated at all
- seqCaf (cafInfo info) `seq`
+-- CgInfo is involved in a loop, so we have to be careful not to seq it
+-- too early.
+-- seqCg (cgInfo info) `seq`
seqCpr (cprInfo info) `seq`
seqLBVar (lbvarInfo info) `seq`
seqOccInfo (occInfo info)
setDemandInfo info dd = info { demandInfo = dd }
setArityInfo info ar = info { arityInfo = ar }
-setCafInfo info cf = info { cafInfo = cf }
+setCgInfo info cg = info { cgInfo = cg }
setCprInfo info cp = info { cprInfo = cp }
setLBVarInfo info lb = info { lbvarInfo = lb }
\end{code}
vanillaIdInfo :: IdInfo
vanillaIdInfo
= IdInfo {
- cafInfo = MayHaveCafRefs, -- Safe!
+ cgInfo = noCgInfo,
arityInfo = UnknownArity,
demandInfo = wwLazy,
specInfo = emptyCoreRules,
occInfo = NoOccInfo
}
-noTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever
+noCafNoTyGenIdInfo = vanillaIdInfo `setTyGenInfo` TyGenNever
+ `setCgInfo` (CgInfo 0 NoCafRefs)
+ -- Used for built-in type Ids in MkId.
-- Many built-in things have fixed types, so we shouldn't
-- run around generalising them
-
-noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs
- -- Local things don't refer to Cafs
-
-noCafOrTyGenIdInfo = noTyGenIdInfo `setCafInfo` NoCafRefs
- -- Most also guarantee not to refer to CAFs
\end{code}
hasArity other = True
ppArityInfo UnknownArity = empty
-ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("__A"), int arity]
-ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("__AL"), int arity]
+ppArityInfo (ArityExactly arity) = hsep [ptext SLIT("ArityExactly"), int arity]
+ppArityInfo (ArityAtLeast arity) = hsep [ptext SLIT("ArityAtLeast"), int arity]
\end{code}
%************************************************************************
for w/w split
(b) the strictness info might be "SSS" or something, so no w/w split.
+Sometimes the arity of a wrapper changes from the original arity from
+which it was generated, so we always emit the "original" arity into
+the interface file, as part of the worker info.
+
+How can this happen? Sometimes we get
+ f = coerce t (\x y -> $wf x y)
+at the moment of w/w split; but the eta reducer turns it into
+ f = coerce t $wf
+which is perfectly fine except that the exposed arity so far as
+the code generator is concerned (zero) differs from the arity
+when we did the split (2).
+
+All this arises because we use 'arity' to mean "exactly how many
+top level lambdas are there" in interface files; but during the
+compilation of this module it means "how many things can I apply
+this to".
+
\begin{code}
data WorkerInfo = NoWorker
%************************************************************************
%* *
-\subsection[CAF-IdInfo]{CAF-related information}
+\subsection[CG-IdInfo]{Code generator-related information}
%* *
%************************************************************************
-This information is used to build Static Reference Tables (see
-simplStg/ComputeSRT.lhs).
+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}
+data CgInfo = CgInfo
+ !Arity -- Exact arity for calling purposes
+ !CafInfo
+
+cgArity (CgInfo arity _) = arity
+cgCafInfo (CgInfo _ caf_info) = caf_info
+
+setCafInfo info caf_info =
+ case cgInfo info of { CgInfo arity _ ->
+ info `setCgInfo` CgInfo arity caf_info }
+
+setCgArity info arity =
+ case cgInfo info of { CgInfo _ caf_info ->
+ info `setCgInfo` CgInfo arity caf_info }
+
+ -- Used for local Ids, which shouldn't need any CgInfo
+noCgInfo = panic "noCgInfo!"
+
+cgMayHaveCafRefs (CgInfo _ caf_info) = mayHaveCafRefs caf_info
+
+seqCg c = c `seq` () -- fields are strict anyhow
+
+vanillaCgInfo = CgInfo 0 MayHaveCafRefs -- Definitely safe
+
+-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs).
+
data CafInfo
= MayHaveCafRefs -- either:
-- (1) A function or static constructor
| NoCafRefs -- A function or static constructor
-- that refers to no CAFs.
--- LATER: not sure how easy this is...
--- | OneCafRef Id
+mayHaveCafRefs MayHaveCafRefs = True
+mayHaveCafRefs _ = False
+seqCaf c = c `seq` ()
-mayHaveCafRefs MayHaveCafRefs = True
-mayHaveCafRefs _ = False
+pprCgInfo (CgInfo arity caf_info) = ppArity arity <+> ppCafInfo caf_info
-seqCaf c = c `seq` ()
+ppArity 0 = empty
+ppArity n = hsep [ptext SLIT("__A"), int n]
ppCafInfo NoCafRefs = ptext SLIT("__C")
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}
+
%************************************************************************
%* *
mkTemplateLocals, mkTemplateLocalsNum,
mkTemplateLocal, idCprInfo
)
-import IdInfo ( IdInfo, vanillaIdInfo, noTyGenIdInfo, noCafOrTyGenIdInfo,
- exactArity, setUnfoldingInfo, setCafInfo, setCprInfo,
- setArityInfo, setSpecInfo,
+import IdInfo ( IdInfo, noCafNoTyGenIdInfo,
+ exactArity, setUnfoldingInfo, setCprInfo,
+ setArityInfo, setSpecInfo, setCgInfo,
mkStrictnessInfo, setStrictnessInfo,
- GlobalIdDetails(..), CafInfo(..), CprInfo(..)
+ GlobalIdDetails(..), CafInfo(..), CprInfo(..),
+ CgInfo(..), setCgArity
)
import FieldLabel ( mkFieldLabel, fieldLabelName,
firstFieldLabelTag, allFieldLabelTags, fieldLabelType
mkDataConId work_name data_con
= mkGlobalId (DataConId data_con) work_name (dataConRepType data_con) info
where
- info = noCafOrTyGenIdInfo
+ info = noCafNoTyGenIdInfo
+ `setCgArity` arity
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
`setCprInfo` cpr_info
wrap_id = mkGlobalId (DataConWrapId data_con) (dataConName data_con) wrap_ty info
work_id = dataConId data_con
- info = noCafOrTyGenIdInfo
+ info = noCafNoTyGenIdInfo
`setUnfoldingInfo` mkTopUnfolding (mkInlineMe wrap_rhs)
`setCprInfo` cpr_info
-- The Cpr info can be important inside INLINE rhss, where the
-- wrapper constructor isn't inlined
+ `setCgArity` arity
`setArityInfo` exactArity arity
-- It's important to specify the arity, so that partial
-- applications are treated as values
mkFunTy data_ty field_tau
arity = 1 + n_dict_tys + n_field_dict_tys
- info = noTyGenIdInfo
- `setCafInfo` caf_info
+ info = noCafNoTyGenIdInfo
+ `setCgInfo` (CgInfo arity caf_info)
`setArityInfo` exactArity arity
`setUnfoldingInfo` unfolding
-- ToDo: consider adding further IdInfo
field_lbl = mkFieldLabel name tycon ty tag
tag = assoc "MkId.mkDictSelId" (classSelIds clas `zip` allFieldLabelTags) sel_id
- info = noCafOrTyGenIdInfo
+ info = noCafNoTyGenIdInfo
+ `setCgArity` 1
`setArityInfo` exactArity 1
`setUnfoldingInfo` unfolding
name = mkPrimOpIdName prim_op
id = mkGlobalId (PrimOpId prim_op) name ty info
- info = noCafOrTyGenIdInfo
+ info = noCafNoTyGenIdInfo
`setSpecInfo` rules
+ `setCgArity` arity
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
name = mkCCallName uniq occ_str
prim_op = CCallOp ccall
- info = noCafOrTyGenIdInfo
+ info = noCafNoTyGenIdInfo
+ `setCgArity` arity
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
\begin{code}
mkDefaultMethodId dm_name ty
- = mkVanillaGlobal dm_name ty noTyGenIdInfo
+ = mkVanillaGlobal dm_name ty noCafNoTyGenIdInfo
mkDictFunId :: Name -- Name to use for the dict fun;
-> Class
-> Id
mkDictFunId dfun_name clas inst_tyvars inst_tys dfun_theta
- = mkVanillaGlobal dfun_name dfun_ty noTyGenIdInfo
+ = mkVanillaGlobal dfun_name dfun_ty noCafNoTyGenIdInfo
where
dfun_ty = mkSigmaTy inst_tyvars dfun_theta (mkDictTy clas inst_tys)
- info = noTyGenIdInfo
+ info = noCafNoTyGenIdInfo
-- Type is wired-in (see comment at TcClassDcl.tcClassSig),
-- so do not generalise it
unsafeCoerceId
= pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
where
- info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
getTagId
= pcMiscPrelId getTagIdKey pREL_GHC SLIT("getTag#") ty info
where
- info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
+ info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
-- We don't provide a defn for this; you must inline it
ty = mkForAllTys [alphaTyVar] (mkFunTy alphaTy intPrimTy)
realWorldPrimId -- :: State# RealWorld
= pcMiscPrelId realWorldPrimIdKey pREL_GHC SLIT("realWorld#")
realWorldStatePrimTy
- (noCafOrTyGenIdInfo `setUnfoldingInfo` mkOtherCon [])
+ (noCafNoTyGenIdInfo `setUnfoldingInfo` mkOtherCon [])
-- The mkOtherCon makes it look that realWorld# is evaluated
-- which in turn makes Simplify.interestingArg return True,
-- which in turn makes INLINE things applied to realWorld# likely
pAR_ERROR_ID
= pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
- (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafOrTyGenIdInfo
+ (mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
\end{code}
pc_bottoming_Id key mod name ty
= pcMiscPrelId key mod name ty bottoming_info
where
- bottoming_info = noCafOrTyGenIdInfo
+ bottoming_info = noCafNoTyGenIdInfo
`setStrictnessInfo` mkStrictnessInfo ([wwStrict], True)
-
+
-- these "bottom" out, no matter what their arguments
generic_ERROR_ID u n = pc_bottoming_Id u pREL_ERR n errorTy
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: CgExpr.lhs,v 1.41 2001/02/20 09:38:59 simonpj Exp $
+% $Id: CgExpr.lhs,v 1.42 2001/03/13 12:50:30 simonmar Exp $
%
%********************************************************
%* *
\subsection[let-and-letrec-codegen]{Converting @StgLet@ and @StgLetrec@}
\begin{code}
-cgExpr (StgLet (StgNonRec name rhs) expr)
- = cgRhs name rhs `thenFC` \ (name, info) ->
+cgExpr (StgLet (StgNonRec srt name rhs) expr)
+ = cgRhs srt name rhs `thenFC` \ (name, info) ->
addBindC name info `thenC`
cgExpr expr
-cgExpr (StgLet (StgRec pairs) expr)
+cgExpr (StgLet (StgRec srt pairs) expr)
= fixC (\ new_bindings -> addBindsC new_bindings `thenC`
- listFCs [ cgRhs b e | (b,e) <- pairs ]
+ listFCs [ cgRhs srt b e | (b,e) <- pairs ]
) `thenFC` \ new_bindings ->
addBindsC new_bindings `thenC`
in @CgClosure@ (to do closures).
\begin{code}
-cgRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgRhs :: SRT -> Id -> StgRhs -> FCode (Id, CgIdInfo)
-- the Id is passed along so a binding can be set up
-cgRhs name (StgRhsCon maybe_cc con args)
+cgRhs srt name (StgRhsCon maybe_cc con args)
= getArgAmodes args `thenFC` \ amodes ->
buildDynCon name maybe_cc con amodes `thenFC` \ idinfo ->
returnFC (name, idinfo)
-cgRhs name (StgRhsClosure cc bi srt@(NoSRT) fvs upd_flag args body)
- = mkRhsClosure name cc bi srt fvs upd_flag args body
-cgRhs name (StgRhsClosure cc bi srt@(SRT _ _) fvs upd_flag args body)
+cgRhs srt name (StgRhsClosure cc bi fvs upd_flag args body)
= mkRhsClosure name cc bi srt fvs upd_flag args body
\end{code}
%* *
%********************************************************
\begin{code}
-cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgNonRec binder rhs)
+cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
+ (StgNonRec srt binder rhs)
= cgLetNoEscapeRhs live_in_rhss rhs_eob_info maybe_cc_slot
- NonRecursive binder rhs
+ NonRecursive srt binder rhs
`thenFC` \ (binder, info) ->
addBindC binder info
-cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot (StgRec pairs)
+cgLetNoEscapeBindings live_in_rhss rhs_eob_info maybe_cc_slot
+ (StgRec srt pairs)
= fixC (\ new_bindings ->
addBindsC new_bindings `thenC`
listFCs [ cgLetNoEscapeRhs full_live_in_rhss
- rhs_eob_info maybe_cc_slot Recursive b e
+ rhs_eob_info maybe_cc_slot Recursive srt b e
| (b,e) <- pairs ]
) `thenFC` \ new_bindings ->
-> EndOfBlockInfo
-> Maybe VirtualSpOffset
-> RecFlag
+ -> SRT
-> Id
-> StgRhs
-> FCode (Id, CgIdInfo)
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
- (StgRhsClosure cc bi srt _ upd_flag args body)
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
+ (StgRhsClosure cc bi _ upd_flag args body)
= -- We could check the update flag, but currently we don't switch it off
-- for let-no-escaped things, so we omit the check too!
-- case upd_flag of
-- Updatable -> panic "cgLetNoEscapeRhs" -- Nothing to update!
-- other -> cgLetNoEscapeClosure binder cc bi live_in_whole_let live_in_rhss args body
- cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info maybe_cc_slot rec args body
+ cgLetNoEscapeClosure binder cc bi srt full_live_in_rhss rhs_eob_info
+ maybe_cc_slot rec args body
-- For a constructor RHS we want to generate a single chunk of code which
-- can be jumped to from many places, which will return the constructor.
-- It's easy; just behave as if it was an StgRhsClosure with a ConApp inside!
-cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec binder
+cgLetNoEscapeRhs full_live_in_rhss rhs_eob_info maybe_cc_slot rec srt binder
(StgRhsCon cc con args)
- = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} NoSRT
+ = cgLetNoEscapeClosure binder cc noBinderInfo{-safe-} srt
full_live_in_rhss rhs_eob_info maybe_cc_slot rec
[] --No args; the binder is data structure, not a function
(StgConApp con args)
%
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
%
-% $Id: ClosureInfo.lhs,v 1.45 2001/02/20 09:38:59 simonpj Exp $
+% $Id: ClosureInfo.lhs,v 1.46 2001/03/13 12:50:30 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
opt_Parallel, opt_DoTickyProfiling,
opt_SMP )
-import Id ( Id, idType, idArityInfo )
+import Id ( Id, idType, idCgArity )
import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
isNullaryDataCon, dataConName
)
mkLFImported :: Id -> LambdaFormInfo
mkLFImported id
- = case idArityInfo id of
- ArityExactly 0 -> LFThunk (idType id)
- TopLevel True{-no fvs-}
- True{-updatable-} NonStandardThunk
- (error "mkLFImported: no srt label")
- (error "mkLFImported: no srt")
- ArityExactly n -> LFReEntrant (idType id) TopLevel n True -- n > 0
- (error "mkLFImported: no srt label")
- (error "mkLFImported: no srt")
- other -> LFImported -- Not sure of exact arity
+ = case idCgArity id of
+ n | n > 0 -> LFReEntrant (idType id) TopLevel n True -- n > 0
+ (error "mkLFImported: no srt label")
+ (error "mkLFImported: no srt")
+ other -> LFImported -- Not sure of exact arity
\end{code}
%************************************************************************
\begin{code}
cgTopBinding :: (StgBinding,[Id]) -> Code
-cgTopBinding (StgNonRec id rhs, srt)
+cgTopBinding (StgNonRec srt_info id rhs, srt)
= absC maybeSplitCode `thenC`
maybeGlobaliseId id `thenFC` \ id' ->
let
in
mkSRT srt_label srt [] `thenC`
setSRTLabel srt_label (
- cgTopRhs id' rhs `thenFC` \ (id, info) ->
+ cgTopRhs id' rhs srt_info `thenFC` \ (id, info) ->
addBindC id info
)
-cgTopBinding (StgRec pairs, srt)
+cgTopBinding (StgRec srt_info pairs, srt)
= absC maybeSplitCode `thenC`
let
(bndrs, rhss) = unzip pairs
setSRTLabel srt_label (
fixC (\ new_binds ->
addBindsC new_binds `thenC`
- mapFCs ( \ (b,e) -> cgTopRhs b e ) pairs'
+ mapFCs ( \ (b,e) -> cgTopRhs b e srt_info ) pairs'
) `thenFC` \ new_binds -> nopC
)
-- to enclose the listFCs in cgTopBinding, but that tickled the
-- statics "error" call in initC. I DON'T UNDERSTAND WHY!
-cgTopRhs :: Id -> StgRhs -> FCode (Id, CgIdInfo)
+cgTopRhs :: Id -> StgRhs -> SRT -> FCode (Id, CgIdInfo)
-- the Id is passed along for setting up a binding...
-cgTopRhs bndr (StgRhsCon cc con args)
+cgTopRhs bndr (StgRhsCon cc con args) srt
= maybeGlobaliseId bndr `thenFC` \ bndr' ->
forkStatics (cgTopRhsCon bndr con args)
-cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body)
+cgTopRhs bndr (StgRhsClosure cc bi fvs upd_flag args body) srt
= -- There should be no free variables
ASSERT(null fvs)
-- If the closure is a thunk, then the binder must be recorded as such.
- ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr)
+-- ASSERT2(not (isUpdatable upd_flag) || mayHaveCafRefs (idCafInfo bndr), ppr bndr)
getSRTLabel `thenFC` \srt_label ->
let lf_info =
\section{Core pass to saturate constructors and PrimOps}
\begin{code}
-module CoreSat (
- coreSatPgm, coreSatExpr
+module CorePrep (
+ corePrepPgm, corePrepExpr
) where
#include "HsVersions.h"
-import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand, exprArity )
+import CoreUtils( exprIsTrivial, exprIsAtom, exprType, exprIsValue, etaExpand )
import CoreFVs ( exprFreeVars )
import CoreLint ( endPass )
import CoreSyn
isUnLiftedType, isUnboxedTupleType, repType,
uaUTy, usOnce, usMany, seqType )
import Demand ( Demand, isStrict, wwLazy, StrictnessInfo(..) )
-import PrimOp ( PrimOp(..) )
-import Var ( Id, TyVar, setTyVarUnique )
+import PrimOp ( PrimOp(..), setCCallUnique )
+import Var ( Var, Id, setVarUnique, globalIdDetails, setGlobalIdDetails )
import VarSet
+import VarEnv
import Id ( mkSysLocal, idType, idStrictness, idDemandInfo, idArity,
- isDeadBinder, setIdType, isPrimOpId_maybe, hasNoBinding
+ setIdType, isPrimOpId_maybe, isLocalId, modifyIdInfo,
+ hasNoBinding
)
-
+import IdInfo ( GlobalIdDetails(..) )
+import HscTypes ( ModDetails(..) )
import UniqSupply
import Maybes
import OrdList
-- Overview
-- ---------------------------------------------------------------------------
-MAJOR CONSTRAINT:
- By the time this pass happens, we have spat out tidied Core into
- the interface file, including all IdInfo.
-
- So we must not change the arity of any top-level function,
- because we've already fixed it and put it out into the interface file.
- Nor must we change a value (e.g. constructor) into a thunk.
-
- It's ok to introduce extra bindings, which don't appear in the
- interface file. We don't put arity info on these extra bindings,
- because they are never fully applied, so there's no chance of
- compiling just-a-fast-entry point for them.
-
-Most of the contents of this pass used to be in CoreToStg. The
-primary goals here are:
+The goal of this pass is to prepare for code generation.
1. Saturate constructor and primop applications.
5. Do the seq/par munging. See notes with mkCase below.
+6. Clone all local Ids. This means that Tidy Core has the property
+ that all Ids are unique, rather than the weaker guarantee of
+ no clashes which the simplifier provides.
+
+7. Give each dynamic CCall occurrence a fresh unique; this is
+ rather like the cloning step above.
+
This is all done modulo type applications and abstractions, so that
when type erasure is done for conversion to STG, we don't end up with
any trivial or useless bindings.
+
-- -----------------------------------------------------------------------------
\begin{code}
-coreSatPgm :: DynFlags -> [CoreBind] -> IO [CoreBind]
-coreSatPgm dflags binds
- = do showPass dflags "CoreSat"
+corePrepPgm :: DynFlags -> ModDetails -> IO ModDetails
+corePrepPgm dflags mod_details
+ = do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
- let new_binds = initUs_ us (coreSatTopBinds binds)
- endPass dflags "CoreSat" Opt_D_dump_sat new_binds
+ let new_binds = initUs_ us (corePrepTopBinds emptyVarEnv (md_binds mod_details))
+ endPass dflags "CorePrep" Opt_D_dump_sat new_binds
+ return (mod_details { md_binds = new_binds })
-coreSatExpr :: DynFlags -> CoreExpr -> IO CoreExpr
-coreSatExpr dflags expr
- = do showPass dflags "CoreSat"
+corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
+corePrepExpr dflags expr
+ = do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
- let new_expr = initUs_ us (coreSatAnExpr expr)
- dumpIfSet_dyn dflags Opt_D_dump_sat "Saturated/Normal form syntax:"
+ let new_expr = initUs_ us (corePrepAnExpr emptyVarEnv expr)
+ dumpIfSet_dyn dflags Opt_D_dump_sat "CorePrep"
(ppr new_expr)
return new_expr
data FloatingBind = FloatLet CoreBind
| FloatCase Id CoreExpr
+type CloneEnv = IdEnv Id -- Clone local Ids
+
allLazy :: OrdList FloatingBind -> Bool
allLazy floats = foldOL check True floats
where
check (FloatLet _) y = y
check (FloatCase _ _) y = False
-coreSatTopBinds :: [CoreBind] -> UniqSM [CoreBind]
--- Very careful to preserve the arity of top-level functions
-coreSatTopBinds [] = returnUs []
+corePrepTopBinds :: CloneEnv -> [CoreBind] -> UniqSM [CoreBind]
+corePrepTopBinds env [] = returnUs []
-coreSatTopBinds (NonRec b r : binds)
- = coreSatTopRhs b r `thenUs` \ (floats, r') ->
- coreSatTopBinds binds `thenUs` \ binds' ->
- returnUs (floats ++ NonRec b r' : binds')
-
-coreSatTopBinds (Rec prs : binds)
- = mapAndUnzipUs do_pair prs `thenUs` \ (floats_s, prs') ->
- coreSatTopBinds binds `thenUs` \ binds' ->
- returnUs (Rec (flattenBinds (concat floats_s) ++ prs') : binds')
+corePrepTopBinds env (bind : binds)
+ = corePrepBind env bind `thenUs` \ (env', floats) ->
+ ASSERT( allLazy floats )
+ corePrepTopBinds env' binds `thenUs` \ binds' ->
+ returnUs (foldOL add binds' floats)
where
- do_pair (b,r) = coreSatTopRhs b r `thenUs` \ (floats, r') ->
- returnUs (floats, (b, r'))
-
-coreSatTopRhs :: Id -> CoreExpr -> UniqSM ([CoreBind], CoreExpr)
--- The trick here is that if we see
--- x = $wC p $wJust q
--- we want to transform to
--- sat = \a -> $wJust a
--- x = $wC p sat q
--- and NOT to
--- x = let sat = \a -> $wJust a in $wC p sat q
---
--- The latter is bad because the thing was a value before, but
--- is a thunk now, and that's wrong because now x may need to
--- be in other bindings' SRTs.
--- This has to be right for recursive as well as non-recursive bindings
---
--- Notice that it's right to give sat vanilla IdInfo; in particular NoCafRefs
---
--- You might worry that arity might increase, thus
--- x = $wC a ==> x = \ b c -> $wC a b c
--- but the simpifier does eta expansion vigorously, so I don't think this
--- can occur. If it did, it would be a problem, because x's arity changes,
--- so we have an ASSERT to check. (I use WARN so we can see the output.)
-
-coreSatTopRhs b rhs
- = coreSatExprFloat rhs `thenUs` \ (floats, rhs1) ->
- if exprIsValue rhs then
- ASSERT( allLazy floats )
- WARN( idArity b /= exprArity rhs1, ptext SLIT("Disaster!") <+> ppr b )
- returnUs ([bind | FloatLet bind <- fromOL floats], rhs1)
- else
- mkBinds floats rhs1 `thenUs` \ rhs2 ->
- WARN( idArity b /= exprArity rhs2, ptext SLIT("Disaster!") <+> ppr b )
- returnUs ([], rhs2)
-
-
-coreSatBind :: CoreBind -> UniqSM (OrdList FloatingBind)
+ add (FloatLet bind) binds = bind : binds
+
+
+-- ---------------------------------------------------------------------------
+-- Bindings
+-- ---------------------------------------------------------------------------
+
+corePrepBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
-- Used for non-top-level bindings
--- We return a *list* of bindings because we may start with
+-- We return a *list* of bindings, because we may start with
-- x* = f (g y)
-- where x is demanded, in which case we want to finish with
-- a = g y
-- x* = f a
-- And then x will actually end up case-bound
-coreSatBind (NonRec binder rhs)
- = coreSatExprFloat rhs `thenUs` \ (floats, new_rhs) ->
- mkNonRec binder (bdrDem binder) floats new_rhs
- -- NB: if there are any lambdas at the top of the RHS,
- -- the floats will be empty, so the arity won't be affected
+corePrepBind env (NonRec bndr rhs)
+ = corePrepExprFloat env rhs `thenUs` \ (floats, rhs') ->
+ cloneBndr env bndr `thenUs` \ (env', bndr') ->
+ mkNonRec bndr' (bdrDem bndr') floats rhs' `thenUs` \ floats' ->
+ returnUs (env', floats')
-coreSatBind (Rec pairs)
+corePrepBind env (Rec pairs)
-- Don't bother to try to float bindings out of RHSs
-- (compare mkNonRec, which does try)
- = mapUs do_rhs pairs `thenUs` \ new_pairs ->
- returnUs (unitOL (FloatLet (Rec new_pairs)))
+ = cloneBndrs env bndrs `thenUs` \ (env', bndrs') ->
+ mapUs (corePrepAnExpr env') rhss `thenUs` \ rhss' ->
+ returnUs (env', unitOL (FloatLet (Rec (bndrs' `zip` rhss'))))
where
- do_rhs (bndr,rhs) = coreSatAnExpr rhs `thenUs` \ new_rhs' ->
- returnUs (bndr,new_rhs')
+ (bndrs, rhss) = unzip pairs
-- ---------------------------------------------------------------------------
-- ---------------------------------------------------------------------------
-- This is where we arrange that a non-trivial argument is let-bound
-coreSatArg :: CoreArg -> RhsDemand -> UniqSM (OrdList FloatingBind, CoreArg)
-coreSatArg arg dem
- = coreSatExprFloat arg `thenUs` \ (floats, arg') ->
+corePrepArg :: CloneEnv -> CoreArg -> RhsDemand
+ -> UniqSM (OrdList FloatingBind, CoreArg)
+corePrepArg env arg dem
+ = corePrepExprFloat env arg `thenUs` \ (floats, arg') ->
if needs_binding arg'
then returnUs (floats, arg')
else newVar (exprType arg') `thenUs` \ v ->
-- Dealing with expressions
-- ---------------------------------------------------------------------------
-coreSatAnExpr :: CoreExpr -> UniqSM CoreExpr
-coreSatAnExpr expr
- = coreSatExprFloat expr `thenUs` \ (floats, expr) ->
+corePrepAnExpr :: CloneEnv -> CoreExpr -> UniqSM CoreExpr
+corePrepAnExpr env expr
+ = corePrepExprFloat env expr `thenUs` \ (floats, expr) ->
mkBinds floats expr
-coreSatExprFloat :: CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
+corePrepExprFloat :: CloneEnv -> CoreExpr -> UniqSM (OrdList FloatingBind, CoreExpr)
-- If
-- e ===> (bs, e')
-- then
-- For example
-- f (g x) ===> ([v = g x], f v)
-coreSatExprFloat (Var v)
- = maybeSaturate v (Var v) 0 (idType v) `thenUs` \ app ->
+corePrepExprFloat env (Var v)
+ = fiddleCCall v `thenUs` \ v1 ->
+ let v2 = lookupVarEnv env v1 `orElse` v1 in
+ maybeSaturate v2 (Var v2) 0 (idType v2) `thenUs` \ app ->
returnUs (nilOL, app)
-coreSatExprFloat (Lit lit)
- = returnUs (nilOL, Lit lit)
+corePrepExprFloat env expr@(Type _)
+ = returnUs (nilOL, expr)
-coreSatExprFloat (Let bind body)
- = coreSatBind bind `thenUs` \ new_binds ->
- coreSatExprFloat body `thenUs` \ (floats, new_body) ->
- returnUs (new_binds `appOL` floats, new_body)
+corePrepExprFloat env expr@(Lit lit)
+ = returnUs (nilOL, expr)
-coreSatExprFloat (Note n@(SCC _) expr)
- = coreSatAnExpr expr `thenUs` \ expr ->
- deLam expr `thenUs` \ expr ->
- returnUs (nilOL, Note n expr)
+corePrepExprFloat env (Let bind body)
+ = corePrepBind env bind `thenUs` \ (env', new_binds) ->
+ corePrepExprFloat env' body `thenUs` \ (floats, new_body) ->
+ returnUs (new_binds `appOL` floats, new_body)
-coreSatExprFloat (Note other_note expr)
- = coreSatExprFloat expr `thenUs` \ (floats, expr) ->
- returnUs (floats, Note other_note expr)
+corePrepExprFloat env (Note n@(SCC _) expr)
+ = corePrepAnExpr env expr `thenUs` \ expr1 ->
+ deLam expr1 `thenUs` \ expr2 ->
+ returnUs (nilOL, Note n expr2)
-coreSatExprFloat expr@(Type _)
- = returnUs (nilOL, expr)
+corePrepExprFloat env (Note other_note expr)
+ = corePrepExprFloat env expr `thenUs` \ (floats, expr') ->
+ returnUs (floats, Note other_note expr')
-coreSatExprFloat expr@(Lam _ _)
- = coreSatAnExpr body `thenUs` \ body' ->
+corePrepExprFloat env expr@(Lam _ _)
+ = corePrepAnExpr env body `thenUs` \ body' ->
returnUs (nilOL, mkLams bndrs body')
where
(bndrs,body) = collectBinders expr
-coreSatExprFloat (Case scrut bndr alts)
- = coreSatExprFloat scrut `thenUs` \ (floats, scrut) ->
- mapUs sat_alt alts `thenUs` \ alts ->
- returnUs (floats, mkCase scrut bndr alts)
+corePrepExprFloat env (Case scrut bndr alts)
+ = corePrepExprFloat env scrut `thenUs` \ (floats, scrut') ->
+ cloneBndr env bndr `thenUs` \ (env', bndr') ->
+ mapUs (sat_alt env') alts `thenUs` \ alts' ->
+ returnUs (floats, mkCase scrut' bndr' alts')
where
- sat_alt (con, bs, rhs)
- = coreSatAnExpr rhs `thenUs` \ rhs ->
- deLam rhs `thenUs` \ rhs ->
- returnUs (con, bs, rhs)
-
-coreSatExprFloat expr@(App _ _)
- = collect_args expr 0 `thenUs` \ (app,(head,depth),ty,floats,ss) ->
+ sat_alt env (con, bs, rhs)
+ = cloneBndrs env bs `thenUs` \ (env', bs') ->
+ corePrepAnExpr env' rhs `thenUs` \ rhs1 ->
+ deLam rhs1 `thenUs` \ rhs2 ->
+ returnUs (con, bs', rhs2)
+
+corePrepExprFloat env expr@(App _ _)
+ = collect_args expr 0 `thenUs` \ (app, (head,depth), ty, floats, ss) ->
ASSERT(null ss) -- make sure we used all the strictness info
-- Now deal with the function
(ss1, ss_rest) = case ss of
(ss1:ss_rest) -> (ss1, ss_rest)
[] -> (wwLazy, [])
- (arg_ty, res_ty) = expectJust "coreSatExprFloat:collect_args" $
+ (arg_ty, res_ty) = expectJust "corePrepExprFloat:collect_args" $
splitFunTy_maybe fun_ty
in
- coreSatArg arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
+ corePrepArg env arg (mkDemTy ss1 arg_ty) `thenUs` \ (fs, arg') ->
returnUs (App fun' arg', hd, res_ty, fs `appOL` floats, ss_rest)
collect_args (Var v) depth
- = returnUs (Var v, (Var v, depth), idType v, nilOL, stricts)
+ = fiddleCCall v `thenUs` \ v1 ->
+ let v2 = lookupVarEnv env v1 `orElse` v1 in
+ returnUs (Var v2, (Var v2, depth), idType v2, nilOL, stricts)
where
stricts = case idStrictness v of
StrictnessInfo demands _
-- If depth < length demands, then we have too few args to
-- satisfy strictness info so we have to ignore all the
-- strictness info, e.g. + (error "urk")
- -- Here, we can't evaluate the arg strictly, because this
- -- partial application might be seq'd
+ -- Here, we can't evaluate the arg strictly, because this
+ -- partial application might be seq'd
+
collect_args (Note (Coerce ty1 ty2) fun) depth
= collect_args fun depth `thenUs` \ (fun', hd, fun_ty, floats, ss) ->
-- non-variable fun, better let-bind it
collect_args fun depth
- = coreSatExprFloat fun `thenUs` \ (fun_floats, fun) ->
+ = corePrepExprFloat env fun `thenUs` \ (fun_floats, fun) ->
newVar ty `thenUs` \ fn_id ->
mkNonRec fn_id onceDem fun_floats fun `thenUs` \ floats ->
returnUs (Var fn_id, (Var fn_id, depth), ty, floats, [])
-- we don't ignore SCCs, since they require some code generation
------------------------------------------------------------------------------
--- Generating new binders
--- ---------------------------------------------------------------------------
-
-newVar :: Type -> UniqSM Id
-newVar ty
- = getUniqueUs `thenUs` \ uniq ->
- seqType ty `seq`
- returnUs (mkSysLocal SLIT("sat") uniq ty)
-
-cloneTyVar :: TyVar -> UniqSM TyVar
-cloneTyVar tv
- = getUniqueUs `thenUs` \ uniq ->
- returnUs (setTyVarUnique tv uniq)
-
-------------------------------------------------------------------------------
-- Building the saturated syntax
-- ---------------------------------------------------------------------------
maybeSaturate :: Id -> CoreExpr -> Int -> Type -> UniqSM CoreExpr
maybeSaturate fn expr n_args ty
| hasNoBinding fn = saturate_it
- | otherwise = returnUs expr
+ | otherwise = returnUs expr
where
fn_arity = idArity fn
excess_arity = fn_arity - n_args
-- Precipitating the floating bindings
-- ---------------------------------------------------------------------------
--- mkNonRec is used for local bindings only, not top level
+-- mkNonRec is used for both top level and local bindings
mkNonRec :: Id -> RhsDemand -- Lhs: id with demand
-> OrdList FloatingBind -> CoreExpr -- Rhs: let binds in body
-> UniqSM (OrdList FloatingBind)
-- then the strictness analyser may say that f has strictness "S"
-- Later the eta expander will transform to
-- f x y = case x of { (a,b) -> a }
- -- So now f has arity 2. Now CoreSat may see
+ -- So now f has arity 2. Now CorePrep may see
-- v = f E
-- so the E argument will turn into a FloatCase.
-- Indeed we should end up with
-- v = case E of { r -> f r }
-- That is, we should not float, even though (f r) is a value
+ --
+ -- Similarly, given
+ -- v = f (x `divInt#` y)
+ -- we don't want to float the case, even if f has arity 2,
+ -- because floating the case would make it evaluated too early
returnUs (floats `snocOL` FloatLet (NonRec bndr rhs))
| isUnLiftedType bndr_rep_ty || isStrictDem dem
+ -- It's a strict let, or the binder is unlifted,
+ -- so we definitely float all the bindings
= ASSERT( not (isUnboxedTupleType bndr_rep_ty) )
returnUs (floats `snocOL` FloatCase bndr rhs)
| otherwise
+ -- Don't float
= mkBinds floats rhs `thenUs` \ rhs' ->
returnUs (unitOL (FloatLet (NonRec bndr rhs')))
-- we can't eta reduce something which must be saturated.
ok_to_eta_reduce (Var f) = not (hasNoBinding f)
- ok_to_eta_reduce _ = False --safe. ToDo: generalise
+ ok_to_eta_reduce _ = False --safe. ToDo: generalise
tryEta bndrs (Let bind@(NonRec b r) body)
| not (any (`elemVarSet` fvs) bndrs)
mkCase scrut@(Var fn `App` Type ty `App` arg) bndr alts
= case isPrimOpId_maybe fn of
Just ParOp -> Case scrut bndr [deflt_alt]
- Just SeqOp ->
- Case arg new_bndr [deflt_alt]
+ Just SeqOp -> Case arg new_bndr [deflt_alt]
other -> Case scrut bndr alts
where
(deflt_alt@(_,_,rhs) : _) = [alt | alt@(DEFAULT,_,_) <- alts]
\end{code}
+
+
+%************************************************************************
+%* *
+\subsection{Cloning}
+%* *
+%************************************************************************
+
+\begin{code}
+------------------------------------------------------------------------------
+-- Cloning binders
+-- ---------------------------------------------------------------------------
+
+cloneBndrs :: CloneEnv -> [Var] -> UniqSM (CloneEnv, [Var])
+cloneBndrs env bs = mapAccumLUs cloneBndr env bs
+
+cloneBndr :: CloneEnv -> Var -> UniqSM (CloneEnv, Var)
+cloneBndr env bndr
+ | isId bndr && isLocalId bndr -- Top level things, which we don't want
+ -- to clone, have become ConstantIds by now
+ = getUniqueUs `thenUs` \ uniq ->
+ let
+ bndr' = setVarUnique bndr uniq
+ in
+ returnUs (extendVarEnv env bndr bndr', bndr')
+
+ | otherwise = returnUs (env, bndr)
+
+------------------------------------------------------------------------------
+-- Cloning ccall Ids; each must have a unique name,
+-- to give the code generator a handle to hang it on
+-- ---------------------------------------------------------------------------
+
+fiddleCCall :: Id -> UniqSM Id
+fiddleCCall id
+ = case globalIdDetails id of
+ PrimOpId (CCallOp ccall) ->
+ -- Make a guaranteed unique name for a dynamic ccall.
+ getUniqueUs `thenUs` \ uniq ->
+ returnUs (setGlobalIdDetails id
+ (PrimOpId (CCallOp (setCCallUnique ccall uniq))))
+ other -> returnUs id
+
+------------------------------------------------------------------------------
+-- Generating new binders
+-- ---------------------------------------------------------------------------
+
+newVar :: Type -> UniqSM Id
+newVar ty
+ = getUniqueUs `thenUs` \ uniq ->
+ seqType ty `seq`
+ returnUs (mkSysLocal SLIT("sat") uniq ty)
+\end{code}
import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
-import CoreUtils ( exprArity )
-import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars, ruleSomeLhsFreeVars )
+import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars,
+ ruleSomeLhsFreeVars )
import CoreLint ( showPass, endPass )
import VarEnv
import VarSet
-import Var ( Id, Var, varName, globalIdDetails, setGlobalIdDetails )
-import Id ( idType, idInfo, idName, isExportedId, idSpecialisation,
- idCafInfo, mkVanillaGlobal, isLocalId, isImplicitId,
- modifyIdInfo, idArity, hasNoBinding, mkLocalIdWithInfo
+import Var ( Id, Var, varName )
+import Id ( idType, idInfo, idName, isExportedId,
+ idSpecialisation, idUnique,
+ mkVanillaGlobal, isLocalId, isImplicitId,
+ hasNoBinding, mkUserLocal
)
import IdInfo {- loads of stuff -}
import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
- localiseName, mkLocalName, isGlobalName, isDllName, isLocalName
+ localiseName, isGlobalName, isLocalName
)
import NameEnv ( filterNameEnv )
import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
import Type ( tidyTopType, tidyType, tidyTyVar )
import Module ( Module, moduleName )
-import PrimOp ( PrimOp(..), setCCallUnique )
import HscTypes ( PersistentCompilerState( pcs_PRS ),
PersistentRenamerState( prsOrig ),
NameSupply( nsNames ), OrigNameCache,
TypeEnv, extendTypeEnvList,
- DFunId, ModDetails(..), TyThing(..)
+ ModDetails(..), TyThing(..)
)
-import UniqSupply
-import DataCon ( DataCon, dataConName )
-import Literal ( isLitLitLit )
import FiniteMap ( lookupFM, addToFM )
import Maybes ( maybeToBool, orElse )
import ErrUtils ( showPass )
-import PprCore ( pprIdCoreRule )
import SrcLoc ( noSrcLoc )
import UniqFM ( mapUFM )
-import Outputable
-import FastTypes
import List ( partition )
import Util ( mapAccumL )
+import Outputable
\end{code}
- Give external Ids the same Unique as they had before
if the name is in the renamer's name cache
- - Clone all local Ids. This means that Tidy Core has the property
- that all Ids are unique, rather than the weaker guarantee of
- no clashes which the simplifier provides.
-
- - Give each dynamic CCall occurrence a fresh unique; this is
- rather like the cloning step above.
-
- Give the Id its UTTERLY FINAL IdInfo; in ptic,
* Its IdDetails becomes VanillaGlobal, reflecting the fact that
from now on we regard it as a global, not local, Id
\begin{code}
tidyCorePgm :: DynFlags -> Module
-> PersistentCompilerState
- -> TypeEnv -> [DFunId]
- -> [CoreBind] -> [IdCoreRule]
- -> IO (PersistentCompilerState, [CoreBind], ModDetails)
-
-tidyCorePgm dflags mod pcs env_tc insts_tc binds_in orphans_in
+ -> 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_ids = findExternalSet binds_in orphans_in
+ ; let ext_rules = findExternalRules binds_in orphans_in ext_ids
- ; us <- mkSplitUniqSupply 't' -- for "tidy"
+ ; let ((orig_env', occ_env, subst_env), tidy_binds)
+ = mapAccumL (tidyTopBind mod ext_ids cg_info_env)
+ init_tidy_env binds_in
- ; let ((us1, orig_env', occ_env, subst_env), tidy_binds)
- = mapAccumL (tidyTopBind mod ext_ids)
- (init_tidy_env us) binds_in
-
- ; let (orphans_out, _)
- = initUs us1 (tidyIdRules (occ_env,subst_env) orphans_in)
+ ; let tidy_rules = tidyIdRules (occ_env,subst_env) ext_rules
; let prs' = prs { prsOrig = orig { nsNames = orig_env' } }
pcs' = pcs { pcs_PRS = prs' }
pprPanic "lookup_dfun_id" (ppr id)
- ; let final_rules = mkFinalRules orphans_out final_ids
- final_type_env = mkFinalTypeEnv env_tc final_ids
- final_dfun_ids = map lookup_dfun_id insts_tc
+ ; let tidy_type_env = mkFinalTypeEnv env_tc final_ids
+ tidy_dfun_ids = map lookup_dfun_id insts_tc
- ; let new_details = ModDetails { md_types = final_type_env,
- md_rules = final_rules,
- md_insts = final_dfun_ids }
+ ; let tidy_details = ModDetails { md_types = tidy_type_env,
+ md_rules = tidy_rules,
+ md_insts = tidy_dfun_ids,
+ md_binds = tidy_binds }
; endPass dflags "Tidy Core" Opt_D_dump_simpl tidy_binds
- ; return (pcs', tidy_binds, new_details)
+ ; return (pcs', tidy_details)
}
where
-- We also make sure to avoid any exported binders. Consider
orig = prsOrig prs
orig_env = nsNames orig
- init_tidy_env us = (us, orig_env, initTidyOccEnv avoids, emptyVarEnv)
+ init_tidy_env = (orig_env, initTidyOccEnv avoids, emptyVarEnv)
avoids = [getOccName bndr | bndr <- bindersOfBinds binds_in,
isGlobalName (idName bndr)]
-
tidyCoreExpr :: CoreExpr -> IO CoreExpr
-tidyCoreExpr expr
- = do { us <- mkSplitUniqSupply 't' -- for "tidy"
- ; let (expr',_) = initUs us (tidyExpr emptyTidyEnv expr)
- ; return expr'
- }
+tidyCoreExpr expr = return (tidyExpr emptyTidyEnv expr)
\end{code}
\end{code}
\begin{code}
-mkFinalRules :: [IdCoreRule] -- Orphan rules
- -> [Id] -- Ids that are exported, so we need their rules
- -> [IdCoreRule]
+findExternalRules :: [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
-mkFinalRules orphan_rules emitted
+findExternalRules binds orphan_rules ext_ids
| opt_OmitInterfacePragmas = []
| otherwise
= orphan_rules ++ local_rules
where
- local_rules = [ (fn, rule)
- | fn <- emitted,
- rule <- rulesRules (idSpecialisation fn),
+ local_rules = [ (id, rule)
+ | id <- bindersOfBinds binds,
+ id `elemVarEnv` ext_ids,
+ rule <- rulesRules (idSpecialisation id),
not (isBuiltinRule rule),
-- We can't print builtin rules in interface files
-- Since they are built in, an importing module
-- will have access to them anyway
- -- Sept 00: I've disabled this test. It doesn't stop many, if any, rules
- -- from coming out, and to make it work properly we need to add ????
+ -- Sept 00: I've disabled this test. It doesn't stop
+ -- many, if any, rules from coming out, and to make it
+ -- work properly we need to add ????
-- (put it back in for now)
isEmptyVarSet (ruleSomeLhsFreeVars (isLocalName . varName) rule)
- -- Spit out a rule only if none of its LHS free vars are
- -- LocalName things i.e. things that aren't visible to importing modules
- -- This is a good reason not to do it when we emit the Id itself
- ]
-\end{code}
+ -- Spit out a rule only if none of its LHS free
+ -- vars are LocalName things i.e. things that
+ -- aren't visible to importing modules This is a
+ -- good reason not to do it when we emit the Id
+ -- itself
+ ]
+\end{code}
%************************************************************************
%* *
\begin{code}
findExternalSet :: [CoreBind] -> [IdCoreRule]
- -> IdEnv Bool -- True <=> show unfolding
+ -> IdEnv Bool -- In domain => external
+ -- Range = True <=> show unfolding
-- Step 1 from the notes above
findExternalSet binds orphan_rules
= foldr find init_needed binds
\begin{code}
-type TopTidyEnv = (UniqSupply, OrigNameCache, TidyOccEnv, VarEnv Var)
+type TopTidyEnv = (OrigNameCache, TidyOccEnv, VarEnv Var)
-- TopTidyEnv: when tidying we need to know
-- * orig_env: Any pre-ordained Names. These may have arisen because the
-- are 'used'
--
-- * subst_env: A Var->Var mapping that substitutes the new Var for the old
---
--- * uniqsuppy: so we can clone any Ids with non-preordained names.
---
\end{code}
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 env (NonRec bndr rhs)
- = ((us2,orig,occ,subst) , NonRec bndr' rhs')
+tidyTopBind mod ext_ids cg_info_env top_tidy_env (NonRec bndr rhs)
+ = ((orig,occ,subst) , NonRec bndr' rhs')
where
- ((us1,orig,occ,subst), bndr')
- = tidyTopBinder mod ext_ids tidy_env rhs' caf_info env bndr
- tidy_env = (occ,subst)
- caf_info = hasCafRefs (const True) rhs'
- (rhs',us2) = initUs us1 (tidyExpr tidy_env rhs)
+ ((orig,occ,subst), bndr')
+ = tidyTopBinder mod ext_ids cg_info_env rec_tidy_env rhs' top_tidy_env bndr
+ rec_tidy_env = (occ,subst)
+ rhs' = tidyExpr rec_tidy_env rhs
-tidyTopBind mod ext_ids env (Rec prs)
+tidyTopBind mod ext_ids cg_info_env top_tidy_env (Rec prs)
= (final_env, Rec prs')
where
- (final_env@(_,_,occ,subst), prs') = mapAccumL do_one env prs
- final_tidy_env = (occ,subst)
+ (final_env@(_,occ,subst), prs') = mapAccumL do_one top_tidy_env prs
+ rec_tidy_env = (occ,subst)
- do_one env (bndr,rhs)
- = ((us',orig,occ,subst), (bndr',rhs'))
+ do_one top_tidy_env (bndr,rhs)
+ = ((orig,occ,subst), (bndr',rhs'))
where
- ((us,orig,occ,subst), bndr')
- = tidyTopBinder mod ext_ids final_tidy_env rhs' caf_info env bndr
- (rhs', us') = initUs us (tidyExpr final_tidy_env rhs)
+ ((orig,occ,subst), bndr')
+ = tidyTopBinder mod ext_ids cg_info_env
+ rec_tidy_env rhs' top_tidy_env bndr
+
+ rhs' = tidyExpr rec_tidy_env rhs
-- the CafInfo for a recursive group says whether *any* rhs in
-- the group may refer indirectly to a CAF (because then, they all do).
(bndrs, rhss) = unzip prs'
- caf_info = hasCafRefss pred rhss
pred v = v `notElem` bndrs
tidyTopBinder :: Module -> IdEnv Bool
- -> TidyEnv -> CoreExpr -> CafInfo
+ -> CgInfoEnv
+ -> TidyEnv -> CoreExpr
-- The TidyEnv is used to tidy the IdInfo
-- The expr is the already-tided RHS
-- 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 tidy_env rhs caf_info
- env@(us, orig_env2, occ_env2, subst_env2) id
+tidyTopBinder mod ext_ids cg_info_env tidy_env rhs
+ env@(orig_env2, occ_env2, subst_env2) id
| isImplicitId id -- Don't mess with constructors,
= (env, id) -- record selectors, and the like
-- The rhs is already tidied
- = ((us_r, orig_env', occ_env', subst_env'), id')
+ = ((orig_env', occ_env', subst_env'), id')
where
- (us_l, us_r) = splitUniqSupply us
-
(orig_env', occ_env', name') = tidyTopName mod orig_env2 occ_env2
is_external
(idName id)
- ty' = tidyTopType (idType id)
- idinfo' = tidyIdInfo us_l tidy_env
- is_external unfold_info arity_info caf_info id
+ ty' = tidyTopType (idType id)
+ cg_info = lookupCgInfo cg_info_env name'
+ idinfo' = tidyIdInfo tidy_env is_external unfold_info cg_info id
id' = mkVanillaGlobal name' ty' idinfo'
subst_env' = extendVarEnv subst_env2 id id'
unfold_info | show_unfold = mkTopUnfolding rhs
| otherwise = noUnfolding
- arity_info = exprArity rhs
-
-tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
+tidyIdInfo tidy_env is_external unfold_info cg_info id
| opt_OmitInterfacePragmas || not is_external
-- No IdInfo if the Id isn't external, or if we don't have -O
= vanillaIdInfo
- `setCafInfo` caf_info
+ `setCgInfo` cg_info
`setStrictnessInfo` strictnessInfo core_idinfo
- `setArityInfo` ArityExactly arity_info
- -- Keep strictness, arity and CAF info; it's used by the code generator
+ -- Keep strictness; it's used by CorePrep
| otherwise
- = let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
- in
- vanillaIdInfo
- `setCafInfo` caf_info
+ = vanillaIdInfo
+ `setCgInfo` cg_info
`setCprInfo` cprInfo core_idinfo
`setStrictnessInfo` strictnessInfo core_idinfo
`setInlinePragInfo` inlinePragInfo core_idinfo
`setUnfoldingInfo` unfold_info
- `setWorkerInfo` tidyWorker tidy_env arity_info (workerInfo core_idinfo)
- `setSpecInfo` rules'
- `setArityInfo` ArityExactly arity_info
- -- this is the final IdInfo, it must agree with the
- -- code finally generated (i.e. NO more transformations
- -- after this!).
+ `setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo)
+ -- NB: we throw away the Rules
+ -- They have already been extracted by findExternalRules
where
core_idinfo = idInfo id
+
-- 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
internal = not external
------------ Worker --------------
--- We only treat a function as having a worker if
--- the exported arity (which is now the number of visible lambdas)
--- is the same as the arity at the moment of the w/w split
--- If so, we can safely omit the unfolding inside the wrapper, and
--- instead re-generate it from the type/arity/strictness info
--- But if the arity has changed, we just take the simple path and
--- put the unfolding into the interface file, forgetting the fact
--- that it's a wrapper.
---
--- How can this happen? Sometimes we get
--- f = coerce t (\x y -> $wf x y)
--- at the moment of w/w split; but the eta reducer turns it into
--- f = coerce t $wf
--- which is perfectly fine except that the exposed arity so far as
--- the code generator is concerned (zero) differs from the arity
--- when we did the split (2).
---
--- All this arises because we use 'arity' to mean "exactly how many
--- top level lambdas are there" in interface files; but during the
--- compilation of this module it means "how many things can I apply
--- this to".
-tidyWorker tidy_env real_arity (HasWorker work_id wrap_arity)
- | real_arity == wrap_arity
+tidyWorker tidy_env (HasWorker work_id wrap_arity)
= HasWorker (tidyVarOcc tidy_env work_id) wrap_arity
-tidyWorker tidy_env real_arity other
+tidyWorker tidy_env other
= NoWorker
------------ Rules --------------
-tidyIdRules :: TidyEnv -> [IdCoreRule] -> UniqSM [IdCoreRule]
-tidyIdRules env [] = returnUs []
+tidyIdRules :: TidyEnv -> [IdCoreRule] -> [IdCoreRule]
+tidyIdRules env [] = []
tidyIdRules env ((fn,rule) : rules)
- = tidyRule env rule `thenUs` \ rule ->
- tidyIdRules env rules `thenUs` \ rules ->
- returnUs ((tidyVarOcc env fn, rule) : rules)
-
-tidyRules :: TidyEnv -> CoreRules -> UniqSM CoreRules
-tidyRules env (Rules rules fvs)
- = mapUs (tidyRule env) rules `thenUs` \ rules ->
- returnUs (Rules rules (foldVarSet tidy_set_elem emptyVarSet fvs))
- where
- tidy_set_elem var new_set = extendVarSet new_set (tidyVarOcc env var)
+ = tidyRule env rule =: \ rule ->
+ tidyIdRules env rules =: \ rules ->
+ ((tidyVarOcc env fn, rule) : rules)
-tidyRule :: TidyEnv -> CoreRule -> UniqSM CoreRule
-tidyRule env rule@(BuiltinRule _) = returnUs rule
+tidyRule :: TidyEnv -> CoreRule -> CoreRule
+tidyRule env rule@(BuiltinRule _) = rule
tidyRule env (Rule name vars tpl_args rhs)
- = tidyBndrs env vars `thenUs` \ (env', vars) ->
- mapUs (tidyExpr env') tpl_args `thenUs` \ tpl_args ->
- tidyExpr env' rhs `thenUs` \ rhs ->
- returnUs (Rule name vars tpl_args rhs)
+ = tidyBndrs env vars =: \ (env', vars) ->
+ map (tidyExpr env') tpl_args =: \ tpl_args ->
+ (Rule name vars tpl_args (tidyExpr env' rhs))
\end{code}
%************************************************************************
\begin{code}
tidyBind :: TidyEnv
-> CoreBind
- -> UniqSM (TidyEnv, CoreBind)
+ -> (TidyEnv, CoreBind)
+
tidyBind env (NonRec bndr rhs)
- = tidyBndrWithRhs env (bndr,rhs) `thenUs` \ (env', bndr') ->
- tidyExpr env' rhs `thenUs` \ rhs' ->
- returnUs (env', NonRec bndr' rhs')
+ = tidyBndrWithRhs env (bndr,rhs) =: \ (env', bndr') ->
+ (env', NonRec bndr' (tidyExpr env' rhs))
tidyBind env (Rec prs)
- = mapAccumLUs tidyBndrWithRhs env prs `thenUs` \ (env', bndrs') ->
- mapUs (tidyExpr env') (map snd prs) `thenUs` \ rhss' ->
- returnUs (env', Rec (zip bndrs' rhss'))
-
-tidyExpr env (Var v)
- = fiddleCCall v `thenUs` \ v ->
- returnUs (Var (tidyVarOcc env v))
+ = mapAccumL tidyBndrWithRhs env prs =: \ (env', bndrs') ->
+ map (tidyExpr env') (map snd prs) =: \ rhss' ->
+ (env', Rec (zip bndrs' rhss'))
-tidyExpr env (Type ty) = returnUs (Type (tidyType env ty))
-tidyExpr env (Lit lit) = returnUs (Lit lit)
-tidyExpr env (App f a)
- = tidyExpr env f `thenUs` \ f ->
- tidyExpr env a `thenUs` \ a ->
- returnUs (App f a)
-
-tidyExpr env (Note n e)
- = tidyExpr env e `thenUs` \ e ->
- returnUs (Note (tidyNote env n) e)
+tidyExpr env (Var v) = Var (tidyVarOcc env v)
+tidyExpr env (Type ty) = Type (tidyType env ty)
+tidyExpr env (Lit lit) = Lit lit
+tidyExpr env (App f a) = App (tidyExpr env f) (tidyExpr env a)
+tidyExpr env (Note n e) = Note (tidyNote env n) (tidyExpr env e)
tidyExpr env (Let b e)
- = tidyBind env b `thenUs` \ (env', b') ->
- tidyExpr env' e `thenUs` \ e ->
- returnUs (Let b' e)
+ = tidyBind env b =: \ (env', b') ->
+ Let b' (tidyExpr env' e)
tidyExpr env (Case e b alts)
- = tidyExpr env e `thenUs` \ e ->
- tidyBndr env b `thenUs` \ (env', b) ->
- mapUs (tidyAlt env') alts `thenUs` \ alts ->
- returnUs (Case e b alts)
+ = tidyBndr env b =: \ (env', b) ->
+ Case (tidyExpr env e) b (map (tidyAlt env') alts)
tidyExpr env (Lam b e)
- = tidyBndr env b `thenUs` \ (env', b) ->
- tidyExpr env' e `thenUs` \ e ->
- returnUs (Lam b e)
+ = tidyBndr env b =: \ (env', b) ->
+ Lam b (tidyExpr env' e)
tidyAlt env (con, vs, rhs)
- = tidyBndrs env vs `thenUs` \ (env', vs) ->
- tidyExpr env' rhs `thenUs` \ rhs ->
- returnUs (con, vs, rhs)
+ = tidyBndrs env vs =: \ (env', vs) ->
+ (con, vs, tidyExpr env' rhs)
tidyNote env (Coerce t1 t2) = Coerce (tidyType env t1) (tidyType env t2)
tidyNote env note = note
Nothing -> v
-- tidyBndr is used for lambda and case binders
-tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var)
+tidyBndr :: TidyEnv -> Var -> (TidyEnv, Var)
tidyBndr env var
- | isTyVar var = returnUs (tidyTyVar env var)
- | otherwise = tidyId env var noCafIdInfo
+ | isTyVar var = tidyTyVar env var
+ | otherwise = tidyId env var
-tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var])
-tidyBndrs env vars = mapAccumLUs tidyBndr env vars
+tidyBndrs :: TidyEnv -> [Var] -> (TidyEnv, [Var])
+tidyBndrs env vars = mapAccumL tidyBndr env vars
-- tidyBndrWithRhs is used for let binders
-tidyBndrWithRhs :: TidyEnv -> (Var, CoreExpr) -> UniqSM (TidyEnv, Var)
-tidyBndrWithRhs env (id,rhs)
- = tidyId env id idinfo
- where
- idinfo = noCafIdInfo `setArityInfo` ArityExactly (exprArity rhs)
- -- NB: This throws away the IdInfo of the Id, which we
- -- no longer need. That means we don't need to
- -- run over it with env, nor renumber it.
-
-tidyId :: TidyEnv -> Id -> IdInfo -> UniqSM (TidyEnv, Id)
-tidyId env@(tidy_env, var_env) id idinfo
+tidyBndrWithRhs :: TidyEnv -> (Id, CoreExpr) -> (TidyEnv, Var)
+tidyBndrWithRhs env (id,rhs) = tidyId env id
+
+tidyId :: TidyEnv -> Id -> (TidyEnv, Id)
+tidyId env@(tidy_env, var_env) id
= -- Non-top-level variables
- getUniqueUs `thenUs` \ uniq ->
let
-- Give the Id a fresh print-name, *and* rename its type
-- The SrcLoc isn't important now,
-- though we could extract it from the Id
- name' = mkLocalName uniq occ' noSrcLoc
+ --
+ -- All local Ids now have the same IdInfo, which should save some
+ -- space.
(tidy_env', occ') = tidyOccName tidy_env (getOccName id)
ty' = tidyType (tidy_env,var_env) (idType id)
- id' = mkLocalIdWithInfo name' ty' idinfo
+ id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc
var_env' = extendVarEnv var_env id id'
in
- returnUs ((tidy_env', var_env'), id')
-
-
-fiddleCCall id
- = case globalIdDetails id of
- PrimOpId (CCallOp ccall) ->
- -- Make a guaranteed unique name for a dynamic ccall.
- getUniqueUs `thenUs` \ uniq ->
- returnUs (setGlobalIdDetails id
- (PrimOpId (CCallOp (setCCallUnique ccall uniq))))
- other -> returnUs id
+ ((tidy_env', var_env'), id')
\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 :: (Id -> Bool) -> CoreExpr -> CafInfo
--- Only called for the RHS of top-level lets
-hasCafRefss :: (Id -> Bool) -> [CoreExpr] -> CafInfo
- -- predicate returns True for a given Id if we look at this Id when
- -- calculating the result. Used to *avoid* looking at the CafInfo
- -- field for an Id that is part of the current recursive group.
-
-hasCafRefs p expr = if isCAF expr || isFastTrue (cafRefs p expr)
- then MayHaveCafRefs
- else NoCafRefs
-
- -- used for recursive groups. The whole group is set to
- -- "MayHaveCafRefs" if at least one of the group is a CAF or
- -- refers to any CAFs.
-hasCafRefss p exprs = if any isCAF exprs || isFastTrue (cafRefss p exprs)
- then MayHaveCafRefs
- else NoCafRefs
-
-cafRefs p (Var id)
- | p id
- = case idCafInfo id of
- NoCafRefs -> fastBool False
- MayHaveCafRefs -> fastBool True
- | otherwise
- = fastBool False
-
-cafRefs p (Lit l) = fastBool False
-cafRefs p (App f a) = cafRefs p f `fastOr` cafRefs p a
-cafRefs p (Lam x e) = cafRefs p e
-cafRefs p (Let b e) = cafRefss p (rhssOfBind b) `fastOr` cafRefs p e
-cafRefs p (Case e bndr alts) = cafRefs p e `fastOr` 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) = cafRefs p e `fastOr` cafRefss p es
-
-
-isCAF :: CoreExpr -> Bool
--- Only called for the RHS of top-level lets
-isCAF e = not (rhsIsNonUpd e)
- {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
-
-rhsIsNonUpd :: 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
-
-rhsIsNonUpd (Lam b e) = isId 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
- = case globalIdDetails id of
- DataConId con | not (isDynConApp con args) -> True
- other -> n_val_args < idArity id
-
-isDynConApp :: DataCon -> [CoreExpr] -> Bool
-isDynConApp con args = isDllName (dataConName con) || any isDynArg 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.coreToStgRhs)
-
-
-isDynArg :: CoreExpr -> Bool
-isDynArg (Var v) = isDllName (idName v)
-isDynArg (Note _ e) = isDynArg e
-isDynArg (Lit lit) = isLitLitLit lit
-isDynArg (App e _) = isDynArg e -- must be a type app
-isDynArg (Lam _ e) = isDynArg e -- must be a type lam
+m =: k = m `seq` k m
\end{code}
import IdInfo ( IdInfo, megaSeqIdInfo,
arityInfo, ppArityInfo,
specInfo, cprInfo, ppCprInfo,
- strictnessInfo, ppStrictnessInfo, cafInfo, ppCafInfo,
+ strictnessInfo, ppStrictnessInfo, cgInfo, pprCgInfo,
cprInfo, ppCprInfo,
workerInfo, ppWorkerInfo,
tyGenInfo, ppTyGenInfo
ppTyGenInfo g,
ppWorkerInfo (workerInfo info),
ppStrictnessInfo s,
- ppCafInfo c,
+-- pprCgInfo c,
ppCprInfo m,
pprCoreRules b p
-- Inline pragma, occ, demand, lbvar info
a = arityInfo info
g = tyGenInfo info
s = strictnessInfo info
- c = cafInfo info
+ c = cgInfo info
m = cprInfo info
p = specInfo info
\end{code}
#include "HsVersions.h"
import CmdLineOpts ( DynFlags, DynFlag(..), dopt, opt_SccProfilingOn )
+import HscTypes ( ModDetails(..) )
import HsSyn ( MonoBinds, RuleDecl(..), RuleBndr(..),
HsExpr(..), HsBinds(..), MonoBinds(..) )
import TcHsSyn ( TypecheckedRuleDecl, TypecheckedHsExpr )
-> PersistentCompilerState -> HomeSymbolTable
-> Module -> PrintUnqualified
-> TcResults
- -> IO ([CoreBind], [(Id,CoreRule)], (SDoc, SDoc, [CoreBndr]))
+ -> IO (ModDetails, (SDoc, SDoc, [CoreBndr]))
deSugar dflags pcs hst mod_name unqual
- (TcResults {tc_env = local_type_env,
+ (TcResults {tc_env = type_env,
tc_binds = all_binds,
+ tc_insts = insts,
tc_rules = rules,
tc_fords = fo_decls})
= do { showPass dflags "Desugar"
; us <- mkSplitUniqSupply 'd'
-- Do desugaring
- ; let (result, ds_warns) = initDs dflags us lookup mod_name
- (dsProgram mod_name all_binds rules fo_decls)
- (ds_binds, ds_rules, _) = result
+ ; let (ds_result, ds_warns) = initDs dflags us lookup mod_name
+ (dsProgram mod_name all_binds rules fo_decls)
+
+ (ds_binds, ds_rules, foreign_stuff) = ds_result
+
+ mod_details = ModDetails { md_types = type_env,
+ md_insts = insts,
+ md_rules = ds_rules,
+ md_binds = ds_binds }
-- Display any warnings
; doIfSet (not (isEmptyBag ds_warns))
; doIfSet (dopt Opt_D_dump_ds dflags)
(printDump (ppr_ds_rules ds_rules))
- ; return result
+ ; return (mod_details, foreign_stuff)
}
where
lookup n = case lookupType hst pte n of {
Just (AnId v) -> v ;
other ->
- case lookupNameEnv local_type_env n of
+ case lookupNameEnv type_env n of
Just (AnId v) -> v ;
other -> pprPanic "Desugar: lookup:" (ppr n)
}
import DataCon ( dataConTyCon, dataConSourceArity )
import TyCon ( isTupleTyCon, tupleTyConBoxity )
import Type ( Kind )
+import BasicTypes ( Arity )
import FiniteMap ( lookupFM )
import CostCentre
import Outputable
pprHsIdInfo info = ptext SLIT("{-##") <+> hsep (map ppr_hs_info info) <+> ptext SLIT("##-}")
data HsIdInfo name
- = HsArity ArityInfo
+ = HsArity Arity
| HsStrictness StrictnessInfo
| HsUnfold InlinePragInfo (UfExpr name)
| HsNoCafRefs
| HsCprInfo
- | HsWorker name -- Worker, if any
+ | HsWorker name Arity -- Worker, if any see IdInfo.WorkerInfo
+ -- for why we want arity here.
deriving( Eq )
-- NB: Specialisations and rules come in separately and are
-- only later attached to the Id. Partial reason: some are orphans.
ppr_hs_info (HsUnfold prag unf) = ptext SLIT("__U") <> pprInlinePragInfo prag <+> parens (pprUfExpr noParens unf)
-ppr_hs_info (HsArity arity) = ppArityInfo arity
+ppr_hs_info (HsArity arity) = ptext SLIT("__A") <+> int arity
ppr_hs_info (HsStrictness str) = ptext SLIT("__S") <+> ppStrictnessInfo str
ppr_hs_info HsNoCafRefs = ptext SLIT("__C")
ppr_hs_info HsCprInfo = ptext SLIT("__M")
-ppr_hs_info (HsWorker w) = ptext SLIT("__P") <+> ppr w
+ppr_hs_info (HsWorker w a) = ptext SLIT("__P") <+> ppr w <+> int a
\end{code}
-----------------------------------------------------------------------------
--- $Id: DriverPhases.hs,v 1.6 2001/02/27 15:25:18 simonmar Exp $
+-- $Id: DriverPhases.hs,v 1.7 2001/03/13 12:50:31 simonmar Exp $
--
-- GHC Driver
--
= MkDependHS -- haskell dependency generation
| Unlit
| Cpp
- | Hsc
+ | Hsc -- ToDo: HscTargetLang
| Cc
| HCc -- Haskellised C (as opposed to vanilla C) compilation
-#ifdef ILX
- | Ilx -- .NET extended IL
-#endif
| Mangle -- assembly mangling, now done by a separate script.
| SplitMangle -- after mangler if splitting
| SplitAs
phaseInputExt Hsc = "hspp"
phaseInputExt HCc = "hc"
phaseInputExt Cc = "c"
-#ifdef ILX
-phaseInputExt Ilx = "ilx"
-#endif
phaseInputExt Mangle = "raw_s"
phaseInputExt SplitMangle = "split_s" -- not really generated
phaseInputExt As = "s"
printErrorsAndWarnings, pprBagOfErrors, pprBagOfWarnings,
+ printError,
ghcExit,
doIfSet, doIfSet_dyn,
dumpIfSet, dumpIfSet_core, dumpIfSet_dyn, dumpIfSet_dyn_or,
import CmdLineOpts ( DynFlags(..), DynFlag(..), dopt )
import System ( ExitCode(..), exitWith )
-import IO ( hPutStr, stderr )
+import IO ( hPutStr, hPutStrLn, stderr )
\end{code}
\begin{code}
\end{code}
+\begin{code}
+printError :: String -> IO ()
+printError str = hPutStrLn stderr str
+\end{code}
\begin{code}
type Messages = (Bag WarnMsg, Bag ErrMsg)
import Id ( Id, idName, setGlobalIdDetails )
import IdInfo ( GlobalIdDetails(VanillaGlobal) )
import HscTypes ( InteractiveContext(..), TyThing(..) )
+import PrelNames ( iINTERACTIVE )
+import CoreTidy ( tidyCoreExpr )
+import StringBuffer ( stringToStringBuffer )
#endif
import HsSyn
-import StringBuffer ( hGetStringBuffer,
- stringToStringBuffer, freeStringBuffer )
+import Id ( idName )
+import IdInfo ( CafInfo(..), CgInfoEnv, CgInfo(..) )
+import StringBuffer ( hGetStringBuffer, freeStringBuffer )
import Parser
import Lex ( PState(..), ParseResult(..) )
import SrcLoc ( mkSrcLoc )
import Rename ( checkOldIface, renameModule, closeIfaceDecls )
import Rules ( emptyRuleBase )
import PrelInfo ( wiredInThingEnv, wiredInThings )
-import PrelNames ( vanillaSyntaxMap, knownKeyNames, iNTERACTIVE )
+import PrelNames ( vanillaSyntaxMap, knownKeyNames )
import MkIface ( completeIface, writeIface, pprIface )
-import Type ( Type )
import TcModule
import InstEnv ( emptyInstEnv )
import Desugar
import SimplCore
import CoreUtils ( coreBindsSize )
import CoreTidy ( tidyCorePgm )
-import CoreSat
-import CoreTidy ( tidyCoreExpr )
+import CorePrep ( corePrepPgm )
+import StgSyn
import CoreToStg ( coreToStg )
import SimplStg ( stg2stg )
import CodeGen ( codeGen )
import Module ( ModuleName, moduleName, mkHomeModule,
moduleUserString )
import CmdLineOpts
-import ErrUtils ( dumpIfSet_dyn, showPass )
+import ErrUtils ( dumpIfSet_dyn, showPass, printError )
import Util ( unJust )
import UniqSupply ( mkSplitUniqSupply )
import Interpreter
import CmStaticInfo ( GhciMode(..) )
import HscStats ( ppSourceStats )
-import HscTypes ( ModDetails, ModIface(..), PersistentCompilerState(..),
- PersistentRenamerState(..), ModuleLocation(..),
- HomeSymbolTable,
- NameSupply(..), PackageRuleBase, HomeIfaceTable,
- typeEnvClasses, typeEnvTyCons, emptyIfaceTable
- )
+import HscTypes
import FiniteMap ( FiniteMap, plusFM, emptyFM, addToFM )
import OccName ( OccName )
import Name ( Name, nameModule, nameOccName, getName, isGlobalName )
-import NameEnv ( emptyNameEnv )
+import NameEnv ( emptyNameEnv, mkNameEnv )
import Module ( Module, lookupModuleEnvByName )
+import Maybes ( orElse )
+
+import IOExts ( newIORef, readIORef, writeIORef, unsafePerformIO )
import Monad ( when )
import Maybe ( isJust )
Nothing -> return (HscFail pcs_ch{-was: pcs_rn-});
Just (pcs_tc, tc_result) -> do {
- ; let env_tc = tc_env tc_result
- insts_tc = tc_insts tc_result
-
-------------------
-- DESUGAR
-------------------
- ; (ds_binds, ds_rules, foreign_stuff)
+ ; (ds_details, foreign_stuff)
<- _scc_ "DeSugar"
deSugar dflags pcs_tc hst this_mod print_unqualified tc_result
-------------------
-- SIMPLIFY
-------------------
- ; (simplified, orphan_rules)
+ ; simpl_details
<- _scc_ "Core2Core"
- core2core dflags pcs_tc hst dont_discard ds_binds ds_rules
+ core2core dflags pcs_tc hst dont_discard ds_details
-------------------
-- TIDY
-------------------
- ; (pcs_simpl, tidy_binds, new_details)
- <- tidyCorePgm dflags this_mod pcs_tc env_tc insts_tc
- simplified orphan_rules
+ ; 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_details)
+ <- tidyCorePgm dflags this_mod pcs_tc cg_info simpl_details
-------------------
- -- BUILD THE NEW ModDetails AND ModIface
+ -- PREPARE FOR CODE GENERATION
-------------------
- ; final_iface <- _scc_ "MkFinalIface"
- mkFinalIface ghci_mode dflags location
- maybe_checked_iface new_iface new_details
+ -- Do saturation and convert to A-normal form
+ ; prepd_details <- corePrepPgm dflags tidy_details
-------------------
-- CONVERT TO STG and COMPLETE CODE GENERATION
-------------------
- -- Do saturation and convert to A-normal form
- ; saturated <- coreSatPgm dflags tidy_binds
+ ; let
+ ModDetails{md_binds=binds, md_types=env_tc} = prepd_details
+
+ local_tycons = typeEnvTyCons env_tc
+ local_classes = typeEnvClasses env_tc
+
+ imported_module_names = map ideclName (hsModuleImports rdr_module)
+ imported_modules = map mod_name_to_Module imported_module_names
+
+ (h_code,c_code,fe_binders) = foreign_stuff
+
+ pit = pcs_PIT pcs_simpl
+
+ mod_name_to_Module :: ModuleName -> Module
+ mod_name_to_Module nm
+ = let str_mi = lookupModuleEnvByName hit nm `orElse`
+ lookupModuleEnvByName pit nm `orElse`
+ pprPanic "mod_name_to_Module: no hst or pst mapping for"
+ (ppr nm)
+ in mi_module str_mi
+
+ ; (maybe_stub_h_filename, maybe_stub_c_filename,
+ maybe_bcos, final_iface )
+ <- if toInterp
+ then do
+ ----------------- Generate byte code ------------------
+ (bcos,itbl_env) <- byteCodeGen dflags binds
+ local_tycons local_classes
+
+ -- Fill in the code-gen info
+ writeIORef cg_info_ref (Just emptyNameEnv)
+
+ ------------------ BUILD THE NEW ModIface ------------
+ final_iface <- _scc_ "MkFinalIface"
+ mkFinalIface ghci_mode dflags location
+ maybe_checked_iface new_iface tidy_details
+
+ return ( Nothing, Nothing,
+ Just (bcos,itbl_env), final_iface )
+
+ else do
+ ----------------- Convert to STG ------------------
+ (stg_binds, cost_centre_info, stg_back_end_info)
+ <- _scc_ "CoreToStg"
+ myCoreToStg dflags this_mod binds
+
+ -- Fill in the code-gen info for the earlier tidyCorePgm
+ writeIORef cg_info_ref (Just stg_back_end_info)
+
+ ------------------ BUILD THE NEW ModIface ------------
+ final_iface <- _scc_ "MkFinalIface"
+ mkFinalIface ghci_mode dflags location
+ maybe_checked_iface new_iface tidy_details
+
+ ------------------ Code generation ------------------
+ abstractC <- _scc_ "CodeGen"
+ codeGen dflags this_mod imported_modules
+ cost_centre_info fe_binders
+ local_tycons stg_binds
+
+ ------------------ Code output -----------------------
+ (maybe_stub_h_name, maybe_stub_c_name)
+ <- codeOutput dflags this_mod local_tycons
+ binds stg_binds
+ c_code h_code abstractC
+
+ return ( maybe_stub_h_name, maybe_stub_c_name,
+ Nothing, final_iface )
+
+ ; let final_details = tidy_details {md_binds = []}
- ; (maybe_stub_h_filename, maybe_stub_c_filename, maybe_bcos)
- <- restOfCodeGeneration dflags toInterp this_mod
- (map ideclName (hsModuleImports rdr_module))
- foreign_stuff env_tc saturated
- hit (pcs_PIT pcs_simpl)
-- and the answer is ...
- ; return (HscRecomp pcs_simpl new_details final_iface
+ ; return (HscRecomp pcs_simpl
+ final_details
+ final_iface
maybe_stub_h_filename maybe_stub_c_filename
maybe_bcos)
}}}}}}}
-mkFinalIface ghci_mode dflags location maybe_old_iface new_iface new_details
+mkFinalIface ghci_mode dflags location
+ maybe_old_iface new_iface new_details
= case completeIface maybe_old_iface new_iface new_details of
+
(new_iface, Nothing) -- no change in the interfacfe
-> do when (dopt Opt_D_dump_hi_diffs dflags)
(printDump (text "INTERFACE UNCHANGED"))
dumpIfSet_dyn dflags Opt_D_dump_hi
"UNCHANGED FINAL INTERFACE" (pprIface new_iface)
return new_iface
+
(new_iface, Just sdoc_diffs)
-> do dumpIfSet_dyn dflags Opt_D_dump_hi_diffs "INTERFACE HAS CHANGED"
sdoc_diffs
dumpIfSet_dyn dflags Opt_D_dump_hi "NEW FINAL INTERFACE"
(pprIface new_iface)
- -- Write the interface file
+
+ -- Write the interface file, if not in interactive mode
when (ghci_mode /= Interactive)
(writeIface (unJust "hscRecomp:hi" (ml_hi_file location))
new_iface)
}}
-restOfCodeGeneration dflags toInterp this_mod imported_module_names
- foreign_stuff env_tc tidy_binds
- hit pit -- these last two for mapping ModNames to Modules
- | toInterp
- = do (bcos,itbl_env)
- <- byteCodeGen dflags tidy_binds local_tycons local_classes
- return (Nothing, Nothing, Just (bcos,itbl_env))
-
- | otherwise
- = do
- -------------------------- Convert to STG -------------------------------
- (stg_binds, cost_centre_info)
- <- _scc_ "CoreToStg"
- myCoreToStg dflags this_mod tidy_binds env_tc
-
- -------------------------- Code generation ------------------------------
- abstractC <- _scc_ "CodeGen"
- codeGen dflags this_mod imported_modules
- cost_centre_info fe_binders
- local_tycons stg_binds
-
- -------------------------- Code output -------------------------------
- (maybe_stub_h_name, maybe_stub_c_name)
- <- codeOutput dflags this_mod local_tycons
- tidy_binds stg_binds
- c_code h_code abstractC
-
- return (maybe_stub_h_name, maybe_stub_c_name, Nothing)
- where
- local_tycons = typeEnvTyCons env_tc
- local_classes = typeEnvClasses env_tc
- imported_modules = map mod_name_to_Module imported_module_names
- (h_code,c_code,fe_binders) = foreign_stuff
-
- mod_name_to_Module :: ModuleName -> Module
- mod_name_to_Module nm
- = let str_mi = case lookupModuleEnvByName hit nm of
- Just mi -> mi
- Nothing -> case lookupModuleEnvByName pit nm of
- Just mi -> mi
- Nothing -> barf nm
- in mi_module str_mi
- barf nm = pprPanic "mod_name_to_Module: no hst or pst mapping for"
- (ppr nm)
-
-
-myCoreToStg dflags this_mod tidy_binds env_tc
+myCoreToStg dflags this_mod tidy_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
- --let bcos = byteCodeGen dflags tidy_binds local_tycons local_classes
-
-
- stg_binds <- _scc_ "Core2Stg" coreToStg dflags this_mod tidy_binds
+ stg_binds <- _scc_ "Core2Stg" coreToStg dflags tidy_binds
(stg_binds2, cost_centre_info)
<- _scc_ "Core2Stg" stg2stg dflags this_mod stg_binds
- return (stg_binds2, cost_centre_info)
+ let env_rhs :: CgInfoEnv
+ env_rhs = mkNameEnv [ (idName bndr, CgInfo (stgRhsArity rhs) caf_info)
+ | (bind,_) <- stg_binds2,
+ let caf_info
+ | stgBindHasCafRefs bind = MayHaveCafRefs
+ | otherwise = NoCafRefs,
+ (bndr,rhs) <- stgBindPairs bind ]
+
+ return (stg_binds2, cost_centre_info, env_rhs)
where
- local_tycons = typeEnvTyCons env_tc
- local_classes = typeEnvClasses env_tc
+ stgBindPairs (StgNonRec _ b r) = [(b,r)]
+ stgBindPairs (StgRec _ prs) = prs
\end{code}
)
import InstEnv ( InstEnv, ClsInstEnv, DFunId )
import Rules ( RuleBase )
+import CoreSyn ( CoreBind )
import Id ( Id )
import Class ( Class, classSelIds )
import TyCon ( TyCon, tyConGenIds, tyConSelIds, tyConDataConsIfAvailable )
-- The next three fields are created by the typechecker
md_types :: TypeEnv,
md_insts :: [DFunId], -- Dfun-ids for the instances in this module
- md_rules :: [IdCoreRule] -- Domain may include Ids from other modules
+ md_rules :: [IdCoreRule], -- Domain may include Ids from other modules
+ md_binds :: [CoreBind]
}
--- NOT YET IMPLEMENTED
-- The ModDetails takes on several slightly different forms:
--
-- After typecheck + desugar
--- md_types contains TyCons, Classes, and hasNoBinding Ids
--- md_insts all instances from this module (incl derived ones)
--- md_rules all rules from this module
--- md_binds desugared bindings
+-- md_types Contains TyCons, Classes, and hasNoBinding Ids
+-- md_insts All instances from this module (incl derived ones)
+-- md_rules All rules from this module
+-- md_binds Desugared bindings
--
-- After simplification
--- md_types same as after typecheck
--- md_insts ditto
--- md_rules orphan rules only (local ones attached to binds)
--- md_binds with rules attached
+-- md_types Same as after typecheck
+-- md_insts Ditto
+-- md_rules Orphan rules only (local ones now attached to binds)
+-- md_binds With rules attached
--
--- After tidy
--- md_types now contains Ids as well, replete with correct IdInfo
--- apart from
+-- After CoreTidy
+-- md_types Now contains Ids as well, replete with final IdInfo
+-- The Ids are only the ones that are visible from
+-- importing modules. Without -O that means only
+-- exported Ids, but with -O importing modules may
+-- see ids mentioned in unfoldings of exported Ids
+--
+-- md_insts Same DFunIds as before, but with final IdInfo,
+-- and the unique might have changed; remember that
+-- CoreTidy links up the uniques of old and new versions
+--
+-- md_rules All rules for exported things, substituted with final Ids
+--
+-- md_binds Tidied
+--
+-- Passed back to compilation manager
+-- Just as after CoreTidy, but with md_binds nuked
+
\end{code}
\begin{code}
)
import CmdLineOpts
-import Id ( idType, idInfo, isImplicitId, isLocalId, idName )
+import Id ( idType, idInfo, isImplicitId, idCgInfo,
+ isLocalId, idName,
+ )
import DataCon ( StrictnessMark(..), dataConId, dataConSig, dataConFieldLabels, dataConStrictMarks )
import IdInfo -- Lots
-import CoreSyn ( CoreBind, CoreRule(..) )
+import CoreSyn ( CoreRule(..) )
import CoreUnfold ( neverUnfold, unfoldingTemplate )
import PprCore ( pprIdCoreRule )
import Name ( getName, nameModule, toRdrName, isGlobalName, Name, NamedThing(..) )
-- NB: 'Nothing' means that even the usages havn't changed, so there's no
-- need to write a new interface file. But even if the usages have
-- changed, the module version may not have.
-completeIface maybe_old_iface new_iface mod_details
+completeIface maybe_old_iface new_iface mod_details
= addVersionInfo maybe_old_iface (new_iface { mi_decls = new_decls })
where
new_decls = mkIfaceDecls ty_cls_dcls rule_dcls inst_dcls
id_type = idType id
id_info = idInfo id
+ cg_info = idCgInfo id
+ arity_info = cgArity cg_info
+ caf_info = cgCafInfo cg_info
hs_idinfo | opt_OmitInterfacePragmas = []
| otherwise = arity_hsinfo ++ caf_hsinfo ++ cpr_hsinfo ++
strict_hsinfo ++ wrkr_hsinfo ++ unfold_hsinfo
------------ Arity --------------
- arity_hsinfo = case arityInfo id_info of
- a@(ArityExactly n) -> [HsArity a]
- other -> []
+ arity_hsinfo | arity_info == 0 = []
+ | otherwise = [HsArity arity_info]
------------ Caf Info --------------
- caf_hsinfo = case cafInfo id_info of
+ caf_hsinfo = case caf_info of
NoCafRefs -> [HsNoCafRefs]
otherwise -> []
work_info = workerInfo id_info
has_worker = case work_info of { HasWorker _ _ -> True; other -> False }
wrkr_hsinfo = case work_info of
- HasWorker work_id wrap_arity -> [HsWorker (getName work_id)]
- NoWorker -> []
+ HasWorker work_id wrap_arity ->
+ [HsWorker (getName work_id) wrap_arity]
+ NoWorker -> []
------------ Unfolding --------------
-- The unfolding is redundant if there is a worker
do_top_bindings [] = returnMM []
- do_top_bindings (StgNonRec b rhs : bs)
+ do_top_bindings (StgNonRec srt b rhs : bs)
= do_top_rhs b rhs `thenMM` \ rhs' ->
addTopLevelIshId b (
do_top_bindings bs `thenMM` \bs' ->
- returnMM (StgNonRec b rhs' : bs')
+ returnMM (StgNonRec srt b rhs' : bs')
)
- do_top_bindings (StgRec pairs : bs)
+ do_top_bindings (StgRec srt pairs : bs)
= addTopLevelIshIds binders (
mapMM do_pair pairs `thenMM` \ pairs2 ->
do_top_bindings bs `thenMM` \ bs' ->
- returnMM (StgRec pairs2 : bs')
+ returnMM (StgRec srt pairs2 : bs')
)
where
binders = map fst pairs
----------
do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
- do_top_rhs binder (StgRhsClosure _ bi srt fv u [] (StgSCC cc (StgConApp con args)))
+ do_top_rhs binder (StgRhsClosure _ bi fv u [] (StgSCC cc (StgConApp con args)))
| not (isSccCountCostCentre cc) && not (isDllConApp con args)
-- Trivial _scc_ around nothing but static data
-- Eliminate _scc_ ... and turn into StgRhsCon
= returnMM (StgRhsCon dontCareCCS con args)
{- Can't do this one with cost-centre stacks: --SDM
- do_top_rhs binder (StgRhsClosure no_cc bi srt fv u [] (StgSCC ty cc expr))
+ do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr))
| (noCCSAttached no_cc || currentOrSubsumedCCS no_cc)
&& not (isSccCountCostCentre cc)
-- Top level CAF without a cost centre attached
-- Attach and collect cc of trivial _scc_ in body
= collectCC cc `thenMM_`
set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' ->
- returnMM (StgRhsClosure cc bi srt fv u [] expr')
+ returnMM (StgRhsClosure cc bi fv u [] expr')
-}
- do_top_rhs binder (StgRhsClosure no_cc bi srt fv u [] body)
+ do_top_rhs binder (StgRhsClosure no_cc bi fv u [] body)
| noCCSAttached no_cc || currentOrSubsumedCCS no_cc
-- Top level CAF without a cost centre attached
-- Attach CAF cc (collect if individual CAF ccs)
else
returnMM all_cafs_ccs) `thenMM` \ caf_ccs ->
set_prevailing_cc caf_ccs (do_expr body) `thenMM` \ body' ->
- returnMM (StgRhsClosure caf_ccs bi srt fv u [] body')
+ returnMM (StgRhsClosure caf_ccs bi fv u [] body')
- do_top_rhs binder (StgRhsClosure cc bi srt fv u [] body)
+ do_top_rhs binder (StgRhsClosure cc bi fv u [] body)
-- Top level CAF with cost centre attached
-- Should this be a CAF cc ??? Does this ever occur ???
= pprPanic "SCCfinal: CAF with cc:" (ppr cc)
-{- can't do this with cost-centre stacks: --SDM
- do_top_rhs binder (StgRhsClosure _ bi srt fv u args (StgSCC cc expr))
- | not (isSccCountCostCentre cc)
- -- Top level function with trivial _scc_ in body
- -- Attach and collect cc of trivial _scc_
- = collectCC cc `thenMM_`
- set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' ->
- returnMM (StgRhsClosure cc bi srt fv u args expr')
--}
-
- do_top_rhs binder (StgRhsClosure no_ccs bi srt fv u args body)
+ do_top_rhs binder (StgRhsClosure no_ccs bi fv u args body)
-- Top level function, probably subsumed
| noCCSAttached no_ccs
= set_lambda_cc (do_expr body) `thenMM` \ body' ->
- returnMM (StgRhsClosure subsumedCCS bi srt fv u args body')
+ returnMM (StgRhsClosure subsumedCCS bi fv u args body')
| otherwise
= pprPanic "SCCfinal: CAF with cc:" (ppr no_ccs)
----------------------------------
- do_let (StgNonRec b rhs) e
+ do_let (StgNonRec srt b rhs) e
= do_rhs rhs `thenMM` \ rhs' ->
addTopLevelIshId b (
do_expr e `thenMM` \ e' ->
- returnMM (StgNonRec b rhs',e')
+ returnMM (StgNonRec srt b rhs',e')
)
- do_let (StgRec pairs) e
+ do_let (StgRec srt pairs) e
= addTopLevelIshIds binders (
mapMM do_pair pairs `thenMM` \ pairs' ->
do_expr e `thenMM` \ e' ->
- returnMM (StgRec pairs', e')
+ returnMM (StgRec srt pairs', e')
)
where
binders = map fst pairs
-- but we don't have to worry about cafs etc.
{-
- do_rhs (StgRhsClosure closure_cc bi srt fv u [] (StgSCC ty cc (StgCon (DataCon con) args _)))
+ do_rhs (StgRhsClosure closure_cc bi fv u [] (StgSCC ty cc (StgCon (DataCon con) args _)))
| not (isSccCountCostCentre cc)
= collectCC cc `thenMM_`
returnMM (StgRhsCon cc con args)
-}
{-
- do_rhs (StgRhsClosure _ bi srt fv u args (StgSCC ty cc expr))
+ do_rhs (StgRhsClosure _ bi fv u args (StgSCC ty cc expr))
| not (isSccCountCostCentre cc)
= collectCC cc `thenMM_`
set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' ->
- returnMM (StgRhsClosure cc bi srt fv u args expr')
+ returnMM (StgRhsClosure cc bi fv u args expr')
-}
- do_rhs (StgRhsClosure cc bi srt fv u [] body)
+ do_rhs (StgRhsClosure cc bi fv u [] body)
= do_expr body `thenMM` \ body' ->
- returnMM (StgRhsClosure currentCCS bi srt fv u [] body')
+ returnMM (StgRhsClosure currentCCS bi fv u [] body')
- do_rhs (StgRhsClosure cc bi srt fv u args body)
+ do_rhs (StgRhsClosure cc bi fv u args body)
= set_lambda_cc (do_expr body) `thenMM` \ body' ->
get_prevailing_cc `thenMM` \ prev_ccs ->
- returnMM (StgRhsClosure currentCCS bi srt fv u args body')
+ returnMM (StgRhsClosure currentCCS bi fv u args body')
do_rhs (StgRhsCon cc con args)
= returnMM (StgRhsCon currentCCS con args)
mk_stg_let cc (new_var, old_var) body
= let
rhs_body = StgApp old_var [{-args-}]
- rhs_closure = StgRhsClosure cc stgArgOcc NoSRT [{-fvs-}] ReEntrant [{-args-}] rhs_body
+ rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant [{-args-}] rhs_body
in
- StgLet (StgNonRec new_var rhs_closure) body
+ StgLet (StgNonRec NoSRT{-eeek!!!-} new_var rhs_closure) body
where
bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
import CostCentre ( CostCentre(..), IsCafCC(..), IsDupdCC(..) )
import CallConv ( cCallConv )
import Type ( Kind, mkArrowKind, liftedTypeKind, openTypeKind, usageTypeKind )
-import IdInfo ( exactArity, InlinePragInfo(..) )
+import IdInfo ( InlinePragInfo(..) )
import PrimOp ( CCall(..), CCallTarget(..) )
import Lex
| id_info_item id_info { $1 : $2 }
id_info_item :: { HsIdInfo RdrName }
- : '__A' INTEGER { HsArity (exactArity (fromInteger $2)) }
+ : '__A' INTEGER { HsArity (fromInteger $2) }
| '__U' inline_prag core_expr { HsUnfold $2 $3 }
| '__M' { HsCprInfo }
| '__S' { HsStrictness (mkStrictnessInfo $1) }
| '__C' { HsNoCafRefs }
- | '__P' qvar_name { HsWorker $2 }
+ | '__P' qvar_name INTEGER { HsWorker $2 (fromInteger $3) }
inline_prag :: { InlinePragInfo }
: {- empty -} { NoInlinePragInfo }
import RnHiFiles ( readIface, removeContext, loadInterface,
loadExports, loadFixDecls, loadDeprecs,
)
-import MkIface ( pprUsage )
import RnEnv ( availsToNameSet, mkIfaceGlobalRdrEnv,
emptyAvailEnv, unitAvailEnv, availEnvElts,
plusAvailEnv, groupAvails, warnUnusedImports,
----------------
hsIdInfoFVs (HsUnfold _ unf) = ufExprFVs unf
-hsIdInfoFVs (HsWorker n) = unitFV n
+hsIdInfoFVs (HsWorker n a) = unitFV n
hsIdInfoFVs other = emptyFVs
----------------
%*********************************************************
\begin{code}
-rnIdInfo (HsWorker worker)
+rnIdInfo (HsWorker worker arity)
= lookupOccRn worker `thenRn` \ worker' ->
- returnRn (HsWorker worker')
+ returnRn (HsWorker worker' arity)
rnIdInfo (HsUnfold inline expr) = rnCoreExpr expr `thenRn` \ expr' ->
returnRn (HsUnfold inline expr')
-> PersistentCompilerState
-> HomeSymbolTable
-> IsExported
- -> [CoreBind] -- Binds in
- -> [IdCoreRule] -- Rules defined in this module
- -> IO ([CoreBind], [IdCoreRule]) -- binds, local orphan rules out
+ -> ModDetails
+ -> IO ModDetails
-core2core dflags pcs hst is_exported binds rules
+core2core dflags pcs hst is_exported
+ mod_details@(ModDetails { md_binds = binds_in, md_rules = rules_in })
= do
let core_todos = dopt_CoreToDo dflags
let pkg_rule_base = pcs_rules pcs -- Rule-base accumulated from imported packages
+
us <- mkSplitUniqSupply 's'
let (cp_us, ru_us) = splitUniqSupply us
-- COMPUTE THE RULE BASE TO USE
(rule_base, local_rule_ids, orphan_rules, rule_rhs_fvs)
- <- prepareRules dflags pkg_rule_base hst ru_us binds rules
+ <- prepareRules dflags pkg_rule_base hst ru_us binds_in rules_in
-- PREPARE THE BINDINGS
- let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported binds
+ let binds1 = updateBinders local_rule_ids rule_rhs_fvs is_exported binds_in
-- DO THE BUSINESS
(stats, processed_binds)
-- Return results
-- We only return local orphan rules, i.e., local rules not attached to an Id
-- The bindings cotain more rules, embedded in the Ids
- return (processed_binds, orphan_rules)
+ return (mod_details { md_binds = processed_binds, md_rules = orphan_rules})
simplifyExpr :: DynFlags -- includes spec of what core-to-core passes to do
bindings have no CAF references, and record the fact in their IdInfo.
\begin{code}
-module SRT where
+module SRT( computeSRTs ) where
#include "HsVersions.h"
-import Id ( Id, idCafInfo )
-import IdInfo ( mayHaveCafRefs )
import StgSyn
-
-import UniqFM
-import UniqSet
-import Panic
+import Id ( Id )
+import VarSet ( varSetElems )
+import Util ( mapAccumL )
#ifdef DEBUG
import Outputable
\begin{code}
computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
+ -- The incoming bindingd are filled with SRTEntries in their SRT slots
+ -- the outgoing ones have NoSRT/SRT values instead
+
computeSRTs binds = map srtTopBind binds
\end{code}
Our functions have type
- :: SrtOffset -- next free offset within the SRT
- -> (UniqSet Id, -- global refs in the continuation
- UniqFM (UniqSet Id))-- global refs in let-no-escaped variables
-{- * -} -> StgExpr -- expression to analyse
-
+srtExpr :: SrtOffset -- Next free offset within the SRT
+ -> StgExpr -- Expression to analyse
-> (StgExpr, -- (e) newly annotated expression
- UniqSet Id, -- (g) global refs from this expression
- [Id], -- (s) SRT required for this expression
+ SrtIds, -- (s) SRT required for this expression (reversed)
SrtOffset) -- (o) new offset
-(g) is a set containing all local top-level and imported ids referred
-to by the expression (e), which have MayHaveCafRefs in their CafInfo.
-
We build a single SRT for a recursive binding group, which is why the
SRT building is done at the binding level rather than the
StgRhsClosure level.
Hmm, that probably makes no sense.
\begin{code}
-srtTopBind
- :: StgBinding
- -> (StgBinding, -- the new binding
- [Id]) -- the SRT for this binding
+type SrtOffset = Int
+type SrtIds = [Id] -- An *reverse-ordered* list of the Ids needed in the SRT
-srtTopBind (StgNonRec binder rhs) =
+srtTopBind :: StgBinding -> (StgBinding, SrtIds)
- -- no need to use circularity for non-recursive bindings
- srtRhs (emptyUniqSet,emptyUFM) 0{-initial offset-} rhs
- =: \(rhs, g, srt, off) ->
- let
- filtered_g = uniqSetToList g
- extra_refs = filter (`notElem` srt) filtered_g
- bind_srt = reverse (extra_refs ++ srt)
- in
- ASSERT2(null bind_srt || idMayHaveCafRefs binder, ppr binder)
+srtTopBind bind
+ = srtBind 0 bind =: \ (bind', srt, off) ->
+ (bind', reverse srt) -- The 'reverse' is because the SRT is
+ -- built up reversed, for efficiency's sake
- case rhs of
- StgRhsClosure _ _ _ _ _ _ _ ->
- (StgNonRec binder (attach_srt_rhs rhs 0 (length bind_srt)),
- bind_srt)
+srtBind :: SrtOffset -> StgBinding -> (StgBinding, SrtIds, SrtOffset)
- -- don't output an SRT for the constructor
- StgRhsCon _ _ _ -> (StgNonRec binder rhs, [])
-
-
-srtTopBind (StgRec bs) =
- ASSERT(null bind_srt || all idMayHaveCafRefs binders)
- (attach_srt_bind (StgRec new_bs) 0 (length bind_srt), bind_srt)
+srtBind off (StgNonRec (SRTEntries rhs_cafs) binder rhs)
+ = (StgNonRec srt_info binder new_rhs, this_srt, body_off)
where
- (binders,rhss) = unzip bs
+ (new_rhs, rhs_srt, rhs_off) = srtRhs off rhs
+ (srt_info, this_srt, body_off) = constructSRT rhs_cafs rhs_srt off rhs_off
- non_caf_binders = [ b | (b, rhs) <- bs, not (caf_rhs rhs) ]
-
- (new_bs, g, srt, _) = doBinds bs [] emptyUniqSet [] 0
-
- -- filter out ourselves from the global references: it makes no
- -- sense to refer recursively to our SRT unless the recursive
- -- reference is required by a nested SRT.
- filtered_g = filter (\id -> id `notElem` non_caf_binders) (uniqSetToList g)
- extra_refs = filter (`notElem` srt) filtered_g
- bind_srt = reverse (extra_refs ++ srt)
-
- doBinds [] new_binds g srt off = (reverse new_binds, g, srt, off)
- doBinds ((binder,rhs):binds) new_binds g srt off =
- srtRhs (emptyUniqSet,emptyUFM) off rhs
- =: \(rhs, rhs_g, rhs_srt, off) ->
- let
- g' = unionUniqSets rhs_g g
- srt' = rhs_srt ++ srt
- in
- doBinds binds ((binder,rhs):new_binds) g' srt' off
-
-caf_rhs (StgRhsClosure _ _ _ free_vars _ [] body) = True
-caf_rhs _ = False
-\end{code}
-
------------------------------------------------------------------------------
-Non-top-level bindings
-\begin{code}
-srtBind :: (UniqSet Id, UniqFM (UniqSet Id))
- -> Int -> StgBinding -> (StgBinding, UniqSet Id, [Id], Int)
+srtBind off (StgRec (SRTEntries rhss_cafs) pairs)
+ = (StgRec srt_info new_pairs, this_srt, body_off)
+ where
+ ((rhss_off, rhss_srt), new_pairs) = mapAccumL do_bind (off, []) pairs
-srtBind cont_refs off (StgNonRec binder rhs) =
- srtRhs cont_refs off rhs =: \(rhs, g, srt, off) ->
- (StgNonRec binder rhs, g, srt, off)
+ do_bind (off,srt) (bndr,rhs)
+ = srtRhs off rhs =: \(rhs', srt', off') ->
+ ((off', srt'++srt), (bndr, rhs'))
-srtBind cont_refs off (StgRec binds) =
- (StgRec new_binds, g, srt, new_off)
- where
- -- process each binding
- (new_binds, g, srt, new_off) = doBinds binds emptyUniqSet [] off []
-
- doBinds [] g srt off new_binds = (reverse new_binds, g, srt, off)
- doBinds ((binder,rhs):binds) g srt off new_binds =
- srtRhs cont_refs off rhs =: \(rhs, g', srt', off) ->
- doBinds binds (unionUniqSets g g') (srt'++srt) off
- ((binder,rhs):new_binds)
+ (srt_info, this_srt, body_off)
+ = constructSRT rhss_cafs rhss_srt off rhss_off
\end{code}
-----------------------------------------------------------------------------
Right Hand Sides
\begin{code}
-srtRhs :: (UniqSet Id, UniqFM (UniqSet Id))
- -> Int -> StgRhs -> (StgRhs, UniqSet Id, [Id], Int)
+srtRhs :: SrtOffset -> StgRhs -> (StgRhs, SrtIds, SrtOffset)
-srtRhs cont off (StgRhsClosure cc bi old_srt free_vars u args body) =
- srtExpr cont off body =: \(body, g, srt, off) ->
- (StgRhsClosure cc bi old_srt free_vars u args body, g, srt, off)
+srtRhs off (StgRhsClosure cc bi free_vars u args body)
+ = srtExpr off body =: \(body, srt, off) ->
+ (StgRhsClosure cc bi free_vars u args body, srt, off)
-srtRhs cont off e@(StgRhsCon cc con args) =
- (e, getGlobalRefs args, [], off)
+srtRhs off e@(StgRhsCon cc con args) = (e, [], off)
\end{code}
-----------------------------------------------------------------------------
Expressions
\begin{code}
-srtExpr :: (UniqSet Id, UniqFM (UniqSet Id))
- -> Int -> StgExpr -> (StgExpr, UniqSet Id, [Id], Int)
-
-srtExpr (cont,lne) off e@(StgApp f args) = (e, global_refs, [], off)
- where global_refs =
- cont `unionUniqSets`
- getGlobalRefs (StgVarArg f:args) `unionUniqSets`
- lookupPossibleLNE lne f
-
-srtExpr (cont,lne) off e@(StgLit l) = (e, cont, [], off)
+srtExpr :: SrtOffset -> StgExpr -> (StgExpr, SrtIds, SrtOffset)
-srtExpr (cont,lne) off e@(StgConApp con args) =
- (e, cont `unionUniqSets` getGlobalRefs args, [], off)
+srtExpr off e@(StgApp f args) = (e, [], off)
+srtExpr off e@(StgLit l) = (e, [], off)
+srtExpr off e@(StgConApp con args) = (e, [], off)
+srtExpr off e@(StgPrimApp op args ty) = (e, [], off)
-srtExpr (cont,lne) off e@(StgPrimApp op args ty) =
- (e, cont `unionUniqSets` getGlobalRefs args, [], off)
+srtExpr off (StgSCC cc expr) =
+ srtExpr off expr =: \(expr, srt, off) ->
+ (StgSCC cc expr, srt, off)
-srtExpr c@(cont,lne) off (StgCase scrut live1 live2 uniq _{-srt-} alts) =
- srtCaseAlts c off alts =: \(alts, alts_g, alts_srt, alts_off) ->
-
- -- construct the SRT for this case
- let (this_srt, scrut_off) = construct_srt alts_g alts_srt alts_off in
-
- -- global refs in the continuation is alts_g.
- srtExpr (alts_g,lne) scrut_off scrut
- =: \(scrut, scrut_g, scrut_srt, case_off) ->
+srtExpr off (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts)
+ = srtCaseAlts off alts =: \(alts, alts_srt, alts_off) ->
let
- g = unionUniqSets alts_g scrut_g
- srt = scrut_srt ++ this_srt
- srt_info = case length this_srt of
- 0 -> NoSRT
- len -> SRT off len
+ (srt_info, this_srt, scrut_off)
+ = constructSRT cafs_in_alts alts_srt off alts_off
in
- (StgCase scrut live1 live2 uniq srt_info alts, g, srt, case_off)
-
-srtExpr cont off (StgLet bind body) =
- srtLet cont off bind body StgLet (\_ cont -> cont)
-
-srtExpr cont off (StgLetNoEscape live1 live2 b@(StgNonRec bndr rhs) body)
- = srtLet cont off b body (StgLetNoEscape live1 live2) calc_cont
- where calc_cont g (cont,lne) = (cont,addToUFM lne bndr g)
-
--- for recursive let-no-escapes, we do *two* passes, the first time
--- just to extract the list of global refs, and the second time we actually
--- construct the SRT now that we know what global refs should be in
--- the various let-no-escape continuations.
-srtExpr conts@(cont,lne) off
- (StgLetNoEscape live1 live2 bind@(StgRec pairs) body)
- = srtBind conts off bind =: \(_, g, _, _) ->
- let
- lne' = addListToUFM lne [ (bndr,g) | (bndr,_) <- pairs ]
- calc_cont _ conts = conts
- in
- srtLet (cont,lne') off bind body (StgLetNoEscape live1 live2) calc_cont
-
-
-srtExpr cont off (StgSCC cc expr) =
- srtExpr cont off expr =: \(expr, g, srt, off) ->
- (StgSCC cc expr, g, srt, off)
+ srtExpr scrut_off scrut =: \(scrut, scrut_srt, case_off) ->
+
+ (StgCase scrut live1 live2 uniq srt_info alts,
+ scrut_srt ++ this_srt,
+ case_off)
+
+srtExpr off (StgLet bind body)
+ = srtBind off bind =: \ (bind', bind_srt, body_off) ->
+ srtExpr body_off body =: \ (body', expr_srt, let_off) ->
+ (StgLet bind' body', expr_srt ++ bind_srt, let_off)
+
+srtExpr off (StgLetNoEscape live1 live2 bind body)
+ = srtBind off bind =: \ (bind', bind_srt, body_off) ->
+ srtExpr body_off body =: \ (body', expr_srt, let_off) ->
+ (StgLetNoEscape live1 live2 bind' body', expr_srt ++ bind_srt, let_off)
#ifdef DEBUG
-srtExpr cont off expr = pprPanic "srtExpr" (ppr expr)
-#else
-srtExpr cont off expr = panic "srtExpr"
+srtExpr off expr = pprPanic "srtExpr" (ppr expr)
#endif
\end{code}
-----------------------------------------------------------------------------
-Let-expressions
-
-This is quite complicated stuff...
-
-\begin{code}
-srtLet cont off bind body let_constr calc_cont
-
- -- If the bindings are all constructors, then we don't need to
- -- buid an SRT at all...
- | all_con_binds bind =
- srtBind cont off bind =: \(bind, bind_g, bind_srt, off) ->
- srtExpr cont off body =: \(body, body_g, body_srt, off) ->
- let
- g = unionUniqSets bind_g body_g
- srt = body_srt ++ bind_srt
- in
- (let_constr bind body, g, srt, off)
-
- -- we have some closure bindings...
- | otherwise =
-
- -- first, find the sub-SRTs in the binding
- srtBind cont off bind =: \(bind, bind_g, bind_srt, bind_off) ->
-
- -- construct the SRT for this binding
- let (this_srt, body_off) = construct_srt bind_g bind_srt bind_off in
-
- -- get the new continuation information (if a let-no-escape)
- let new_cont = calc_cont bind_g cont in
-
- -- now find the SRTs in the body
- srtExpr new_cont body_off body =: \(body, body_g, body_srt, let_off) ->
-
- let
- -- union all the global references together
- let_g = unionUniqSets bind_g body_g
-
- -- concatenate the sub-SRTs
- let_srt = body_srt ++ this_srt
-
- -- attach the SRT info to the binding
- bind' = attach_srt_bind bind off (length this_srt)
- in
- (let_constr bind' body, let_g, let_srt, let_off)
-\end{code}
-
------------------------------------------------------------------------------
Construct an SRT.
Construct the SRT at this point from its sub-SRTs and any new global
which are "live").
\begin{code}
-construct_srt global_refs sub_srt current_offset
+constructSRT caf_refs sub_srt initial_offset current_offset
= let
- extra_refs = filter (`notElem` sub_srt) (uniqSetToList global_refs)
- this_srt = extra_refs ++ sub_srt
+ extra_refs = filter (`notElem` sub_srt) (varSetElems caf_refs)
+ this_srt = extra_refs ++ sub_srt
-- Add the length of the new entries to the
-- current offset to get the next free offset in the global SRT.
new_offset = current_offset + length extra_refs
- in (this_srt, new_offset)
-\end{code}
-
------------------------------------------------------------------------------
-Case Alternatives
-
-\begin{code}
-srtCaseAlts :: (UniqSet Id, UniqFM (UniqSet Id))
- -> Int -> StgCaseAlts -> (StgCaseAlts, UniqSet Id, [Id], Int)
+ srt_length = new_offset - initial_offset
-srtCaseAlts cont off (StgAlgAlts t alts dflt) =
- srtAlgAlts cont off alts [] emptyUniqSet []
- =: \(alts, alts_g, alts_srt, off) ->
- srtDefault cont off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
- let
- g = unionUniqSets alts_g dflt_g
- srt = dflt_srt ++ alts_srt
- in
- (StgAlgAlts t alts dflt, g, srt, off)
-
-srtCaseAlts cont off (StgPrimAlts t alts dflt) =
- srtPrimAlts cont off alts [] emptyUniqSet []
- =: \(alts, alts_g, alts_srt, off) ->
- srtDefault cont off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
- let
- g = unionUniqSets alts_g dflt_g
- srt = dflt_srt ++ alts_srt
- in
- (StgPrimAlts t alts dflt, g, srt, off)
+ srt_info | srt_length == 0 = NoSRT
+ | otherwise = SRT initial_offset srt_length
-srtAlgAlts cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
-srtAlgAlts cont off ((con,args,used,rhs):alts) new_alts g srt =
- srtExpr cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
- let
- g' = unionUniqSets rhs_g g
- srt' = rhs_srt ++ srt
- in
- srtAlgAlts cont off alts ((con,args,used,rhs) : new_alts) g' srt'
-
-srtPrimAlts cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
-srtPrimAlts cont off ((lit,rhs):alts) new_alts g srt =
- srtExpr cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
- let
- g' = unionUniqSets rhs_g g
- srt' = rhs_srt ++ srt
- in
- srtPrimAlts cont off alts ((lit,rhs) : new_alts) g' srt'
-
-srtDefault cont off StgNoDefault = (StgNoDefault,emptyUniqSet,[],off)
-srtDefault cont off (StgBindDefault rhs) =
- srtExpr cont off rhs =: \(rhs, g, srt, off) ->
- (StgBindDefault rhs, g, srt, off)
+ in ASSERT( srt_length == length this_srt )
+ (srt_info, this_srt, new_offset)
\end{code}
-----------------------------------------------------------------------------
-
-Here we decide which Id's to place in the static reference table. An
-internal top-level id will be in the environment with the appropriate
-CafInfo, so we use that if available. An imported top-level Id will
-have the CafInfo attached. Otherwise, we just ignore the Id.
+Case Alternatives
\begin{code}
-getGlobalRefs :: [StgArg] -> UniqSet Id
-getGlobalRefs args = mkUniqSet (concat (map globalRefArg args))
-
-globalRefArg :: StgArg -> [Id]
-globalRefArg (StgVarArg id)
- | idMayHaveCafRefs id = [id]
- | otherwise = []
-globalRefArg _ = []
-
-idMayHaveCafRefs id = mayHaveCafRefs (idCafInfo id)
+srtCaseAlts :: SrtOffset -> StgCaseAlts -> (StgCaseAlts, SrtIds, SrtOffset)
+
+srtCaseAlts off (StgAlgAlts t alts dflt)
+ = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') ->
+ mapAccumL srtAlgAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') ->
+ (StgAlgAlts t alts' dflt', alts_srt, alts_off)
+
+srtCaseAlts off (StgPrimAlts t alts dflt)
+ = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') ->
+ mapAccumL srtPrimAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') ->
+ (StgPrimAlts t alts' dflt', alts_srt, alts_off)
+
+srtAlgAlt (off,srt) (con,args,used,rhs)
+ = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) ->
+ ((rhs_off, rhs_srt ++ srt), (con,args,used,rhs'))
+
+srtPrimAlt (off,srt) (lit,rhs)
+ = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) ->
+ ((rhs_off, rhs_srt ++ srt), (lit, rhs'))
+
+srtDefault off StgNoDefault
+ = ((off,[]), StgNoDefault)
+srtDefault off (StgBindDefault rhs)
+ = srtExpr off rhs =: \(rhs', srt, off) ->
+ ((off,srt), StgBindDefault rhs')
\end{code}
-----------------------------------------------------------------------------
Misc stuff
\begin{code}
-attach_srt_bind :: StgBinding -> Int -> Int -> StgBinding
-attach_srt_bind (StgNonRec binder rhs) off len =
- StgNonRec binder (attach_srt_rhs rhs off len)
-attach_srt_bind (StgRec binds) off len =
- StgRec [ (v,attach_srt_rhs rhs off len) | (v,rhs) <- binds ]
-
-attach_srt_rhs :: StgRhs -> Int -> Int -> StgRhs
-attach_srt_rhs (StgRhsCon cc con args) off length
- = StgRhsCon cc con args
-attach_srt_rhs (StgRhsClosure cc bi _ free upd args rhs) off length
- = StgRhsClosure cc bi srt free upd args rhs
- where
- srt | length == 0 = NoSRT
- | otherwise = SRT off length
-
-
-all_con_binds (StgNonRec x rhs) = con_rhs rhs
-all_con_binds (StgRec bs) = all con_rhs (map snd bs)
-
-con_rhs (StgRhsCon _ _ _) = True
-con_rhs _ = False
-
-
a =: k = k a
\end{code}
-
------------------------------------------------------------------------------
-Fix up the SRT's in a let-no-escape.
-
-(for a description of let-no-escapes, see CgLetNoEscape.lhs)
-
-Here's the problem: a let-no-escape isn't represented by an activation
-record on the stack. It seems either very difficult or impossible to
-get the liveness bitmap right in the info table, so we don't do it
-this way (the liveness mask isn't constant).
-
-So, the question is how does the garbage collector get access to the
-SRT for the rhs of the let-no-escape? It can't see an info table, so
-it must get the SRT from somewhere else. Here's an example:
-
- let-no-escape x = .... f ....
- in case blah of
- p -> .... x ... g ....
-
-(f and g are global). Suppose we garbage collect while evaluating
-'blah'. The stack will contain an activation record for the case,
-which will point to an SRT containing [g] (according to our SRT
-algorithm above). But, since the case continuation can call x, and
-hence f, the SRT should really be [f,g].
-
-another example:
-
- let-no-escape {-rec-} z = \x -> case blah of
- p1 -> .... f ...
- p2 -> case blah2 of
- p -> .... (z x') ...
- in ....
-
-if we GC while evaluating blah2, then the case continuation on the
-stack needs to refer to [f] in its SRT, because we can reach f by
-calling z recursively.
-
-FIX:
-
-We keep track of the global references made by each let-no-escape in
-scope, so we can expand them every time the let-no-escape is
-referenced.
-
-\begin{code}
-lookupPossibleLNE lne_env f =
- case lookupUFM lne_env f of
- Nothing -> emptyUniqSet
- Just refs -> refs
-\end{code}
end_pass us2 "ProfMassage" collected_CCs binds3
end_pass us2 what ccs binds2
- = -- report verbosely, if required
- (if dopt Opt_D_verbose_stg2stg dflags then
- hPutStr stdout (showSDoc
- (text ("*** "++what++":") $$ vcat (map ppr binds2)
- ))
- else return ()) >>
- let
- linted_binds = stg_linter what binds2
- in
- return (linted_binds, us2, ccs)
+ = do -- report verbosely, if required
+ dumpIfSet_dyn dflags Opt_D_verbose_stg2stg what
+ (vcat (map ppr binds2))
+ let linted_binds = stg_linter what binds2
+ return (linted_binds, us2, ccs)
-- return: processed binds
-- UniqueSupply for the next guy to use
-- cost-centres to be declared/registered (specialised)
-> StgBinding
-> StatEnv
-statBinding top (StgNonRec b rhs)
+statBinding top (StgNonRec _srt b rhs)
= statRhs top (b, rhs)
-statBinding top (StgRec pairs)
+statBinding top (StgRec _srt pairs)
= combineSEs (map (statRhs top) pairs)
statRhs :: Bool -> (Id, StgRhs) -> StatEnv
statRhs top (b, StgRhsCon cc con args)
= countOne (ConstructorBinds top)
-statRhs top (b, StgRhsClosure cc bi srt fv u args body)
+statRhs top (b, StgRhsClosure cc bi fv u args body)
= statExpr body `combineSE`
countN FreeVariables (length fv) `combineSE`
countOne (
#include "HsVersions.h"
import CoreSyn
-import CoreFVs
import CoreUtils
-import SimplUtils
import StgSyn
import Type
import TyCon ( isAlgTyCon )
+import Literal
import Id
import Var ( Var, globalIdDetails )
import IdInfo
import VarEnv
import DataCon ( dataConWrapId )
import IdInfo ( OccInfo(..) )
-import PrimOp ( PrimOp(..), ccallMayGC )
import TysPrim ( foreignObjPrimTyCon )
-import Maybes ( maybeToBool, orElse )
-import Name ( getOccName, isExternallyVisibleName )
-import Module ( Module )
+import Maybes ( maybeToBool )
+import Name ( getOccName, isExternallyVisibleName, isDllName )
import OccName ( occNameUserString )
import BasicTypes ( TopLevelFlag(..), isNotTopLevel )
import CmdLineOpts ( DynFlags, opt_KeepStgTypes )
+import FastTypes hiding ( fastOr )
import Outputable
+import List ( partition )
+
infixr 9 `thenLne`
\end{code}
%************************************************************************
%* *
+\subsection[caf-info]{Collecting live CAF info}
+%* *
+%************************************************************************
+
+In this pass we also collect information on which CAFs are live for
+constructing SRTs (see SRT.lhs).
+
+A top-level Id has CafInfo, which is
+
+ - MayHaveCafRefs, if it may refer indirectly to
+ 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.
+
+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
+of "live" here is the same as for live variables, see above (which is
+why it's convenient to collect CAF information here rather than elsewhere).
+
+The later SRT pass takes these lists of Ids and uses them to construct
+the actual nested SRTs, and replaces the lists of Ids with (offset,length)
+pairs.
+
+%************************************************************************
+%* *
\subsection[binds-StgVarInfo]{Setting variable info: top-level, binds, RHSs}
%* *
%************************************************************************
\begin{code}
-coreToStg :: DynFlags -> Module -> [CoreBind] -> IO [StgBinding]
-coreToStg dflags this_mod pgm
- = return (fst (initLne (coreTopBindsToStg pgm)))
+coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding]
+coreToStg dflags pgm
+ = return pgm'
+ where (env', fvs, pgm') = coreTopBindsToStg emptyVarEnv pgm
coreExprToStg :: CoreExpr -> StgExpr
coreExprToStg expr
- = new_expr where (new_expr,_,_) = initLne (coreToStgExpr expr)
-
--- For top-level guys, we basically aren't worried about this
--- live-variable stuff; we do need to keep adding to the environment
--- as we step through the bindings (using @extendVarEnv@).
-
-coreTopBindsToStg :: [CoreBind] -> LneM ([StgBinding], FreeVarsInfo)
-
-coreTopBindsToStg [] = returnLne ([], emptyFVInfo)
-coreTopBindsToStg (bind:binds)
- = let
- binders = bindersOf bind
- env_extension = binders `zip` repeat how_bound
- how_bound = LetrecBound True {- top level -}
- emptyVarSet
- in
-
- extendVarEnvLne env_extension (
- coreTopBindsToStg binds `thenLne` \ (binds', fv_binds) ->
- coreTopBindToStg binders fv_binds bind `thenLne` \ (bind', fv_bind) ->
- returnLne (
- (bind' : binds'),
- binders `minusFVBinders` (fv_binds `unionFVInfo` fv_bind)
- )
- )
+ = new_expr where (new_expr,_,_) = initLne emptyVarEnv (coreToStgExpr expr)
+
+
+coreTopBindsToStg
+ :: IdEnv HowBound -- environment for the bindings
+ -> [CoreBind]
+ -> (IdEnv HowBound, FreeVarsInfo, [StgBinding])
+
+coreTopBindsToStg env [] = (env, emptyFVInfo, [])
+coreTopBindsToStg env (b:bs)
+ = (env2, fvs1, b':bs')
+ where
+ -- env accumulates down the list of binds, fvs accumulates upwards
+ (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b
+ (env2, fvs1, bs') = coreTopBindsToStg env1 bs
coreTopBindToStg
- :: [Id] -- New binders (with correct arity)
+ :: IdEnv HowBound
-> FreeVarsInfo -- Info about the body
-> CoreBind
- -> LneM (StgBinding, FreeVarsInfo)
+ -> (IdEnv HowBound, FreeVarsInfo, StgBinding)
-coreTopBindToStg [binder] body_fvs (NonRec _ rhs)
- = coreToStgRhs body_fvs TopLevel (binder,rhs) `thenLne` \ (rhs2, fvs, _) ->
- returnLne (StgNonRec binder rhs2, fvs)
+coreTopBindToStg env body_fvs (NonRec id rhs)
+ = let
+ caf_info = hasCafRefs env rhs
-coreTopBindToStg binders body_fvs (Rec pairs)
- = fixLne (\ ~(_, rec_rhs_fvs) ->
- let scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
- in
- mapAndUnzip3Lne (coreToStgRhs scope_fvs TopLevel) pairs
- `thenLne` \ (rhss2, fvss, _) ->
- let fvs = unionFVInfos fvss
- in
- returnLne (StgRec (binders `zip` rhss2), fvs)
- )
+ env' = extendVarEnv env id (LetBound how_bound emptyVarSet)
+
+ how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
+ | otherwise = TopLevelNoCafs
+
+ (stg_rhs, fvs', cafs) =
+ initLne env (
+ coreToStgRhs body_fvs TopLevel (id,rhs)
+ `thenLne` \ (stg_rhs, fvs', _) ->
+ freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
+ returnLne (stg_rhs, fvs', cafs)
+ )
+
+ bind = StgNonRec (SRTEntries cafs) id stg_rhs
+ in
+ ASSERT2(consistent caf_info bind, ppr id)
+-- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info)
+ (env', fvs' `unionFVInfo` body_fvs, bind)
+
+coreTopBindToStg env body_fvs (Rec pairs)
+ = let
+ (binders, rhss) = unzip pairs
+
+ -- to calculate caf_info, we initially map all the binders to
+ -- TopLevelNoCafs.
+ env1 = extendVarEnvList env
+ [ (b, LetBound TopLevelNoCafs emptyVarSet) | b <- binders ]
+
+ caf_info = hasCafRefss env1{-NB: not env'-} rhss
+
+ env' = extendVarEnvList env
+ [ (b, LetBound how_bound emptyVarSet) | b <- binders ]
+
+ how_bound | mayHaveCafRefs caf_info = TopLevelHasCafs
+ | otherwise = TopLevelNoCafs
+
+ (stg_rhss, fvs', cafs)
+ = initLne env' (
+ mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs
+ `thenLne` \ (stg_rhss, fvss', _) ->
+ let fvs' = unionFVInfos fvss' in
+ freeVarsToLiveVars fvs' `thenLne` \ (_, cafs) ->
+ returnLne (stg_rhss, fvs', cafs)
+ )
+
+ bind = StgRec (SRTEntries cafs) (zip binders stg_rhss)
+ in
+ ASSERT2(consistent caf_info 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
\end{code}
\begin{code}
where
binder_info = lookupFVInfo scope_fv_info binder
+bogus_rhs = StgRhsClosure noCCS noBinderInfo [] ReEntrant [] bogus_expr
+bogus_expr = (StgLit (MachInt 1))
+
mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo
-> StgExpr -> StgRhs
mkStgRhs top rhs_fvs binder_info (StgLam _ bndrs body)
- = StgRhsClosure noCCS binder_info noSRT
+ = StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
ReEntrant
bndrs body
= StgRhsCon noCCS con args
mkStgRhs top rhs_fvs binder_info rhs
- = StgRhsClosure noCCS binder_info noSRT
+ = StgRhsClosure noCCS binder_info
(getFVs rhs_fvs)
(updatable [] rhs)
[] rhs
set_of_args = mkVarSet args'
fvs = args' `minusFVBinders` body_fvs
escs = body_escs `minusVarSet` set_of_args
+ result_expr | null args' = body
+ | otherwise = StgLam (exprType expr) args' body
in
- if null args'
- then returnLne (body, fvs, escs)
- else returnLne (StgLam (exprType expr) args' body, fvs, escs)
+ returnLne (result_expr, fvs, escs)
coreToStgExpr (Note (SCC cc) expr)
= coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) ->
-- Cases require a little more real work.
coreToStgExpr (Case scrut bndr alts)
- = getVarsLiveInCont `thenLne` \ live_in_cont ->
- extendVarEnvLne [(bndr, CaseBound)] $
- vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
- lookupLiveVarsForSet alts_fvs `thenLne` \ alts_lvs ->
+ = extendVarEnvLne [(bndr, CaseBound)] $
+ vars_alts (findDefault alts) `thenLne` \ (alts2, alts_fvs, alts_escs) ->
+ freeVarsToLiveVars alts_fvs `thenLne` \ (alts_lvs, alts_caf_refs) ->
let
-- determine whether the default binder is dead or not
-- This helps the code generator to avoid generating an assignment
then bndr
else bndr `setIdOccInfo` IAmDead
- -- for a _ccall_GC_, some of the *arguments* need to live across the
- -- call (see findLiveArgs comments.), so we annotate them as being live
- -- in the alts to achieve the desired effect.
- mb_live_across_case =
- case scrut of
- -- ToDo: Notes?
- e@(App _ _) | (v, args) <- myCollectArgs e,
- PrimOpId (CCallOp ccall) <- globalIdDetails v,
- ccallMayGC ccall
- -> Just (filterVarSet isForeignObjArg (exprFreeVars e))
- _ -> Nothing
-
-- Don't consider the default binder as being 'live in alts',
-- since this is from the point of view of the case expr, where
-- the default binder is not free.
- live_in_alts = orElse (FMAP unionVarSet mb_live_across_case) id $
- live_in_cont `unionVarSet`
- (alts_lvs `minusVarSet` unitVarSet bndr)
+ live_in_alts = (alts_lvs `minusVarSet` unitVarSet bndr)
in
-- we tell the scrutinee that everything live in the alts
-- is live in it, too.
- setVarsLiveInCont live_in_alts (
- coreToStgExpr scrut
- ) `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
-
- lookupLiveVarsForSet scrut_fvs `thenLne` \ scrut_lvs ->
- let
- live_in_whole_case = live_in_alts `unionVarSet` scrut_lvs
+ setVarsLiveInCont (live_in_alts,alts_caf_refs) (
+ coreToStgExpr scrut `thenLne` \ (scrut2, scrut_fvs, scrut_escs) ->
+ freeVarsToLiveVars scrut_fvs `thenLne` \ (scrut_lvs, _) ->
+ returnLne (scrut2, scrut_fvs, scrut_escs, scrut_lvs)
+ )
+ `thenLne` \ (scrut2, scrut_fvs, scrut_escs, scrut_lvs) ->
+
+ let srt = SRTEntries alts_caf_refs
in
returnLne (
- StgCase scrut2 live_in_whole_case live_in_alts bndr' noSRT alts2,
+ StgCase scrut2 scrut_lvs live_in_alts bndr' srt alts2,
bndr `minusFVBinder` (scrut_fvs `unionFVInfo` alts_fvs),
(alts_escs `minusVarSet` unitVarSet bndr) `unionVarSet` getFVSet scrut_fvs
- -- You might think we should have scrut_escs, not (getFVSet scrut_fvs),
- -- but actually we can't call, and then return from, a let-no-escape thing.
+ -- You might think we should have scrut_escs, not
+ -- (getFVSet scrut_fvs), but actually we can't call, and
+ -- then return from, a let-no-escape thing.
)
where
scrut_ty = idType bndr
-> LneM (StgExpr, FreeVarsInfo, EscVarsSet)
coreToStgApp maybe_thunk_body f args
- = getVarsLiveInCont `thenLne` \ live_in_cont ->
- coreToStgArgs args `thenLne` \ (args', args_fvs) ->
+ = coreToStgArgs args `thenLne` \ (args', args_fvs) ->
lookupVarLne f `thenLne` \ how_bound ->
let
n_args = length args
- not_letrec_bound = not (isLetrecBound how_bound)
+ not_letrec_bound = not (isLetBound how_bound)
fun_fvs = singletonFVInfo f how_bound fun_occ
-- Mostly, the arity info of a function is in the fn's IdInfo
-- is among the escaping vars
coreToStgLet let_no_escape bind body
- = fixLne (\ ~(_, _, _, rec_bind_lvs, _, rec_body_fvs, _, _) ->
+ = fixLne (\ ~(_, _, _, _, _, rec_body_fvs, _, _) ->
-- Do the bindings, setting live_in_cont to empty if
-- we ain't in a let-no-escape world
getVarsLiveInCont `thenLne` \ live_in_cont ->
- setVarsLiveInCont
- (if let_no_escape then live_in_cont else emptyVarSet)
- (vars_bind rec_bind_lvs rec_body_fvs bind)
- `thenLne` \ (bind2, bind_fvs, bind_escs, env_ext) ->
-
- -- The live variables of this binding are the ones which are live
- -- by virtue of being accessible via the free vars of the binding (lvs_from_fvs)
- -- together with the live_in_cont ones
- lookupLiveVarsForSet (binders `minusFVBinders` bind_fvs)
- `thenLne` \ lvs_from_fvs ->
- let
- bind_lvs = lvs_from_fvs `unionVarSet` live_in_cont
- in
-
- -- bind_fvs and bind_escs still include the binders of the let(rec)
- -- but bind_lvs does not
+ setVarsLiveInCont (if let_no_escape
+ then live_in_cont
+ else (emptyVarSet,emptyVarSet))
+ (vars_bind rec_body_fvs bind)
+ `thenLne` \ (bind2, bind_fvs, bind_escs, bind_lvs, env_ext) ->
-- Do the body
extendVarEnvLne env_ext (
- coreToStgExpr body `thenLne` \ (body2, body_fvs, body_escs) ->
- lookupLiveVarsForSet body_fvs `thenLne` \ body_lvs ->
+ coreToStgExpr body `thenLne` \(body2, body_fvs, body_escs) ->
+ freeVarsToLiveVars body_fvs `thenLne` \(body_lvs, _) ->
- returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
- body2, body_fvs, body_escs, body_lvs)
+ returnLne (bind2, bind_fvs, bind_escs, bind_lvs,
+ body2, body_fvs, body_escs, body_lvs)
+ )
- )) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
- body2, body_fvs, body_escs, body_lvs) ->
+ ) `thenLne` (\ (bind2, bind_fvs, bind_escs, bind_lvs,
+ body2, body_fvs, body_escs, body_lvs) ->
-- Compute the new let-expression
Rec pairs -> map fst pairs
mk_binding bind_lvs binder
- = (binder, LetrecBound False -- Not top level
+ = (binder, LetBound NotTopLevelBound -- Not top level
live_vars
)
where
else
unitVarSet binder
- vars_bind :: StgLiveVars
- -> FreeVarsInfo -- Free var info for body of binding
+ vars_bind :: FreeVarsInfo -- Free var info for body of binding
-> CoreBind
-> LneM (StgBinding,
- FreeVarsInfo, EscVarsSet, -- free vars; escapee vars
- [(Id, HowBound)])
- -- extension to environment
+ FreeVarsInfo,
+ EscVarsSet, -- free vars; escapee vars
+ StgLiveVars, -- vars live in binding
+ [(Id, HowBound)]) -- extension to environment
+
- vars_bind rec_bind_lvs rec_body_fvs (NonRec binder rhs)
- = coreToStgRhs rec_body_fvs NotTopLevel (binder,rhs)
- `thenLne` \ (rhs2, fvs, escs) ->
- let
- env_ext_item@(binder', _) = mk_binding rec_bind_lvs binder
- in
- returnLne (StgNonRec binder' rhs2, fvs, escs, [env_ext_item])
+ vars_bind body_fvs (NonRec binder rhs)
+ = coreToStgRhs body_fvs NotTopLevel (binder,rhs)
+ `thenLne` \ (rhs2, bind_fvs, escs) ->
- vars_bind rec_bind_lvs rec_body_fvs (Rec pairs)
- = let
- binders = map fst pairs
- env_ext = map (mk_binding rec_bind_lvs) binders
+ freeVarsToLiveVars bind_fvs `thenLne` \ (bind_lvs, bind_cafs) ->
+ let
+ env_ext_item@(binder', _) = mk_binding bind_lvs binder
in
- extendVarEnvLne env_ext (
- fixLne (\ ~(_, rec_rhs_fvs, _, _) ->
- let
- rec_scope_fvs = unionFVInfo rec_body_fvs rec_rhs_fvs
- in
- mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
+ returnLne (StgNonRec (SRTEntries bind_cafs) binder' rhs2,
+ bind_fvs, escs, bind_lvs, [env_ext_item])
+
+
+ vars_bind body_fvs (Rec pairs)
+ = fixLne (\ ~(_, rec_rhs_fvs, _, bind_lvs, _) ->
+ let
+ rec_scope_fvs = unionFVInfo body_fvs rec_rhs_fvs
+ binders = map fst pairs
+ env_ext = map (mk_binding bind_lvs) binders
+ in
+ extendVarEnvLne env_ext (
+ mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) pairs
`thenLne` \ (rhss2, fvss, escss) ->
- let
- fvs = unionFVInfos fvss
- escs = unionVarSets escss
- in
- returnLne (StgRec (binders `zip` rhss2), fvs, escs, env_ext)
- ))
+ let
+ bind_fvs = unionFVInfos fvss
+ escs = unionVarSets escss
+ in
+ freeVarsToLiveVars (binders `minusFVBinders` bind_fvs)
+ `thenLne` \ (bind_lvs, bind_cafs) ->
+ returnLne (StgRec (SRTEntries bind_cafs) (binders `zip` rhss2),
+ bind_fvs, escs, bind_lvs, env_ext)
+ )
+ )
is_join_var :: Id -> Bool
-- A hack (used only for compiler debuggging) to tell if
%************************************************************************
There's a lot of stuff to pass around, so we use this @LneM@ monad to
-help. All the stuff here is only passed {\em down}.
+help. All the stuff here is only passed *down*.
\begin{code}
type LneM a = IdEnv HowBound
- -> StgLiveVars -- vars live in continuation
+ -> (StgLiveVars, -- vars live in continuation
+ IdSet) -- cafs live in continuation
-> a
data HowBound
= ImportBound
| CaseBound
| LambdaBound
- | LetrecBound
- Bool -- True <=> bound at top level
+ | LetBound
+ TopLevelCafInfo
StgLiveVars -- Live vars... see notes below
-isLetrecBound (LetrecBound _ _) = True
-isLetrecBound other = False
+isLetBound (LetBound _ _) = True
+isLetBound other = False
\end{code}
For a let(rec)-bound variable, x, we record StgLiveVars, the set of
just x alone. If x is a let-no-escaped variable then x is represented
by a code pointer and a stack pointer (well, one for each stack). So
all of the variables needed in the execution of x are live if x is,
-and are therefore recorded in the LetrecBound constructor; x itself
+and are therefore recorded in the LetBound constructor; x itself
*is* included.
The set of live variables is guaranteed ot have no further let-no-escaped
The std monad functions:
\begin{code}
-initLne :: LneM a -> a
-initLne m = m emptyVarEnv emptyVarSet
+initLne :: IdEnv HowBound -> LneM a -> a
+initLne env m = m env (emptyVarSet,emptyVarSet)
{-# INLINE thenLne #-}
{-# INLINE returnLne #-}
returnLne e env lvs_cont = e
thenLne :: LneM a -> (a -> LneM b) -> LneM b
-thenLne m k env lvs_cont
+thenLne m k env lvs_cont
= k (m env lvs_cont) env lvs_cont
mapLne :: (a -> LneM b) -> [a] -> LneM [b]
Functions specific to this monad:
\begin{code}
-getVarsLiveInCont :: LneM StgLiveVars
+getVarsLiveInCont :: LneM (StgLiveVars, IdSet)
getVarsLiveInCont env lvs_cont = lvs_cont
-setVarsLiveInCont :: StgLiveVars -> LneM a -> LneM a
+setVarsLiveInCont :: (StgLiveVars,IdSet) -> LneM a -> LneM a
setVarsLiveInCont new_lvs_cont expr env lvs_cont
= expr env new_lvs_cont
-- only ever tacked onto a decorated expression. It is never used as
-- the basis of a control decision, which might give a black hole.
-lookupLiveVarsForSet :: FreeVarsInfo -> LneM StgLiveVars
-
-lookupLiveVarsForSet fvs env lvs_cont
- = returnLne (unionVarSets (map do_one (getFVs fvs)))
- env lvs_cont
+freeVarsToLiveVars :: FreeVarsInfo -> LneM (StgLiveVars, IdSet)
+freeVarsToLiveVars fvs env live_in_cont
+ = returnLne (lvs `unionVarSet` lvs_cont,
+ mkVarSet cafs `unionVarSet` cafs_cont)
+ env live_in_cont
where
+ (lvs_cont, cafs_cont) = live_in_cont -- not a strict pattern match!
+ (local, global) = partition isLocalId (allFVs fvs)
+
+ cafs = filter is_caf_one global
+ lvs = unionVarSets (map do_one local)
+
do_one v
= if isLocalId v then
case (lookupVarEnv env v) of
- Just (LetrecBound _ lvs) -> extendVarSet lvs v
- Just _ -> unitVarSet v
- Nothing -> pprPanic "lookupVarEnv/do_one:" (ppr v)
+ Just (LetBound _ lvs) -> extendVarSet lvs v
+ Just _ -> unitVarSet v
+ Nothing -> pprPanic "lookupLiveVarsForSet/do_one:" (ppr v)
else
emptyVarSet
-\end{code}
+ is_caf_one v
+ = case lookupVarEnv env v of
+ Just (LetBound TopLevelHasCafs lvs) ->
+ ASSERT( isEmptyVarSet lvs ) True
+ Just (LetBound _ _) -> False
+ _otherwise -> mayHaveCafRefs (idCafInfo v)
+\end{code}
%************************************************************************
%* *
%************************************************************************
\begin{code}
-type FreeVarsInfo = VarEnv (Var, Bool, StgBinderInfo)
+type FreeVarsInfo = VarEnv (Var, TopLevelCafInfo, StgBinderInfo)
-- If f is mapped to noBinderInfo, that means
-- that f *is* mentioned (else it wouldn't be in the
-- IdEnv at all), but perhaps in an unsaturated applications.
-- noBinderInfo, since we aren't interested in their
-- occurence info.
--
- -- The Bool is True <=> the Id is top level letrec bound
- --
-- For ILX we track free var info for type variables too;
-- hence VarEnv not IdEnv
+data TopLevelCafInfo
+ = NotTopLevelBound
+ | TopLevelNoCafs
+ | TopLevelHasCafs
+ deriving Eq
+
type EscVarsSet = IdSet
\end{code}
emptyFVInfo = emptyVarEnv
singletonFVInfo :: Id -> HowBound -> StgBinderInfo -> FreeVarsInfo
-singletonFVInfo id ImportBound info = emptyVarEnv
-singletonFVInfo id (LetrecBound top_level _) info = unitVarEnv id (id, top_level, info)
-singletonFVInfo id other info = unitVarEnv id (id, False, info)
+singletonFVInfo id ImportBound info
+ | mayHaveCafRefs (idCafInfo id) = unitVarEnv id (id, TopLevelHasCafs, info)
+ | otherwise = emptyVarEnv
+singletonFVInfo id (LetBound top_level _) info
+ = unitVarEnv id (id, top_level, info)
+singletonFVInfo id other info
+ = unitVarEnv id (id, NotTopLevelBound, info)
tyvarFVInfo :: TyVarSet -> FreeVarsInfo
tyvarFVInfo tvs = foldVarSet add emptyFVInfo tvs
- where
- add tv fvs = extendVarEnv fvs tv (tv, False, noBinderInfo)
+ where
+ add tv fvs = extendVarEnv fvs tv (tv, NotTopLevelBound, noBinderInfo)
unionFVInfo :: FreeVarsInfo -> FreeVarsInfo -> FreeVarsInfo
unionFVInfo fv1 fv2 = plusVarEnv_C plusFVInfo fv1 fv2
Nothing -> noBinderInfo
Just (_,_,info) -> info
+allFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
+allFVs fvs = [id | (id,_,_) <- rngVarEnv fvs]
+
getFVs :: FreeVarsInfo -> [Id] -- Non-top-level things only
-getFVs fvs = [id | (id,False,_) <- rngVarEnv fvs]
+getFVs fvs = [id | (id,NotTopLevelBound,_) <- rngVarEnv fvs]
getFVSet :: FreeVarsInfo -> IdSet
getFVSet fvs = mkVarSet (getFVs fvs)
go (Note n e) as = go e as
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
+-- Only called for the RHS of top-level lets
+hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo
+ -- predicate returns True for a given Id if we look at this Id when
+ -- calculating the result. Used to *avoid* looking at the CafInfo
+ -- field for an Id that is part of the current recursive group.
+
+hasCafRefs p expr
+ | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs
+ | otherwise = NoCafRefs
+
+ -- used for recursive groups. The whole group is set to
+ -- "MayHaveCafRefs" if at least one of the group is a CAF or
+ -- refers to any CAFs.
+hasCafRefss p exprs
+ | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs
+ | otherwise = NoCafRefs
+
+-- cafRefs compiles to beautiful code :)
+
+cafRefs p (Var id)
+ | isLocalId id = fastBool False
+ | otherwise =
+ case lookupVarEnv p id of
+ Just (LetBound TopLevelHasCafs _) -> fastBool True
+ Just (LetBound _ _) -> fastBool False
+ Nothing -> fastBool (cgMayHaveCafRefs (idCgInfo id)) -- imported Ids
+
+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))
+
+isCAF :: CoreExpr -> Bool
+-- Only called for the RHS of top-level lets
+isCAF e = not (rhsIsNonUpd e)
+ {- ToDo: check type for onceness, i.e. non-updatable thunks? -}
+
+
+rhsIsNonUpd :: 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
+
+rhsIsNonUpd (Lam b e) = isId 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
+ | Just con <- isDataConId_maybe id = not (isDynConApp con args)
+ | otherwise = n_val_args < idArity id
+
+isDynConApp :: DataCon -> [CoreExpr] -> Bool
+isDynConApp con args = isDllName (dataConName con) || any isDynArg 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.coreToStgRhs)
+
+
+isDynArg :: CoreExpr -> Bool
+isDynArg (Var v) = isDllName (idName v)
+isDynArg (Note _ e) = isDynArg e
+isDynArg (Lit lit) = isLitLitLit lit
+isDynArg (App e _) = isDynArg e -- must be a type app
+isDynArg (Lam _ e) = isDynArg e -- must be a type lam
+\end{code}
\begin{code}
lintStgBinds :: StgBinding -> LintM [Id] -- Returns the binders
-lintStgBinds (StgNonRec binder rhs)
+lintStgBinds (StgNonRec _srt binder rhs)
= lint_binds_help (binder,rhs) `thenL_`
returnL [binder]
-lintStgBinds (StgRec pairs)
+lintStgBinds (StgRec _srt pairs)
= addInScopeVars binders (
mapL lint_binds_help pairs `thenL_`
returnL binders
\begin{code}
lintStgRhs :: StgRhs -> LintM (Maybe Type)
-lintStgRhs (StgRhsClosure _ _ _ _ _ [] expr)
+lintStgRhs (StgRhsClosure _ _ _ _ [] expr)
= lintStgExpr expr
-lintStgRhs (StgRhsClosure _ _ _ _ _ binders expr)
+lintStgRhs (StgRhsClosure _ _ _ _ binders expr)
= addLoc (LambdaBodyOf binders) (
addInScopeVars binders (
lintStgExpr expr `thenMaybeL` \ body_ty ->
-- SRTs
SRT(..), noSRT,
- pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs,
- getArgPrimRep, pprStgAlts,
+ -- utils
+ stgBindHasCafRefs, stgRhsArity, getArgPrimRep,
isLitLitArg, isDllConApp, isStgTypeArg,
- stgArity, stgArgType
+ stgArgType, stgBinders,
+
+ pprStgBinding, pprStgBindings, pprStgBindingsWithSRTs, pprStgAlts
#ifdef DEBUG
, pprStgLVs
#include "HsVersions.h"
import CostCentre ( CostCentreStack, CostCentre )
+import VarSet ( IdSet, isEmptyVarSet )
import Id ( Id, idName, idPrimRep, idType )
import Name ( isDllName )
import Literal ( Literal, literalType, isLitLitLit, literalPrimRep )
import Type ( Type )
import TyCon ( TyCon )
import UniqSet ( isEmptyUniqSet, uniqSetToList, UniqSet )
+import CmdLineOpts ( opt_SccProfilingOn )
\end{code}
%************************************************************************
with respect to binder and occurrence information (just as in
@CoreSyn@):
+There is one SRT for each group of bindings.
+
\begin{code}
data GenStgBinding bndr occ
- = StgNonRec bndr (GenStgRhs bndr occ)
- | StgRec [(bndr, GenStgRhs bndr occ)]
+ = StgNonRec SRT bndr (GenStgRhs bndr occ)
+ | StgRec SRT [(bndr, GenStgRhs bndr occ)]
+
+stgBinders :: GenStgBinding bndr occ -> [bndr]
+stgBinders (StgNonRec _ b _) = [b]
+stgBinders (StgRec _ bs) = map fst bs
\end{code}
%************************************************************************
= StgRhsClosure
CostCentreStack -- CCS to be attached (default is CurrentCCS)
StgBinderInfo -- Info about how this binder is used (see below)
- SRT -- The closures's SRT
[occ] -- non-global free vars; a list, rather than
-- a set, because order is important
- UpdateFlag -- ReEntrant | Updatable | SingleEntry
+ !UpdateFlag -- ReEntrant | Updatable | SingleEntry
[bndr] -- arguments; if empty, then not a function;
-- as above, order is important.
(GenStgExpr bndr occ) -- body
[GenStgArg occ] -- args
\end{code}
+\begin{code}
+stgRhsArity :: GenStgRhs bndr occ -> Int
+stgRhsArity (StgRhsClosure _ _ _ _ args _) = length args
+stgRhsArity (StgRhsCon _ _ _) = 0
+\end{code}
+
+\begin{code}
+stgBindHasCafRefs :: GenStgBinding bndr occ -> Bool
+stgBindHasCafRefs (StgNonRec srt _ rhs)
+ = nonEmptySRT srt || rhsIsUpdatable rhs
+stgBindHasCafRefs (StgRec srt binds)
+ = nonEmptySRT srt || any rhsIsUpdatable (map snd binds)
+
+rhsIsUpdatable (StgRhsClosure _ _ _ upd _ _) = isUpdatable upd
+rhsIsUpdatable _ = False
+\end{code}
+
Here's the @StgBinderInfo@ type, and its combining op:
\begin{code}
data StgBinderInfo
case expression within this binding group has a subrange of the whole
SRT, expressed as an offset and length.
+In CoreToStg we collect the list of CafRefs at each SRT site, which is later
+converted into the length and offset form by the SRT pass.
+
\begin{code}
data SRT = NoSRT
- | SRT !Int{-offset-} !Int{-length-}
+ | SRTEntries IdSet -- generated by CoreToStg
+ | SRT !Int{-offset-} !Int{-length-} -- generated by computeSRTs
noSRT :: SRT
noSRT = NoSRT
+nonEmptySRT NoSRT = False
+nonEmptySRT (SRTEntries vs) = not (isEmptyVarSet vs)
+nonEmptySRT _ = True
+
pprSRT (NoSRT) = ptext SLIT("_no_srt_")
+pprSRT (SRTEntries ids) = text "SRT:" <> ppr ids
pprSRT (SRT off len) = parens (ppr off <> comma <> ppr len)
\end{code}
pprGenStgBinding :: (Outputable bndr, Outputable bdee, Ord bdee)
=> GenStgBinding bndr bdee -> SDoc
-pprGenStgBinding (StgNonRec bndr rhs)
- = hang (hsep [ppr bndr, equals])
- 4 ((<>) (ppr rhs) semi)
+pprGenStgBinding (StgNonRec srt bndr rhs)
+ = pprMaybeSRT srt $$ hang (hsep [ppr bndr, equals])
+ 4 ((<>) (ppr rhs) semi)
-pprGenStgBinding (StgRec pairs)
+pprGenStgBinding (StgRec srt pairs)
= vcat ((ifPprDebug (ptext SLIT("{- StgRec (begin) -}"))) :
- (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
+ pprMaybeSRT srt :
+ (map (ppr_bind) pairs) ++ [(ifPprDebug (ptext SLIT("{- StgRec (end) -}")))])
where
ppr_bind (bndr, expr)
= hang (hsep [ppr bndr, equals])
--
-- Very special! Suspicious! (SLPJ)
-pprStgExpr (StgLet (StgNonRec bndr (StgRhsClosure cc bi srt free_vars upd_flag args rhs))
+{-
+pprStgExpr (StgLet srt (StgNonRec bndr (StgRhsClosure cc bi free_vars upd_flag args rhs))
expr@(StgLet _ _))
= ($$)
(hang (hcat [ptext SLIT("let { "), ppr bndr, ptext SLIT(" = "),
interppSP args, char ']'])
8 (sep [hsep [ppr rhs, ptext SLIT("} in")]]))
(ppr expr)
+-}
-- special case: let ... in let ...
pprStgExpr (StgLet bind expr@(StgLet _ _))
= ($$)
- (sep [hang (ptext SLIT("let {")) 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
+ (sep [hang (ptext SLIT("let {"))
+ 2 (hsep [pprGenStgBinding bind, ptext SLIT("} in")])])
(ppr expr)
-- general case
=> GenStgRhs bndr bdee -> SDoc
-- special case
-pprStgRhs (StgRhsClosure cc bi srt [free_var] upd_flag [{-no args-}] (StgApp func []))
+pprStgRhs (StgRhsClosure cc bi [free_var] upd_flag [{-no args-}] (StgApp func []))
= hcat [ ppr cc,
pp_binder_info bi,
- pprMaybeSRT srt,
brackets (ifPprDebug (ppr free_var)),
ptext SLIT(" \\"), ppr upd_flag, ptext SLIT(" [] "), ppr func ]
-- general case
-pprStgRhs (StgRhsClosure cc bi srt free_vars upd_flag args body)
- = hang (hcat [ppr cc,
+pprStgRhs (StgRhsClosure cc bi free_vars upd_flag args body)
+ = hang (hsep [if opt_SccProfilingOn then ppr cc else empty,
pp_binder_info bi,
- pprMaybeSRT srt,
- brackets (ifPprDebug (interppSP free_vars)),
- ptext SLIT(" \\"), ppr upd_flag, brackets (interppSP args)])
+ ifPprDebug (brackets (interppSP free_vars)),
+ char '\\' <> ppr upd_flag, brackets (interppSP args)])
4 (ppr body)
pprStgRhs (StgRhsCon cc con args)
space, ppr con, ptext SLIT("! "), brackets (interppSP args)]
pprMaybeSRT (NoSRT) = empty
-pprMaybeSRT srt = ptext SLIT(" srt: ") <> pprSRT srt
-\end{code}
-
-Collect @IdInfo@ stuff that is most easily just snaffled straight
-from the STG bindings.
-
-\begin{code}
-stgArity :: StgRhs -> Int
-
-stgArity (StgRhsCon _ _ _) = 0 -- it's a constructor, fully applied
-stgArity (StgRhsClosure _ _ _ _ _ args _ ) = length args
+pprMaybeSRT srt = ptext SLIT("srt: ") <> pprSRT srt
\end{code}
\begin{code}
tcIdInfo unf_env in_scope_vars name ty info_ins
- = foldlTc tcPrag vanillaIdInfo info_ins
+ = foldlTc tcPrag init_info info_ins
where
- tcPrag info (HsArity arity) = returnTc (info `setArityInfo` arity)
+ -- set the CgInfo to something sensible but uninformative before
+ -- we start, because the default CgInfo is a panic.
+ init_info = vanillaIdInfo `setCgInfo` vanillaCgInfo
+
tcPrag info (HsNoCafRefs) = returnTc (info `setCafInfo` NoCafRefs)
tcPrag info HsCprInfo = returnTc (info `setCprInfo` ReturnsCPR)
+ tcPrag info (HsArity arity) =
+ returnTc (info `setArityInfo` (ArityExactly arity)
+ `setCgArity` arity)
+
tcPrag info (HsUnfold inline_prag expr)
= tcPragExpr unf_env name in_scope_vars expr `thenNF_Tc` \ maybe_expr' ->
let
tcPrag info (HsStrictness strict_info)
= returnTc (info `setStrictnessInfo` strict_info)
- tcPrag info (HsWorker nm)
- = tcWorkerInfo unf_env ty info nm
+ tcPrag info (HsWorker nm arity)
+ = tcWorkerInfo unf_env ty info nm arity
\end{code}
\begin{code}
-tcWorkerInfo unf_env ty info worker_name
- | not (hasArity arity_info)
- = pprPanic "Worker with no arity info" (ppr worker_name)
-
- | otherwise
+tcWorkerInfo unf_env ty info worker_name arity
= uniqSMToTcM (mkWrapper ty arity demands res_bot cpr_info) `thenNF_Tc` \ wrap_fn ->
let
-- Watch out! We can't pull on unf_env too eagerly!
info' = case tcLookupRecId_maybe unf_env worker_name of
- Just worker_id -> info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
- `setWorkerInfo` HasWorker worker_id arity
+ Just worker_id ->
+ info `setUnfoldingInfo` mkTopUnfolding (wrap_fn worker_id)
+ `setWorkerInfo` HasWorker worker_id arity
- Nothing -> pprTrace "tcWorkerInfo failed:" (ppr worker_name) info
+ Nothing -> pprTrace "tcWorkerInfo failed:"
+ (ppr worker_name) info
in
returnTc info'
where
- -- We are relying here on arity, cpr and strictness info always appearing
+ -- We are relying here on cpr and strictness info always appearing
-- before worker info, fingers crossed ....
- arity_info = arityInfo info
- arity = arityLowerBound arity_info
cpr_info = cprInfo info
- (demands, res_bot) = case strictnessInfo info of
- StrictnessInfo d r -> (d,r)
- _ -> (take arity (repeat wwLazy),False) -- Noncommittal
+
+ (demands, res_bot)
+ = case strictnessInfo info of
+ StrictnessInfo d r -> (d,r)
+ _ -> (take arity (repeat wwLazy),False)
+ -- Noncommittal
\end{code}
For unfoldings we try to do the job lazily, so that we never type check
genUnitTyCon, genUnitDataCon, plusTyCon, inrDataCon,
inlDataCon, crossTyCon, crossDataCon
)
-import IdInfo ( noCafOrTyGenIdInfo, setUnfoldingInfo )
+import IdInfo ( noCafNoTyGenIdInfo, setUnfoldingInfo )
import CoreUnfold ( mkTopUnfolding )
import Unique ( mkBuiltinUnique )
tycon_ty = mkTyConApp tycon tyvar_tys -- T a b c
tyvar_tys = mkTyVarTys tyvars
- from_id_info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
- to_id_info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
+ from_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding from_fn
+ to_id_info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkTopUnfolding to_fn
from_ty = mkForAllTys tyvars (mkFunTy tycon_ty rep_ty)
to_ty = mkForAllTys tyvars (mkFunTy rep_ty tycon_ty)
projects / ghc-hetmet.git / commitdiff