Commit 10cbc75d authored by simonmar's avatar simonmar

[project @ 2001-03-13 12:50:29 by simonmar]

Some rearrangements that Simon & I have been working on recently:

    - CoreSat is now CorePrep, and is a general "prepare-for-code-
      generation" pass.  It does cloning, saturation of constructors &
      primops, A-normal form, and a couple of other minor fiddlings.

    - CoreTidy no longer does cloning, and minor fiddlings.  It doesn't
      need the unique supply any more, so that's removed.

    - CoreToStg now collects CafInfo and the list of CafRefs for each
      binding.  The SRT pass is much simpler now.

    - IdInfo now has a CgInfo field for "code generator info".  It currently
      contains arity (the actual code gen arity which affects the calling
      convention as opposed to the ArityInfo which is a measure of how
      many arguments the Id can be applied to before it does any work), and
      CafInfo.

      Previously we overloaded the ArityInfo field to contain both
      codegen arity and simplifier arity.  Things are cleaner now.

    - CgInfo is collected by CoreToStg, and passed back into CoreTidy in
      a loop.  The compiler will complain rather than going into a black
      hole if the CgInfo is pulled on too early.

    - Worker info in an interface file now comes with arity info attached.
      Previously the main arity info was overloaded for this purpose, but
      it lead to a few hacks in the compiler, this tidies things up somewhat.

Bottom line: we removed several fragilities, and tidied up a number of
things.  Code size should be smaller, but we'll see...
parent b0b4be02
......@@ -48,7 +48,7 @@ module Id (
setIdTyGenInfo,
setIdWorkerInfo,
setIdSpecialisation,
setIdCafInfo,
setIdCgInfo,
setIdCprInfo,
setIdOccInfo,
......@@ -59,7 +59,9 @@ module Id (
idWorkerInfo,
idUnfolding,
idSpecialisation,
idCgInfo,
idCafInfo,
idCgArity,
idCprInfo,
idLBVarInfo,
idOccInfo,
......@@ -97,7 +99,6 @@ import FieldLabel ( FieldLabel )
import SrcLoc ( SrcLoc )
import Unique ( Unique, mkBuiltinUnique, getBuiltinUniques,
getNumBuiltinUniques )
import Outputable
infixl 1 `setIdUnfolding`,
`setIdArityInfo`,
......@@ -132,7 +133,7 @@ mkLocalIdWithInfo name ty info = Var.mkLocalId name (addFreeTyVars ty) info
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
......@@ -140,7 +141,7 @@ mkGlobalId details name ty info = Var.mkGlobalId details name (addFreeTyVars ty)
\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...
......@@ -354,13 +355,24 @@ idSpecialisation id = specInfo (idInfo id)
setIdSpecialisation :: Id -> CoreRules -> Id
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
......
......@@ -11,7 +11,7 @@ module IdInfo (
GlobalIdDetails(..), notGlobalId, -- Not abstract
IdInfo, -- Abstract
vanillaIdInfo, noTyGenIdInfo, noCafOrTyGenIdInfo, noCafIdInfo,
vanillaIdInfo, noCafNoTyGenIdInfo,
seqIdInfo, megaSeqIdInfo,
-- Zapping
......@@ -57,8 +57,14 @@ module IdInfo (
-- 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,
......@@ -73,6 +79,8 @@ module IdInfo (
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,
......@@ -96,8 +104,10 @@ infixl 1 `setDemandInfo`,
`setCprInfo`,
`setWorkerInfo`,
`setLBVarInfo`,
`setOccInfo`,
`setCgInfo`,
`setCafInfo`,
`setOccInfo`
`setCgArity`
-- infixl so you can say (id `set` a `set` b)
\end{code}
......@@ -168,7 +178,7 @@ data IdInfo
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
......@@ -191,7 +201,9 @@ megaSeqIdInfo info
-- 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)
......@@ -228,7 +240,7 @@ setUnfoldingInfo info uf
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}
......@@ -238,7 +250,7 @@ setLBVarInfo info lb = info { lbvarInfo = lb }
vanillaIdInfo :: IdInfo
vanillaIdInfo
= IdInfo {
cafInfo = MayHaveCafRefs, -- Safe!
cgInfo = noCgInfo,
arityInfo = UnknownArity,
demandInfo = wwLazy,
specInfo = emptyCoreRules,
......@@ -252,15 +264,11 @@ vanillaIdInfo
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}
......@@ -309,8 +317,8 @@ hasArity UnknownArity = False
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}
%************************************************************************
......@@ -445,6 +453,23 @@ There might not be a worker, even for a strict function, because:
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
......@@ -473,14 +498,42 @@ wrapperArity (HasWorker _ a) = a
%************************************************************************
%* *
\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
......@@ -490,19 +543,29 @@ data CafInfo
| 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}
%************************************************************************
%* *
......
......@@ -71,11 +71,12 @@ import Id ( idType, mkGlobalId, mkVanillaGlobal,
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
......@@ -137,7 +138,8 @@ mkDataConId :: Name -> DataCon -> Id
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
......@@ -199,11 +201,12 @@ mkDataConWrapId data_con
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
......@@ -393,8 +396,8 @@ mkRecordSelId tycon field_label unpack_id unpackUtf8_id
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
......@@ -519,7 +522,8 @@ mkDictSelId name clas
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
......@@ -563,8 +567,9 @@ mkPrimOpId prim_op
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
......@@ -594,7 +599,8 @@ mkCCallOpId uniq ccall ty
name = mkCCallName uniq occ_str
prim_op = CCallOp ccall
info = noCafOrTyGenIdInfo
info = noCafNoTyGenIdInfo
`setCgArity` arity
`setArityInfo` exactArity arity
`setStrictnessInfo` strict_info
......@@ -613,7 +619,7 @@ mkCCallOpId uniq ccall ty
\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
......@@ -623,10 +629,10 @@ mkDictFunId :: Name -- Name to use for the dict fun;
-> 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
......@@ -680,7 +686,7 @@ another gun with which to shoot yourself in the foot.
unsafeCoerceId
= pcMiscPrelId unsafeCoerceIdKey pREL_GHC SLIT("unsafeCoerce#") ty info
where
info = noCafOrTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
info = noCafNoTyGenIdInfo `setUnfoldingInfo` mkCompulsoryUnfolding rhs
ty = mkForAllTys [openAlphaTyVar,openBetaTyVar]
......@@ -698,7 +704,7 @@ evaluate its argument and call the dataToTag# primitive.
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)
......@@ -716,7 +722,7 @@ nasty as-is, change it back to a literal (@Literal@).
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
......@@ -769,7 +775,7 @@ aBSENT_ERROR_ID
pAR_ERROR_ID
= pcMiscPrelId parErrorIdKey pREL_ERR SLIT("parError")
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafOrTyGenIdInfo
(mkSigmaTy [openAlphaTyVar] [] openAlphaTy) noCafNoTyGenIdInfo
\end{code}
......@@ -796,9 +802,9 @@ pcMiscPrelId key mod str ty info
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 $
%
%********************************************************
%* *
......@@ -208,14 +208,14 @@ cgExpr (StgCase expr live_vars save_vars bndr srt alts)
\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`
......@@ -274,17 +274,15 @@ We rely on the support code in @CgCon@ (to do constructors) and
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}
......@@ -391,17 +389,19 @@ mkRhsClosure bndr cc bi srt fvs upd_flag args body
%* *
%********************************************************
\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 ->
......@@ -416,25 +416,27 @@ cgLetNoEscapeRhs
-> 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}
......@@ -79,7 +79,7 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
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
)
......@@ -261,16 +261,11 @@ mkLFLetNoEscape = LFLetNoEscape
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}
%************************************************************************
......
......@@ -188,7 +188,7 @@ variable.
\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
......@@ -196,11 +196,11 @@ cgTopBinding (StgNonRec id rhs, srt)
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
......@@ -214,7 +214,7 @@ cgTopBinding (StgRec pairs, srt)
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
)
......@@ -256,18 +256,18 @@ maybeSplitCode
-- 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 =
......
......@@ -4,13 +4,13 @@
\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
......@@ -18,13 +18,16 @@ import Type ( Type, applyTy, splitFunTy_maybe, isTyVarTy,
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
......@@ -37,21 +40,7 @@ import Outputable
-- Overview
-- ---------------------------------------------------------------------------