-
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: ClosureInfo.lhs,v 1.61 2003/11/17 14:23:31 simonmar Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
the STG paper.
\begin{code}
-#include "HsVersions.h"
-
module ClosureInfo (
ClosureInfo, LambdaFormInfo, SMRep, -- all abstract
- StandardFormInfo,
+ StandardFormInfo, ArgDescr(..),
- EntryConvention(..),
+ CallingConvention(..),
- mkClosureLFInfo, mkConLFInfo,
- mkLFImported, mkLFArgument, mkLFLetNoEscape,
+ mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo,
+ mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
- closureSize, closureHdrSize,
- closureNonHdrSize, closureSizeWithoutFixedHdr,
+ closureSize, closureNonHdrSize,
closureGoodStuffSize, closurePtrsSize,
- slopSize, fitsMinUpdSize,
+ slopSize,
+
+ layOutDynClosure, layOutStaticClosure, layOutStaticNoFVClosure,
+ layOutDynConstr, layOutStaticConstr,
+ mkVirtHeapOffsets, mkStaticClosure,
- layOutDynClosure, layOutDynCon, layOutStaticClosure,
- layOutStaticNoFVClosure, layOutPhantomClosure,
- mkVirtHeapOffsets, -- for GHCI
+ nodeMustPointToIt, getEntryConvention,
+ FCode, CgInfoDownwards, CgState,
- nodeMustPointToIt, getEntryConvention,
blackHoleOnEntry,
staticClosureRequired,
- slowFunEntryCodeRequired, funInfoTableRequired,
- stdVapRequired, noUpdVapRequired,
- closureId, infoTableLabelFromCI,
- closureLabelFromCI,
- entryLabelFromCI, fastLabelFromCI,
+ closureName, infoTableLabelFromCI,
+ closureLabelFromCI, closureSRT,
+ entryLabelFromCI,
closureLFInfo, closureSMRep, closureUpdReqd,
- closureSingleEntry, closureSemiTag, closureType,
- closureReturnsUnboxedType, getStandardFormThunkInfo,
+ closureSingleEntry, closureReEntrant, closureSemiTag,
+ closureFunInfo, isStandardFormThunk,
- closureKind, closureTypeDescr, -- profiling
+ isToplevClosure,
+ closureTypeDescr, -- profiling
- isStaticClosure, allocProfilingMsg,
- blackHoleClosureInfo,
- maybeSelectorInfo,
+ isStaticClosure,
+ allocProfilingMsg,
+ cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo,
- dataConLiveness -- concurrency
+ staticClosureNeedsLink,
+
+ mkInfoTable, mkRetInfoTable, mkVecInfoTable,
) where
-import Ubiq{-uitous-}
-import AbsCLoop -- here for paranoia-checking
+#include "../includes/config.h"
+#include "../includes/MachDeps.h"
+#include "HsVersions.h"
-import AbsCSyn
+import AbsCSyn
import StgSyn
import CgMonad
-import CgCompInfo ( mAX_SPEC_SELECTEE_SIZE,
- mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject,
- mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS,
- mAX_SPEC_ALL_NONPTRS,
- oTHER_TAG
+import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
+import CgRetConv ( assignRegs )
+import CLabel
+import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
+ opt_Parallel, opt_DoTickyProfiling,
+ opt_SMP, opt_Unregisterised )
+import Id ( Id, idType, idArity, idName, idPrimRep )
+import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon,
+ isNullaryDataCon, dataConName
)
-import CgRetConv ( assignRegs, dataReturnConvAlg,
- DataReturnConvention(..)
- )
-import CLabel ( mkStdEntryLabel, mkFastEntryLabel,
- mkPhantomInfoTableLabel, mkInfoTableLabel,
- mkBlackHoleInfoTableLabel, mkVapInfoTableLabel,
- mkStaticInfoTableLabel, mkStaticConEntryLabel,
- mkConEntryLabel, mkClosureLabel, mkVapEntryLabel
- )
-import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent )
-import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize,
- intOffsetIntoGoods,
- VirtualHeapOffset(..)
- )
-import Id ( idType, idPrimRep, getIdArity,
- externallyVisibleId, dataConSig,
- dataConTag, fIRST_TAG,
- isDataCon, dataConArity, dataConTyCon,
- isTupleCon, DataCon(..),
- GenId{-instance Eq-}
- )
-import IdInfo ( arityMaybe )
-import Maybes ( assocMaybe, maybeToBool )
-import Outputable ( isLocallyDefined, getLocalName )
-import PprStyle ( PprStyle(..) )
-import PprType ( GenType{-instance Outputable-} )
-import PrimRep ( getPrimRepSize, separateByPtrFollowness )
+import Name ( Name, nameUnique, getOccName, getName, getOccString )
+import OccName ( occNameUserString )
+import PrimRep
import SMRep -- all of it
-import TyCon ( maybeTyConSingleCon, TyCon{-instance NamedThing-} )
-import Type ( isPrimType, splitForAllTy, splitFunTy, mkFunTys )
-import Util ( isIn, mapAccumL, panic, pprPanic, assertPanic )
-
-maybeCharLikeTyCon = panic "ClosureInfo.maybeCharLikeTyCon (ToDo)"
-maybeIntLikeTyCon = panic "ClosureInfo.maybeIntLikeTyCon (ToDo)"
-getDataSpecTyCon_maybe = panic "ClosureInfo.getDataSpecTyCon_maybe (ToDo)"
-getTyDescription = panic "ClosureInfo.getTyDescription (ToDo)"
-\end{code}
-
-The ``wrapper'' data type for closure information:
-
-\begin{code}
-data ClosureInfo
- = MkClosureInfo
- Id -- The thing bound to this closure
- LambdaFormInfo -- info derivable from the *source*
- SMRep -- representation used by storage manager
+import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe )
+import TcType ( tcSplitSigmaTy )
+import TyCon ( isFunTyCon )
+import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, ipNameName )
+import Util ( mapAccumL, listLengthCmp, lengthIs )
+import FastString
+import Outputable
+import Literal
+import Constants
+import Bitmap
+
+import Maybe ( isJust )
+import DATA_BITS
+
+import TypeRep -- TEMP
\end{code}
%************************************************************************
%* *
-\subsection[ClosureInfo-OLD-DOC]{OLD DOCUMENTATION PROBABLY SUPERCEDED BY stg-details}
+\subsection[ClosureInfo-datatypes]{Data types for closure information}
%* *
%************************************************************************
-We can optimise the function-entry code as follows.
-\begin{itemize}
-
-\item If the ``function'' is not updatable, we can jump directly to its
- entry code, rather than indirecting via the info pointer in the
- closure. (For updatable thunks we must go via the closure, in
- case it has been updated.)
-
-\item If the former bullet applies, and the application we are
- compiling gives the function as many arguments as it needs, we
- can jump to its fast-entry code. (This only applies if the
- function has one or more args, because zero-arg closures have
- no fast-entry code.)
-
-\item If the function is a top-level non-constructor or imported, there
- is no need to make Node point to its closure. In order for
- this to be right, we need to ensure that:
- \begin{itemize}
- \item If such closures are updatable then they push their
- static address in the update frame, not Node. Actually
- we create a black hole and push its address.
-
- \item The arg satisfaction check should load Node before jumping to
- UpdatePAP.
-
- \item Top-level constructor closures need careful handling. If we are to
- jump direct to the constructor code, we must load Node first, even
- though they are top-level. But if we go to their ``own''
- standard-entry code (which loads Node and then jumps to the
- constructor code) we don't need to load Node.
- \end{itemize}
-\end{itemize}
-
-
-{\em Top level constructors (@mkStaticConEntryInfo@)}
-
-\begin{verbatim}
- x = {y,ys} \ {} Cons {y,ys} -- Std form constructor
-\end{verbatim}
-
-x-closure: Cons-info-table, y-closure, ys-closure
-
-x-entry: Node = x-closure; jump( Cons-entry )
+Information about a closure, from the code generator's point of view.
-x's EntryInfo in its own module:
-\begin{verbatim}
- Base-label = Cons -- Not x!!
- NodeMustPoint = True
- ClosureClass = Constructor
-\end{verbatim}
+A ClosureInfo decribes the info pointer of a closure. It has
+enough information
+ a) to construct the info table itself
+ b) to allocate a closure containing that info pointer (i.e.
+ it knows the info table label)
- So if x is entered, Node will be set up and
- we'll jump direct to the Cons code.
+We make a ClosureInfo for
+ - each let binding (both top level and not)
+ - each data constructor (for its shared static and
+ dynamic info tables)
-x's EntryInfo in another module: (which may not know that x is a constructor)
-\begin{verbatim}
- Base-label = x -- Is x!!
- NodeMustPoint = False -- All imported things have False
- ClosureClass = non-committal
-\end{verbatim}
-
- If x is entered, we'll jump to x-entry, which will set up Node
- before jumping to the standard Cons code
-
-{\em Top level non-constructors (@mkStaticEntryInfo@)}
-\begin{verbatim}
- x = ...
-\end{verbatim}
-
-For updatable thunks, x-entry must push an allocated BH in update frame, not Node.
-
-For non-zero arity, arg satis check must load Node before jumping to
- UpdatePAP.
-
-x's EntryInfo in its own module:
-\begin{verbatim}
- Base-label = x
- NodeMustPoint = False
- ClosureClass = whatever
-\end{verbatim}
-
-{\em Inner constructors (@mkConEntryInfo@)}
-
-\begin{verbatim}
- Base-label = Cons -- Not x!!
- NodeMustPoint = True -- If its arity were zero, it would
- -- have been lifted to top level
- ClosureClass = Constructor
-\end{verbatim}
-
-{\em Inner non-constructors (@mkEntryInfo@)}
-
-\begin{verbatim}
- Base-label = x
- NodeMustPoint = True -- If no free vars, would have been
- -- lifted to top level
- ClosureClass = whatever
-\end{verbatim}
-
-{\em Imported}
-
-\begin{verbatim}
- Nothing,
- or
- Base-label = x
- NodeMustPoint = False
- ClosureClass = whatever
-\end{verbatim}
-
-==============
-THINK: we could omit making Node point to top-level constructors
-of arity zero; but that might interact nastily with updates.
-==============
-
-
-==========
-The info we need to import for imported things is:
-
-\begin{verbatim}
- data ImportInfo = UnknownImportInfo
- | HnfImport Int -- Not updatable, arity given
- -- Arity can be zero, for (eg) constrs
- | UpdatableImport -- Must enter via the closure
-\end{verbatim}
-
-ToDo: move this stuff???
-
-\begin{pseudocode}
-mkStaticEntryInfo lbl cl_class
- = MkEntryInfo lbl False cl_class
-
-mkStaticConEntryInfo lbl
- = MkEntryInfo lbl True ConstructorClosure
-
-mkEntryInfo lbl cl_class
- = MkEntryInfo lbl True cl_class
-
-mkConEntryInfo lbl
- = MkEntryInfo lbl True ConstructorClosure
-\end{pseudocode}
-
-%************************************************************************
-%* *
-\subsection[ClosureInfo-datatypes]{Data types for closure information}
-%* *
-%************************************************************************
+\begin{code}
+data ClosureInfo
+ = ClosureInfo {
+ closureName :: !Name, -- The thing bound to this closure
+ closureLFInfo :: !LambdaFormInfo, -- NOTE: not an LFCon (see below)
+ closureSMRep :: !SMRep, -- representation used by storage mgr
+ closureSRT :: !C_SRT, -- What SRT applies to this closure
+ closureType :: !Type, -- Type of closure (ToDo: remove)
+ closureDescr :: !String -- closure description (for profiling)
+ }
+
+ -- constructor closures don't have a unique info table label (they use
+ -- the constructor's info table), and they don't have an SRT.
+ | ConInfo {
+ closureCon :: !DataCon,
+ closureSMRep :: !SMRep
+ }
+\end{code}
%************************************************************************
%* *
%* *
%************************************************************************
+Information about an identifier, from the code generator's point of
+view. Every identifier is bound to a LambdaFormInfo in the
+environment, which gives the code generator enough info to be able to
+tail call or return that identifier.
+
+Note that a closure is usually bound to an identifier, so a
+ClosureInfo contains a LambdaFormInfo.
+
\begin{code}
data LambdaFormInfo
- = LFReEntrant -- Reentrant closure; used for PAPs too
- Bool -- True if top level
- Int -- Arity
- Bool -- True <=> no fvs
+ = LFReEntrant -- Reentrant closure (a function)
+ TopLevelFlag -- True if top level
+ !Int -- Arity
+ !Bool -- True <=> no fvs
+ ArgDescr -- Argument descriptor (should reall be in ClosureInfo)
| LFCon -- Constructor
- DataCon -- The constructor (may be specialised)
- Bool -- True <=> zero arity
-
- | LFTuple -- Tuples
- DataCon -- The tuple constructor (may be specialised)
- Bool -- True <=> zero arity
+ DataCon -- The constructor
| LFThunk -- Thunk (zero arity)
- Bool -- True <=> top level
- Bool -- True <=> no free vars
- Bool -- True <=> updatable (i.e., *not* single-entry)
+ TopLevelFlag
+ !Bool -- True <=> no free vars
+ !Bool -- True <=> updatable (i.e., *not* single-entry)
StandardFormInfo
+ !Bool -- True <=> *might* be a function type
- | LFArgument -- Used for function arguments. We know nothing about
- -- this closure. Treat like updatable "LFThunk"...
-
- | LFImported -- Used for imported things. We know nothing about this
- -- closure. Treat like updatable "LFThunk"...
+ | LFUnknown -- Used for function arguments and imported things.
+ -- We know nothing about this closure. Treat like
+ -- updatable "LFThunk"...
-- Imported things which we do know something about use
-- one of the other LF constructors (eg LFReEntrant for
-- known functions)
+ !Bool -- True <=> *might* be a function type
| LFLetNoEscape -- See LetNoEscape module for precise description of
-- these "lets".
- Int -- arity;
- StgLiveVars-- list of variables live in the RHS of the let.
- -- (ToDo: maybe not used)
+ !Int -- arity;
| LFBlackHole -- Used for the closures allocated to hold the result
-- of a CAF. We want the target of the update frame to
-- be in the heap, so we make a black hole to hold it.
+ CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info).
- -- This last one is really only for completeness;
- -- it isn't actually used for anything interesting
- {- | LFIndirection -}
data StandardFormInfo -- Tells whether this thunk has one of a small number
-- of standard forms
= NonStandardThunk -- No, it isn't
- | SelectorThunk
- Id -- Scrutinee
- DataCon -- Constructor
- Int -- 0-origin offset of ak within the "goods" of constructor
- -- (Recall that the a1,...,an may be laid out in the heap
- -- in a non-obvious order.)
+ | SelectorThunk
+ Int -- 0-origin offset of ak within the "goods" of
+ -- constructor (Recall that the a1,...,an may be laid
+ -- out in the heap in a non-obvious order.)
{- A SelectorThunk is of form
con a1,..,an -> ak
and the constructor is from a single-constr type.
- If we can't convert the heap-offset of the selectee into an Int, e.g.,
- it's "GEN_VHS+i", we just give up.
-}
- | VapThunk
- Id -- Function
- [StgArg] -- Args
- Bool -- True <=> the function is not top-level, so
- -- must be stored in the thunk too
+ | ApThunk
+ Int -- arity
-{- A VapThunk is of form
+{- An ApThunk is of form
- f a1 ... an
+ x1 ... xn
- where f is a known function, with arity n
- So for this thunk we can use the label for f's heap-entry
- info table (generated when f's defn was dealt with),
- rather than generating a one-off info table and entry code
- for this one thunk.
+ The code for the thunk just pushes x2..xn on the stack and enters x1.
+ There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled
+ in the RTS to save space.
-}
-
-mkLFArgument = LFArgument
-mkLFBlackHole = LFBlackHole
-mkLFLetNoEscape = LFLetNoEscape
-
-mkLFImported :: Id -> LambdaFormInfo
-mkLFImported id
- = case arityMaybe (getIdArity id) of
- Nothing -> LFImported
- Just 0 -> LFThunk True{-top-lev-} True{-no fvs-}
- True{-updatable-} NonStandardThunk
- Just n -> LFReEntrant True n True -- n > 0
\end{code}
%************************************************************************
@mkClosureLFInfo@ figures out the appropriate LFInfo for the closure.
\begin{code}
-mkClosureLFInfo :: Bool -- True of top level
+mkClosureLFInfo :: Id -- The binder
+ -> TopLevelFlag -- True of top level
-> [Id] -- Free vars
-> UpdateFlag -- Update flag
-> [Id] -- Args
- -> StgExpr -- Body of closure: passed so we
- -- can look for selector thunks!
-> LambdaFormInfo
-mkClosureLFInfo top fvs upd_flag args@(_:_) body -- Non-empty args
- = LFReEntrant top (length args) (null fvs)
+mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args
+ = LFReEntrant top (length args) (null fvs) (mkArgDescr (getName bndr) args)
-mkClosureLFInfo top fvs ReEntrant [] body
- = LFReEntrant top 0 (null fvs)
-\end{code}
-
-OK, this is where we look at the body of the closure to see if it's a
-selector---turgid, but nothing deep. We are looking for a closure of
-{\em exactly} the form:
-\begin{verbatim}
-... = [the_fv] \ u [] ->
- case the_fv of
- con a_1 ... a_n -> a_i
-\end{verbatim}
-Here we go:
-\begin{code}
-mkClosureLFInfo False -- don't bother if at top-level
- [the_fv] -- just one...
- Updatable
- [] -- no args (a thunk)
- (StgCase (StgApp (StgVarArg scrutinee) [{-no args-}] _)
- _ _ _ -- ignore live vars and uniq...
- (StgAlgAlts case_ty
- [(con, params, use_mask,
- (StgApp (StgVarArg selectee) [{-no args-}] _))]
- StgNoDefault))
- | the_fv == scrutinee -- Scrutinee is the only free variable
- && maybeToBool maybe_offset -- Selectee is a component of the tuple
- && maybeToBool offset_into_int_maybe
- && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough
- =
- -- ASSERT(is_single_constructor) -- Should be true, by causes error for SpecTyCon
- LFThunk False False True (SelectorThunk scrutinee con offset_into_int)
+mkClosureLFInfo bndr top fvs upd_flag []
+ = ASSERT( not updatable || not (isUnLiftedType id_ty) )
+ LFThunk top (null fvs) updatable NonStandardThunk
+ (might_be_a_function id_ty)
where
- (_, params_w_offsets) = layOutDynCon con idPrimRep params
- maybe_offset = assocMaybe params_w_offsets selectee
- Just the_offset = maybe_offset
- offset_into_int_maybe = intOffsetIntoGoods the_offset
- Just offset_into_int = offset_into_int_maybe
- is_single_constructor = maybeToBool (maybeTyConSingleCon tycon)
- (_,_,_, tycon) = dataConSig con
+ updatable = isUpdatable upd_flag
+ id_ty = idType bndr
+
+might_be_a_function :: Type -> Bool
+might_be_a_function ty
+ | Just (tc,_) <- splitTyConApp_maybe (repType ty),
+ not (isFunTyCon tc) = False
+ | otherwise = True
\end{code}
-Same kind of thing, looking for vector-apply thunks, of the form:
-
- x = [...] \ .. [] -> f a1 .. an
-
-where f has arity n. We rely on the arity info inside the Id being correct.
+@mkConLFInfo@ is similar, for constructors.
\begin{code}
-mkClosureLFInfo top_level
- fvs
- upd_flag
- [] -- No args; a thunk
- (StgApp (StgVarArg fun_id) args _)
- | not top_level -- A top-level thunk would require a static
- -- vap_info table, which we don't generate just
- -- now; so top-level thunks are never standard
- -- form.
- && isLocallyDefined fun_id -- Must be defined in this module
- && maybeToBool arity_maybe -- A known function with known arity
- && fun_arity > 0 -- It'd better be a function!
- && fun_arity == length args -- Saturated application
- = LFThunk top_level (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args store_fun_in_vap)
- where
- arity_maybe = arityMaybe (getIdArity fun_id)
- Just fun_arity = arity_maybe
-
- -- If the function is a free variable then it must be stored
- -- in the thunk too; if it isn't a free variable it must be
- -- because it's constant, so it doesn't need to be stored in the thunk
- store_fun_in_vap = fun_id `is_elem` fvs
-
- is_elem = isIn "mkClosureLFInfo"
-\end{code}
+mkConLFInfo :: DataCon -> LambdaFormInfo
+mkConLFInfo con = LFCon con
-Finally, the general updatable-thing case:
-\begin{code}
-mkClosureLFInfo top fvs upd_flag [] body
- = LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk
+mkSelectorLFInfo id offset updatable
+ = LFThunk NotTopLevel False updatable (SelectorThunk offset)
+ (might_be_a_function (idType id))
-isUpdatable ReEntrant = False
-isUpdatable SingleEntry = False
-isUpdatable Updatable = True
+mkApLFInfo id upd_flag arity
+ = LFThunk NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity)
+ (might_be_a_function (idType id))
\end{code}
-@mkConLFInfo@ is similar, for constructors.
+Miscellaneous LF-infos.
\begin{code}
-mkConLFInfo :: DataCon -> LambdaFormInfo
+mkLFArgument id = LFUnknown (might_be_a_function (idType id))
-mkConLFInfo con
- = ASSERT(isDataCon con)
- let
- arity = dataConArity con
- in
- if isTupleCon con then
- LFTuple con (arity == 0)
- else
- LFCon con (arity == 0)
-\end{code}
+mkLFLetNoEscape = LFLetNoEscape
+mkLFImported :: Id -> LambdaFormInfo
+mkLFImported id
+ = case idArity id of
+ n | n > 0 -> LFReEntrant TopLevel n True (panic "arg_descr") -- n > 0
+ other -> mkLFArgument id -- Not sure of exact arity
+\end{code}
%************************************************************************
%* *
\begin{code}
closureSize :: ClosureInfo -> HeapOffset
-closureSize cl_info@(MkClosureInfo _ _ sm_rep)
- = totHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info))
-
-closureSizeWithoutFixedHdr :: ClosureInfo -> HeapOffset
-closureSizeWithoutFixedHdr cl_info@(MkClosureInfo _ _ sm_rep)
- = varHdrSize sm_rep `addOff` (intOff (closureNonHdrSize cl_info))
-
-closureHdrSize :: ClosureInfo -> HeapOffset
-closureHdrSize (MkClosureInfo _ _ sm_rep)
- = totHdrSize sm_rep
+closureSize cl_info = fixedHdrSize + closureNonHdrSize cl_info
closureNonHdrSize :: ClosureInfo -> Int
-closureNonHdrSize cl_info@(MkClosureInfo _ lf_info sm_rep)
- = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info) --ToDo: pass lf_info?
+closureNonHdrSize cl_info
+ = tot_wds + computeSlopSize tot_wds
+ (closureSMRep cl_info)
+ (closureNeedsUpdSpace cl_info)
where
tot_wds = closureGoodStuffSize cl_info
+-- we leave space for an update if either (a) the closure is updatable
+-- or (b) it is a static thunk. This is because a static thunk needs
+-- a static link field in a predictable place (after the slop), regardless
+-- of whether it is updatable or not.
+closureNeedsUpdSpace (ClosureInfo { closureLFInfo =
+ LFThunk TopLevel _ _ _ _ }) = True
+closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
+
+slopSize :: ClosureInfo -> Int
+slopSize cl_info
+ = computeSlopSize (closureGoodStuffSize cl_info)
+ (closureSMRep cl_info)
+ (closureNeedsUpdSpace cl_info)
+
closureGoodStuffSize :: ClosureInfo -> Int
-closureGoodStuffSize (MkClosureInfo _ _ sm_rep)
- = let (ptrs, nonptrs) = sizes_from_SMRep sm_rep
+closureGoodStuffSize cl_info
+ = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs + nonptrs
closurePtrsSize :: ClosureInfo -> Int
-closurePtrsSize (MkClosureInfo _ _ sm_rep)
- = let (ptrs, _) = sizes_from_SMRep sm_rep
+closurePtrsSize cl_info
+ = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info)
in ptrs
-- not exported:
-sizes_from_SMRep (SpecialisedRep k ptrs nonptrs _) = (ptrs, nonptrs)
-sizes_from_SMRep (GenericRep ptrs nonptrs _) = (ptrs, nonptrs)
-sizes_from_SMRep (BigTupleRep ptrs) = (ptrs, 0)
-sizes_from_SMRep (MuTupleRep ptrs) = (ptrs, 0)
-sizes_from_SMRep (DataRep nonptrs) = (0, nonptrs)
-sizes_from_SMRep BlackHoleRep = (0, 0)
-sizes_from_SMRep (StaticRep ptrs nonptrs) = (ptrs, nonptrs)
-#ifdef DEBUG
-sizes_from_SMRep PhantomRep = panic "sizes_from_SMRep: PhantomRep"
-sizes_from_SMRep DynamicRep = panic "sizes_from_SMRep: DynamicRep"
-#endif
-\end{code}
-
-\begin{code}
-fitsMinUpdSize :: ClosureInfo -> Bool
-fitsMinUpdSize (MkClosureInfo _ _ BlackHoleRep) = True
-fitsMinUpdSize cl_info = isSpecRep (closureSMRep cl_info) && closureNonHdrSize cl_info <= mIN_UPD_SIZE
+sizes_from_SMRep :: SMRep -> (Int,Int)
+sizes_from_SMRep (GenericRep _ ptrs nonptrs _) = (ptrs, nonptrs)
+sizes_from_SMRep BlackHoleRep = (0, 0)
\end{code}
Computing slop size. WARNING: this looks dodgy --- it has deep
Updateable closures must be @mIN_UPD_SIZE@.
\begin{itemize}
\item
- Cons cell requires 2 words
- \item
Indirections require 1 word
\item
Appels collector indirections 2 words
Copying collector forward pointer requires 1 word
THEREFORE: @mIN_SIZE_NonUpdHeapObject = 1@
-
-\item
-@SpecialisedRep@ closures closures may require slop:
- \begin{itemize}
- \item
- @ConstantRep@ and @CharLikeRep@ closures always use the address of
- a static closure. They are never allocated or
- collected (eg hold forwarding pointer) hence never any slop.
-
- \item
- @IntLikeRep@ are never updatable.
- May need slop to be collected (as they will be size 1 or more
- this probably has no affect)
-
- \item
- @SpecRep@ may be updateable and will be collectable
-
- \item
- @StaticRep@ may require slop if updatable. Non-updatable ones are OK.
-
- \item
- @GenericRep@ closures will always be larger so never require slop.
- \end{itemize}
-
- ***** ToDo: keep an eye on this!
\end{itemize}
-\begin{code}
-slopSize cl_info@(MkClosureInfo _ lf_info sm_rep)
- = computeSlopSize (closureGoodStuffSize cl_info) sm_rep (closureUpdReqd cl_info)
+Static closures have an extra ``static link field'' at the end, but we
+don't bother taking that into account here.
+\begin{code}
computeSlopSize :: Int -> SMRep -> Bool -> Int
-computeSlopSize tot_wds (SpecialisedRep ConstantRep _ _ _) _
- = 0
-computeSlopSize tot_wds (SpecialisedRep CharLikeRep _ _ _) _
- = 0
-
-computeSlopSize tot_wds (SpecialisedRep _ _ _ _) True -- Updatable
- = max 0 (mIN_UPD_SIZE - tot_wds)
-computeSlopSize tot_wds (StaticRep _ _) True -- Updatable
- = max 0 (mIN_UPD_SIZE - tot_wds)
-computeSlopSize tot_wds BlackHoleRep _ -- Updatable
+computeSlopSize tot_wds (GenericRep _ _ _ _) True -- Updatable
= max 0 (mIN_UPD_SIZE - tot_wds)
-computeSlopSize tot_wds (SpecialisedRep _ _ _ _) False -- Not updatable
- = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds)
+computeSlopSize tot_wds (GenericRep True _ _ _) False -- Non updatable
+ = 0 -- Static
-computeSlopSize tot_wds other_rep _ -- Any other rep
- = 0
+computeSlopSize tot_wds (GenericRep False _ _ _) False -- Non updatable
+ = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds) -- Dynamic
+
+computeSlopSize tot_wds BlackHoleRep _ -- Updatable
+ = max 0 (mIN_UPD_SIZE - tot_wds)
\end{code}
%************************************************************************
%* *
-\subsection[layOutDynClosure]{Lay out a dynamic closure}
+\subsection[layOutDynClosure]{Lay out a closure}
%* *
%************************************************************************
\begin{code}
layOutDynClosure, layOutStaticClosure
- :: Id -- STG identifier w/ which this closure assoc'd
- -> (a -> PrimRep) -- function w/ which to be able to get a PrimRep
+ :: Id -- STG identifier of this closure
+ -> (a -> PrimRep) -- how to get a PrimRep for the fields
-> [a] -- the "things" being layed out
-> LambdaFormInfo -- what sort of closure it is
+ -> C_SRT -- its SRT
+ -> String -- closure description
-> (ClosureInfo, -- info about the closure
[(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them
-layOutDynClosure name kind_fn things lf_info
- = (MkClosureInfo name lf_info sm_rep,
+layOutDynClosure = layOutClosure False
+layOutStaticClosure = layOutClosure True
+
+layOutStaticNoFVClosure id lf_info srt_info descr
+ = fst (layOutClosure True id (panic "kind_fn") [] lf_info srt_info descr)
+
+layOutClosure
+ :: Bool -- True <=> static closure
+ -> Id -- STG identifier of this closure
+ -> (a -> PrimRep) -- how to get a PrimRep for the fields
+ -> [a] -- the "things" being layed out
+ -> LambdaFormInfo -- what sort of closure it is
+ -> C_SRT -- its SRT
+ -> String -- closure description
+ -> (ClosureInfo, -- info about the closure
+ [(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them
+
+layOutClosure is_static id kind_fn things lf_info srt_info descr
+ = (ClosureInfo { closureName = name,
+ closureLFInfo = lf_info,
+ closureSMRep = sm_rep,
+ closureSRT = srt_info,
+ closureType = idType id,
+ closureDescr = descr },
things_w_offsets)
where
+ name = idName id
(tot_wds, -- #ptr_wds + #nonptr_wds
ptr_wds, -- #ptr_wds
- things_w_offsets) = mkVirtHeapOffsets sm_rep kind_fn things
- sm_rep = chooseDynSMRep lf_info tot_wds ptr_wds
+ things_w_offsets) = mkVirtHeapOffsets kind_fn things
+ sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
-layOutStaticClosure name kind_fn things lf_info
- = (MkClosureInfo name lf_info (StaticRep ptr_wds (tot_wds - ptr_wds)),
- things_w_offsets)
+
+layOutDynConstr, layOutStaticConstr
+ :: DataCon
+ -> (a -> PrimRep)
+ -> [a]
+ -> (ClosureInfo,
+ [(a,VirtualHeapOffset)])
+
+layOutDynConstr = layOutConstr False
+layOutStaticConstr = layOutConstr True
+
+layOutConstr is_static data_con kind_fn args
+ = (ConInfo { closureSMRep = sm_rep,
+ closureCon = data_con },
+ things_w_offsets)
where
(tot_wds, -- #ptr_wds + #nonptr_wds
ptr_wds, -- #ptr_wds
- things_w_offsets) = mkVirtHeapOffsets (StaticRep bot bot) kind_fn things
- bot = panic "layoutStaticClosure"
-
-layOutStaticNoFVClosure :: Id -> LambdaFormInfo -> ClosureInfo
-layOutStaticNoFVClosure name lf_info
- = MkClosureInfo name lf_info (StaticRep ptr_wds nonptr_wds)
- where
- -- I am very uncertain that this is right - it will show up when testing
- -- my dynamic loading code. ADR
- -- (If it's not right, we'll have to grab the kinds of the arguments from
- -- somewhere.)
- ptr_wds = 0
- nonptr_wds = 0
-
-layOutPhantomClosure :: Id -> LambdaFormInfo -> ClosureInfo
-layOutPhantomClosure name lf_info = MkClosureInfo name lf_info PhantomRep
+ things_w_offsets) = mkVirtHeapOffsets kind_fn args
+ sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
\end{code}
-A wrapper for when used with data constructors:
+%************************************************************************
+%* *
+\subsection[mkStaticClosure]{Make a static closure}
+%* *
+%************************************************************************
+
+Make a static closure, adding on any extra padding needed for CAFs,
+and adding a static link field if necessary.
+
\begin{code}
-layOutDynCon :: DataCon
- -> (a -> PrimRep)
- -> [a]
- -> (ClosureInfo, [(a,VirtualHeapOffset)])
-
-layOutDynCon con kind_fn args
- = ASSERT(isDataCon con)
- layOutDynClosure con kind_fn args (mkConLFInfo con)
+mkStaticClosure lbl cl_info ccs fields cafrefs
+ | opt_SccProfilingOn =
+ CStaticClosure
+ lbl
+ cl_info
+ (mkCCostCentreStack ccs)
+ all_fields
+ | otherwise =
+ CStaticClosure
+ lbl
+ cl_info
+ (panic "absent cc")
+ all_fields
+
+ where
+ all_fields = fields ++ padding_wds ++ static_link_field
+
+ upd_reqd = closureUpdReqd cl_info
+
+ -- for the purposes of laying out the static closure, we consider all
+ -- thunks to be "updatable", so that the static link field is always
+ -- in the same place.
+ padding_wds
+ | not upd_reqd = []
+ | otherwise = replicate n (mkIntCLit 0) -- a bunch of 0s
+ where n = max 0 (mIN_UPD_SIZE - length fields)
+
+ -- We always have a static link field for a thunk, it's used to
+ -- save the closure's info pointer when we're reverting CAFs
+ -- (see comment in Storage.c)
+ static_link_field
+ | upd_reqd || staticClosureNeedsLink cl_info = [static_link_value]
+ | otherwise = []
+
+ -- for a static constructor which has NoCafRefs, we set the
+ -- static link field to a non-zero value so the garbage
+ -- collector will ignore it.
+ static_link_value
+ | cafrefs = mkIntCLit 0
+ | otherwise = mkIntCLit 1
\end{code}
-
%************************************************************************
%* *
\subsection[SMreps]{Choosing SM reps}
%************************************************************************
\begin{code}
-chooseDynSMRep
- :: LambdaFormInfo
+chooseSMRep
+ :: Bool -- True <=> static closure
+ -> LambdaFormInfo
-> Int -> Int -- Tot wds, ptr wds
-> SMRep
-chooseDynSMRep lf_info tot_wds ptr_wds
+chooseSMRep is_static lf_info tot_wds ptr_wds
= let
- nonptr_wds = tot_wds - ptr_wds
-
- updatekind = case lf_info of
- LFThunk _ _ upd _ -> if upd then SMUpdatable else SMSingleEntry
- LFBlackHole -> SMUpdatable
- _ -> SMNormalForm
+ nonptr_wds = tot_wds - ptr_wds
+ closure_type = getClosureType is_static tot_wds ptr_wds lf_info
in
- if (nonptr_wds == 0 && ptr_wds <= mAX_SPEC_ALL_PTRS)
- || (tot_wds <= mAX_SPEC_MIXED_FIELDS)
- || (ptr_wds == 0 && nonptr_wds <= mAX_SPEC_ALL_NONPTRS) then
- let
- spec_kind = case lf_info of
-
- (LFTuple _ True) -> ConstantRep
+ GenericRep is_static ptr_wds nonptr_wds closure_type
- (LFTuple _ _) -> SpecRep
+-- we *do* get non-updatable top-level thunks sometimes. eg. f = g
+-- gets compiled to a jump to g (if g has non-zero arity), instead of
+-- messing around with update frames and PAPs. We set the closure type
+-- to FUN_STATIC in this case.
- (LFCon _ True) -> ConstantRep
-
- (LFCon con _ ) -> if maybeToBool (maybeCharLikeTyCon tycon) then CharLikeRep
- else if maybeToBool (maybeIntLikeTyCon tycon) then IntLikeRep
- else SpecRep
- where
- tycon = dataConTyCon con
-
- _ -> SpecRep
- in
- SpecialisedRep spec_kind ptr_wds nonptr_wds updatekind
- else
- GenericRep ptr_wds nonptr_wds updatekind
+getClosureType :: Bool -> Int -> Int -> LambdaFormInfo -> ClosureType
+getClosureType is_static tot_wds ptr_wds lf_info
+ = case lf_info of
+ LFCon con | is_static && ptr_wds == 0 -> ConstrNoCaf
+ | otherwise -> Constr
+ LFReEntrant _ _ _ _ -> Fun
+ LFThunk _ _ _ (SelectorThunk _) _ -> ThunkSelector
+ LFThunk _ _ _ _ _ -> Thunk
+ _ -> panic "getClosureType"
\end{code}
-
%************************************************************************
%* *
\subsection[mkVirtHeapOffsets]{Assigning heap offsets in a closure}
the result list
\begin{code}
-mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager
- -> (a -> PrimRep) -- To be able to grab kinds;
+mkVirtHeapOffsets ::
+ (a -> PrimRep) -- To be able to grab kinds;
-- w/ a kind, we can find boxedness
-> [a] -- Things to make offsets for
-> (Int, -- *Total* number of words allocated
Int, -- Number of words allocated for *pointers*
[(a, VirtualHeapOffset)])
- -- Things with their offsets from start of object
- -- in order of increasing offset
+ -- Things with their offsets from start of
+ -- object in order of increasing offset
-- First in list gets lowest offset, which is initial offset + 1.
-mkVirtHeapOffsets sm_rep kind_fun things
+mkVirtHeapOffsets kind_fun things
= let (ptrs, non_ptrs) = separateByPtrFollowness kind_fun things
(wds_of_ptrs, ptrs_w_offsets) = mapAccumL computeOffset 0 ptrs
(tot_wds, non_ptrs_w_offsets) = mapAccumL computeOffset wds_of_ptrs non_ptrs
in
(tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets)
where
- offset_of_first_word = totHdrSize sm_rep
computeOffset wds_so_far thing
= (wds_so_far + (getPrimRepSize . kind_fun) thing,
- (thing, (offset_of_first_word `addOff` (intOff wds_so_far)))
+ (thing, fixedHdrSize + wds_so_far)
)
\end{code}
\begin{code}
nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
nodeMustPointToIt lf_info
- = let
- do_profiling = opt_SccProfilingOn
- in
- case lf_info of
- LFReEntrant top arity no_fvs -> returnFC (
- not no_fvs || -- Certainly if it has fvs we need to point to it
- not top -- If it is not top level we will point to it
+ = case lf_info of
+ LFReEntrant top _ no_fvs _ -> returnFC (
+ not no_fvs || -- Certainly if it has fvs we need to point to it
+ isNotTopLevel top
+ -- If it is not top level we will point to it
-- We can have a \r closure with no_fvs which
-- is not top level as special case cgRhsClosure
-- has been dissabled in favour of let floating
-- the not top case above ensures this is ok.
)
- LFCon _ zero_arity -> returnFC True
- LFTuple _ zero_arity -> returnFC True
+ LFCon _ -> returnFC True
-- Strictly speaking, the above two don't need Node to point
-- to it if the arity = 0. But this is a *really* unlikely
-- having Node point to the result of an update. SLPJ
-- 27/11/92.
- LFThunk _ no_fvs updatable _
- -> returnFC (updatable || not no_fvs || do_profiling)
+ LFThunk _ no_fvs updatable NonStandardThunk _
+ -> returnFC (updatable || not no_fvs || opt_SccProfilingOn)
-- For the non-updatable (single-entry case):
--
-- or profiling (in which case we need to recover the cost centre
-- from inside it)
- LFArgument -> returnFC True
- LFImported -> returnFC True
- LFBlackHole -> returnFC True
+ LFThunk _ no_fvs updatable some_standard_form_thunk _
+ -> returnFC True
+ -- Node must point to any standard-form thunk.
+
+ LFUnknown _ -> returnFC True
+ LFBlackHole _ -> returnFC True
-- BH entry may require Node to point
- LFLetNoEscape _ _ -> returnFC False
+ LFLetNoEscape _ -> returnFC False
\end{code}
The entry conventions depend on the type of closure being entered,
(rather than directly) to catch double-entry.
\begin{code}
-data EntryConvention
- = ViaNode -- The "normal" convention
+data CallingConvention
+ = EnterIt -- no args, not a function
- | StdEntry CLabel -- Jump to this code, with args on stack
- (Maybe CLabel) -- possibly setting infoptr to this
+ | JumpToIt CLabel -- no args, not a function, but we
+ -- know what its entry code is
- | DirectEntry -- Jump directly to code, with args in regs
+ | ReturnIt -- it's a function, but we have
+ -- zero args to apply to it, so just
+ -- return it.
+
+ | SlowCall -- Unknown fun, or known fun with
+ -- too few args.
+
+ | DirectEntry -- Jump directly, with args in regs
CLabel -- The code label
Int -- Its arity
- [MagicId] -- Its register assignments (possibly empty)
+ [MagicId] -- Its register assignments
+ -- (possibly empty)
-getEntryConvention :: Id -- Function being applied
- -> LambdaFormInfo -- Its info
+getEntryConvention :: Name -- Function being applied
+ -> LambdaFormInfo -- Its info
-> [PrimRep] -- Available arguments
- -> FCode EntryConvention
+ -> FCode CallingConvention
-getEntryConvention id lf_info arg_kinds
+getEntryConvention name lf_info arg_kinds
= nodeMustPointToIt lf_info `thenFC` \ node_points ->
- let
- is_concurrent = opt_ForConcurrent
- in
returnFC (
- if (node_points && is_concurrent) then ViaNode else
+ -- if we're parallel, then we must always enter via node. The reason
+ -- is that the closure may have been fetched since we allocated it.
+
+ if (node_points && opt_Parallel) then EnterIt else
+
+ -- Commented out by SDM after futher thoughts:
+ -- - the only closure type that can be blackholed is a thunk
+ -- - we already enter thunks via node (unless the closure is
+ -- non-updatable, in which case why is it being re-entered...)
case lf_info of
- LFReEntrant _ arity _ ->
- if arity == 0 || (length arg_kinds) < arity then
- StdEntry (mkStdEntryLabel id) Nothing
+ LFReEntrant _ arity _ _ ->
+ if null arg_kinds then
+ if arity == 0 then
+ EnterIt -- a non-updatable thunk
+ else
+ ReturnIt -- no args at all
+ else if listLengthCmp arg_kinds arity == LT then
+ SlowCall -- not enough args
else
- DirectEntry (mkFastEntryLabel id arity) arity arg_regs
+ DirectEntry (mkEntryLabel name) arity arg_regs
where
- (arg_regs, _) = assignRegs live_regs (take arity arg_kinds)
- live_regs = if node_points then [node] else []
-
- LFCon con zero_arity
- -> let itbl = if zero_arity then
- mkPhantomInfoTableLabel con
- else
- mkInfoTableLabel con
- in StdEntry (mkStdEntryLabel con) (Just itbl)
- -- Should have no args
- LFTuple tup zero_arity
- -> StdEntry (mkStdEntryLabel tup)
- (Just (mkInfoTableLabel tup))
- -- Should have no args
-
- LFThunk _ _ updatable std_form_info
- -> if updatable
- then ViaNode
- else StdEntry (thunkEntryLabel id std_form_info updatable) Nothing
-
- LFArgument -> ViaNode
- LFImported -> ViaNode
- LFBlackHole -> ViaNode -- Presumably the black hole has by now
- -- been updated, but we don't know with
- -- what, so we enter via Node
-
- LFLetNoEscape arity _
- -> ASSERT(arity == length arg_kinds)
- DirectEntry (mkStdEntryLabel id) arity arg_regs
+ (arg_regs, _) = assignRegs [node] (take arity arg_kinds)
+ -- we don't use node to pass args now (SDM)
+
+ LFCon con
+ | isNullaryDataCon con
+ -- a real constructor. Don't bother entering it, just jump
+ -- to the constructor entry code directly.
+ -> --false:ASSERT (null arg_kinds)
+ -- Should have no args (meaning what?)
+ JumpToIt (mkStaticConEntryLabel (dataConName con))
+
+ | otherwise {- not nullary -}
+ -> --false:ASSERT (null arg_kinds)
+ -- Should have no args (meaning what?)
+ JumpToIt (mkConEntryLabel (dataConName con))
+
+ LFThunk _ _ updatable std_form_info is_fun
+ -- must always "call" a function-typed thing, cannot just enter it
+ | is_fun -> SlowCall
+ | updatable || opt_DoTickyProfiling -- to catch double entry
+ || opt_SMP -- always enter via node on SMP, since the
+ -- thunk might have been blackholed in the
+ -- meantime.
+ -> ASSERT(null arg_kinds) EnterIt
+ | otherwise
+ -> ASSERT(null arg_kinds)
+ JumpToIt (thunkEntryLabel name std_form_info updatable)
+
+ LFUnknown True -> SlowCall -- might be a function
+ LFUnknown False -> ASSERT2 (null arg_kinds, ppr name <+> ppr arg_kinds) EnterIt -- not a function
+
+ LFBlackHole _ -> SlowCall -- Presumably the black hole has by now
+ -- been updated, but we don't know with
+ -- what, so we slow call it
+
+ LFLetNoEscape 0
+ -> JumpToIt (mkReturnPtLabel (nameUnique name))
+
+ LFLetNoEscape arity
+ -> if (not (arg_kinds `lengthIs` arity)) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else
+ DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs
where
- (arg_regs, _) = assignRegs live_regs arg_kinds
- live_regs = if node_points then [node] else []
+ (arg_regs, _) = assignRegs [] arg_kinds
+ -- node never points to a LetNoEscape, see above --SDM
+ --live_regs = if node_points then [node] else []
)
-blackHoleOnEntry :: Bool -- No-black-holing flag
- -> ClosureInfo
- -> Bool
+blackHoleOnEntry :: ClosureInfo -> Bool
-- Static closures are never themselves black-holed.
--- Updatable ones will be overwritten with a CAFList cell, which points to a black hole;
--- Single-entry ones have no fvs to plug, and we trust they don't form part of a loop.
+-- Updatable ones will be overwritten with a CAFList cell, which points to a
+-- black hole;
+-- Single-entry ones have no fvs to plug, and we trust they don't form part
+-- of a loop.
-blackHoleOnEntry no_black_holing (MkClosureInfo _ _ (StaticRep _ _)) = False
+blackHoleOnEntry ConInfo{} = False
+blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep })
+ | isStaticRep rep
+ = False -- Never black-hole a static closure
-blackHoleOnEntry no_black_holing (MkClosureInfo _ lf_info _)
+ | otherwise
= case lf_info of
- LFReEntrant _ _ _ -> False
- LFThunk _ no_fvs updatable _
+ LFReEntrant _ _ _ _ -> False
+ LFLetNoEscape _ -> False
+ LFThunk _ no_fvs updatable _ _
-> if updatable
- then not no_black_holing
- else not no_fvs
+ then not opt_OmitBlackHoling
+ else opt_DoTickyProfiling || not no_fvs
+ -- the former to catch double entry,
+ -- and the latter to plug space-leaks. KSW/SDM 1999-04.
+
other -> panic "blackHoleOnEntry" -- Should never happen
-getStandardFormThunkInfo
- :: LambdaFormInfo
- -> Maybe [StgArg] -- Nothing => not a standard-form thunk
- -- Just atoms => a standard-form thunk with payload atoms
+isStandardFormThunk :: LambdaFormInfo -> Bool
-getStandardFormThunkInfo (LFThunk _ _ _ (SelectorThunk scrutinee _ _))
- = --trace "Selector thunk: missed opportunity to save info table + code"
- Nothing
- -- Just [StgVarArg scrutinee]
- -- We can't save the info tbl + code until we have a way to generate
- -- a fixed family thereof.
+isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True
+isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True
+isStandardFormThunk other_lf_info = False
-getStandardFormThunkInfo (LFThunk _ _ _ (VapThunk fun_id args fun_in_payload))
- | fun_in_payload = Just (StgVarArg fun_id : args)
- | otherwise = Just args
+\end{code}
-getStandardFormThunkInfo other_lf_info = Nothing
+-----------------------------------------------------------------------------
+SRT-related stuff
-maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ (SelectorThunk _ con offset)) _) = Just (con,offset)
-maybeSelectorInfo _ = Nothing
+\begin{code}
+staticClosureNeedsLink :: ClosureInfo -> Bool
+-- A static closure needs a link field to aid the GC when traversing
+-- the static closure graph. But it only needs such a field if either
+-- a) it has an SRT
+-- b) it's a constructor with one or more pointer fields
+-- In case (b), the constructor's fields themselves play the role
+-- of the SRT.
+staticClosureNeedsLink (ClosureInfo { closureSRT = srt })
+ = needsSRT srt
+staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con })
+ = not (isNullaryDataCon con) && not_nocaf_constr
+ where
+ not_nocaf_constr =
+ case sm_rep of
+ GenericRep _ _ _ ConstrNoCaf -> False
+ _other -> True
\end{code}
Avoiding generating entries and info tables
to use an error label in the info table to substitute for the absent
slow entry code.
-* Standard vap-entry code
- Standard vap-entry info table
- Needed iff we have any updatable thunks of the standard vap-entry shape.
-
-* Single-update vap-entry code
- Single-update vap-entry info table
- Needed iff we have any non-updatable thunks of the
- standard vap-entry shape.
-
-
\begin{code}
staticClosureRequired
- :: Id
+ :: Name
-> StgBinderInfo
-> LambdaFormInfo
-> Bool
-staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
- (LFReEntrant top_level _ _) -- It's a function
- = ASSERT( top_level ) -- Assumption: it's a top-level, no-free-var binding
- arg_occ -- There's an argument occurrence
- || unsat_occ -- There's an unsaturated call
- || externallyVisibleId binder
+staticClosureRequired binder bndr_info
+ (LFReEntrant top_level _ _ _) -- It's a function
+ = ASSERT( isTopLevel top_level )
+ -- Assumption: it's a top-level, no-free-var binding
+ not (satCallsOnly bndr_info)
staticClosureRequired binder other_binder_info other_lf_info = True
-
-slowFunEntryCodeRequired -- Assumption: it's a function, not a thunk.
- :: Id
- -> StgBinderInfo
- -> Bool
-slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
- = arg_occ -- There's an argument occurrence
- || unsat_occ -- There's an unsaturated call
- || externallyVisibleId binder
- {- HAS FREE VARS AND IS PARALLEL WORLD -}
-
-slowFunEntryCodeRequired binder NoStgBinderInfo = True
-
-funInfoTableRequired
- :: Id
- -> StgBinderInfo
- -> LambdaFormInfo
- -> Bool
-funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
- (LFReEntrant top_level _ _)
- = not top_level
- || arg_occ -- There's an argument occurrence
- || unsat_occ -- There's an unsaturated call
- || externallyVisibleId binder
-
-funInfoTableRequired other_binder_info binder other_lf_info = True
-
--- We need the vector-apply entry points for a function if
--- there's a vector-apply occurrence in this module
-
-stdVapRequired, noUpdVapRequired :: StgBinderInfo -> Bool
-
-stdVapRequired binder_info
- = case binder_info of
- StgBinderInfo _ _ std_vap_occ _ _ -> std_vap_occ
- _ -> False
-
-noUpdVapRequired binder_info
- = case binder_info of
- StgBinderInfo _ _ _ no_upd_vap_occ _ -> no_upd_vap_occ
- _ -> False
\end{code}
%************************************************************************
\begin{code}
isStaticClosure :: ClosureInfo -> Bool
-isStaticClosure (MkClosureInfo _ _ rep) = isStaticRep rep
-
-closureId :: ClosureInfo -> Id
-closureId (MkClosureInfo id _ _) = id
-
-closureSMRep :: ClosureInfo -> SMRep
-closureSMRep (MkClosureInfo _ _ sm_rep) = sm_rep
-
-closureLFInfo :: ClosureInfo -> LambdaFormInfo
-closureLFInfo (MkClosureInfo _ lf_info _) = lf_info
+isStaticClosure cl_info = isStaticRep (closureSMRep cl_info)
closureUpdReqd :: ClosureInfo -> Bool
-
-closureUpdReqd (MkClosureInfo _ (LFThunk _ _ upd _) _) = upd
-closureUpdReqd (MkClosureInfo _ LFBlackHole _) = True
+closureUpdReqd (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _ }) = upd
+closureUpdReqd (ClosureInfo { closureLFInfo = LFBlackHole _ }) = True
-- Black-hole closures are allocated to receive the results of an
-- alg case with a named default... so they need to be updated.
-closureUpdReqd other_closure = False
+closureUpdReqd other_closure = False
closureSingleEntry :: ClosureInfo -> Bool
-
-closureSingleEntry (MkClosureInfo _ (LFThunk _ _ upd _) _) = not upd
-closureSingleEntry other_closure = False
-\end{code}
-
-Note: @closureType@ returns appropriately specialised tycon and
-datacons.
-\begin{code}
-closureType :: ClosureInfo -> Maybe (TyCon, [Type], [Id])
-
--- First, a turgid special case. When we are generating the
--- standard code and info-table for Vaps (which is done when the function
--- defn is encountered), we don't have a convenient Id to hand whose
--- type is that of (f x y z). So we need to figure out the type
--- rather than take it from the Id. The Id is probably just "f"!
-
-closureType (MkClosureInfo id (LFThunk _ _ _ (VapThunk fun_id args _)) _)
- = getDataSpecTyCon_maybe (fun_result_ty (length args) fun_id)
-
-closureType (MkClosureInfo id lf _) = getDataSpecTyCon_maybe (idType id)
-\end{code}
-
-@closureReturnsUnboxedType@ is used to check whether a closure, {\em
-once it has eaten its arguments}, returns an unboxed type. For
-example, the closure for a function:
-\begin{verbatim}
- f :: Int -> Int#
-\end{verbatim}
-returns an unboxed type. This is important when dealing with stack
-overflow checks.
-\begin{code}
-closureReturnsUnboxedType :: ClosureInfo -> Bool
-
-closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _)
- = isPrimType (fun_result_ty arity fun_id)
-
-closureReturnsUnboxedType other_closure = False
- -- All non-function closures aren't functions,
- -- and hence are boxed, since they are heap alloc'd
-
--- ToDo: need anything like this in Type.lhs?
-fun_result_ty arity id
- = let
- (_, de_foralld_ty) = splitForAllTy (idType id)
- (arg_tys, res_ty) = splitFunTy{-w/ dicts as args?-} de_foralld_ty
- in
- ASSERT(arity >= 0 && length arg_tys >= arity)
- mkFunTys (drop arity arg_tys) res_ty
+closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd
+closureSingleEntry other_closure = False
+
+closureReEntrant :: ClosureInfo -> Bool
+closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True
+closureReEntrant other_closure = False
+
+closureSemiTag :: ClosureInfo -> Maybe Int
+closureSemiTag (ConInfo { closureCon = data_con })
+ = Just (dataConTag data_con - fIRST_TAG)
+closureSemiTag _ = Nothing
+
+closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr)
+closureFunInfo (ClosureInfo { closureLFInfo = LFReEntrant _ arity _ arg_desc})
+ = Just (arity, arg_desc)
+closureFunInfo _
+ = Nothing
\end{code}
\begin{code}
-closureSemiTag :: ClosureInfo -> Int
-
-closureSemiTag (MkClosureInfo _ lf_info _)
+isToplevClosure :: ClosureInfo -> Bool
+isToplevClosure (ClosureInfo { closureLFInfo = lf_info })
= case lf_info of
- LFCon data_con _ -> dataConTag data_con - fIRST_TAG
- LFTuple _ _ -> 0
- _ -> fromInteger oTHER_TAG
+ LFReEntrant TopLevel _ _ _ -> True
+ LFThunk TopLevel _ _ _ _ -> True
+ other -> False
+isToplevClosure _ = False
\end{code}
Label generation.
\begin{code}
infoTableLabelFromCI :: ClosureInfo -> CLabel
-
-infoTableLabelFromCI (MkClosureInfo id lf_info rep)
+infoTableLabelFromCI (ClosureInfo { closureName = name,
+ closureLFInfo = lf_info,
+ closureSMRep = rep })
= case lf_info of
- LFCon con _ -> mkConInfoPtr con rep
- LFTuple tup _ -> mkConInfoPtr tup rep
+ LFBlackHole info -> info
- LFBlackHole -> mkBlackHoleInfoTableLabel
+ LFThunk _ _ upd_flag (SelectorThunk offset) _ ->
+ mkSelectorInfoLabel upd_flag offset
- LFThunk _ _ upd_flag (VapThunk fun_id args _) -> mkVapInfoTableLabel fun_id upd_flag
- -- Use the standard vap info table
- -- for the function, rather than a one-off one
- -- for this particular closure
+ LFThunk _ _ upd_flag (ApThunk arity) _ ->
+ mkApInfoTableLabel upd_flag arity
-{- For now, we generate individual info table and entry code for selector thunks,
- so their info table should be labelled in the standard way.
- The only special thing about them is that the info table has a field which
- tells the GC that it really is a selector.
+ LFThunk{} -> mkInfoTableLabel name
- Later, perhaps, we'll have some standard RTS code for selector-thunk info tables,
- in which case this line will spring back to life.
+ LFReEntrant _ _ _ (ArgGen _ _) -> mkInfoTableLabel name
+ LFReEntrant _ _ _ _ -> mkInfoTableLabel name
- LFThunk _ _ upd_flag (SelectorThunk _ _ offset) -> mkSelectorInfoTableLabel upd_flag offset
- -- Ditto for selectors
--}
+ other -> panic "infoTableLabelFromCI"
- other -> {-NO: if isStaticRep rep
- then mkStaticInfoTableLabel id
- else -} mkInfoTableLabel id
+infoTableLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep })
+ = mkConInfoPtr con rep
-mkConInfoPtr :: Id -> SMRep -> CLabel
-mkConInfoPtr id rep =
- case rep of
- PhantomRep -> mkPhantomInfoTableLabel id
- StaticRep _ _ -> mkStaticInfoTableLabel id
- _ -> mkInfoTableLabel id
-mkConEntryPtr :: Id -> SMRep -> CLabel
-mkConEntryPtr id rep =
- case rep of
- StaticRep _ _ -> mkStaticConEntryLabel id
- _ -> mkConEntryLabel id
+mkConInfoPtr :: DataCon -> SMRep -> CLabel
+mkConInfoPtr con rep
+ | isStaticRep rep = mkStaticInfoTableLabel name
+ | otherwise = mkConInfoTableLabel name
+ where
+ name = dataConName con
+mkConEntryPtr :: DataCon -> SMRep -> CLabel
+mkConEntryPtr con rep
+ | isStaticRep rep = mkStaticConEntryLabel (dataConName con)
+ | otherwise = mkConEntryLabel (dataConName con)
-closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id
+closureLabelFromCI (ClosureInfo { closureName = nm }) = mkClosureLabel nm
+closureLabelFromCI _ = panic "closureLabelFromCI"
entryLabelFromCI :: ClosureInfo -> CLabel
-entryLabelFromCI (MkClosureInfo id lf_info rep)
+entryLabelFromCI (ClosureInfo { closureName = id,
+ closureLFInfo = lf_info,
+ closureSMRep = rep })
= case lf_info of
- LFThunk _ _ upd_flag std_form_info -> thunkEntryLabel id std_form_info upd_flag
- LFCon con _ -> mkConEntryPtr con rep
- LFTuple tup _ -> mkConEntryPtr tup rep
- other -> mkStdEntryLabel id
+ LFThunk _ _ upd_flag std_form_info _ ->
+ thunkEntryLabel id std_form_info upd_flag
+ other -> mkEntryLabel id
+
+entryLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep })
+ = mkConEntryPtr con rep
+
-- thunkEntryLabel is a local help function, not exported. It's used from both
-- entryLabelFromCI and getEntryConvention.
--- I don't think it needs to deal with the SelectorThunk case
--- Well, it's falling over now, so I've made it deal with it. (JSM)
-thunkEntryLabel thunk_id (VapThunk fun_id args _) is_updatable
- = mkVapEntryLabel fun_id is_updatable
+thunkEntryLabel thunk_id (ApThunk arity) is_updatable
+ = mkApEntryLabel is_updatable arity
+thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag
+ = mkSelectorEntryLabel upd_flag offset
thunkEntryLabel thunk_id _ is_updatable
- = mkStdEntryLabel thunk_id
-
-fastLabelFromCI :: ClosureInfo -> CLabel
-fastLabelFromCI (MkClosureInfo id _ _) = mkFastEntryLabel id fun_arity
- where
- arity_maybe = arityMaybe (getIdArity id)
- fun_arity = case arity_maybe of
- Just x -> x
- _ -> pprPanic "fastLabelFromCI:no arity:" (ppr PprShowAll id)
+ = mkEntryLabel thunk_id
\end{code}
\begin{code}
-allocProfilingMsg :: ClosureInfo -> FAST_STRING
-
-allocProfilingMsg (MkClosureInfo _ lf_info _)
+allocProfilingMsg :: ClosureInfo -> FastString
+allocProfilingMsg ConInfo{} = FSLIT("TICK_ALLOC_CON")
+allocProfilingMsg ClosureInfo{ closureLFInfo = lf_info }
= case lf_info of
- LFReEntrant _ _ _ -> SLIT("ALLOC_FUN")
- LFCon _ _ -> SLIT("ALLOC_CON")
- LFTuple _ _ -> SLIT("ALLOC_CON")
- LFThunk _ _ _ _ -> SLIT("ALLOC_THK")
- LFBlackHole -> SLIT("ALLOC_BH")
- LFImported -> panic "ALLOC_IMP"
+ LFReEntrant _ _ _ _ -> FSLIT("TICK_ALLOC_FUN")
+ LFThunk _ _ True _ _ -> FSLIT("TICK_ALLOC_UP_THK") -- updatable
+ LFThunk _ _ False _ _ -> FSLIT("TICK_ALLOC_SE_THK") -- nonupdatable
+ LFBlackHole _ -> FSLIT("TICK_ALLOC_BH")
+ _ -> panic "allocProfilingMsg"
\end{code}
We need a black-hole closure info to pass to @allocDynClosure@ when we
-want to allocate the black hole on entry to a CAF.
+want to allocate the black hole on entry to a CAF. These are the only
+ways to build an LFBlackHole, maintaining the invariant that it really
+is a black hole and not something else.
\begin{code}
-blackHoleClosureInfo (MkClosureInfo id _ _)
- = MkClosureInfo id LFBlackHole BlackHoleRep
+cafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
+ closureType = ty })
+ = ClosureInfo { closureName = nm,
+ closureLFInfo = LFBlackHole mkCAFBlackHoleInfoTableLabel,
+ closureSMRep = BlackHoleRep,
+ closureSRT = NoC_SRT,
+ closureType = ty,
+ closureDescr = "" }
+cafBlackHoleClosureInfo _ = panic "cafBlackHoleClosureInfo"
+
+seCafBlackHoleClosureInfo (ClosureInfo { closureName = nm,
+ closureType = ty })
+ = ClosureInfo { closureName = nm,
+ closureLFInfo = LFBlackHole mkSECAFBlackHoleInfoTableLabel,
+ closureSMRep = BlackHoleRep,
+ closureSRT = NoC_SRT,
+ closureType = ty,
+ closureDescr = "" }
+seCafBlackHoleClosureInfo _ = panic "seCafBlackHoleClosureInfo"
\end{code}
-The register liveness when returning from a constructor. For
-simplicity, we claim just [node] is live for all but PhantomRep's. In
-truth, this means that non-constructor info tables also claim node,
-but since their liveness information is never used, we don't care.
+%************************************************************************
+%* *
+\subsection[ClosureInfo-Profiling-funs]{Misc functions about for profiling info.}
+%* *
+%************************************************************************
+
+Profiling requires two pieces of information to be determined for
+each closure's info table --- description and type.
+
+The description is stored directly in the @CClosureInfoTable@ when the
+info table is built.
+
+The type is determined from the type information stored with the @Id@
+in the closure info using @closureTypeDescr@.
\begin{code}
-dataConLiveness (MkClosureInfo con _ PhantomRep)
- = case (dataReturnConvAlg con) of
- ReturnInRegs regs -> mkLiveRegsMask regs
- ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???"
+closureTypeDescr :: ClosureInfo -> String
+closureTypeDescr (ClosureInfo { closureType = ty })
+ = getTyDescription ty
+closureTypeDescr (ConInfo { closureCon = data_con })
+ = occNameUserString (getOccName (dataConTyCon data_con))
+
+getTyDescription :: Type -> String
+getTyDescription ty
+ = case (tcSplitSigmaTy ty) of { (_, _, tau_ty) ->
+ case tau_ty of
+ TyVarTy _ -> "*"
+ AppTy fun _ -> getTyDescription fun
+ FunTy _ res -> '-' : '>' : fun_result res
+ NewTcApp tycon _ -> getOccString tycon
+ TyConApp tycon _ -> getOccString tycon
+ NoteTy (FTVNote _) ty -> getTyDescription ty
+ NoteTy (SynNote ty1) _ -> getTyDescription ty1
+ PredTy sty -> getPredTyDescription sty
+ ForAllTy _ ty -> getTyDescription ty
+ }
+ where
+ fun_result (FunTy _ res) = '>' : fun_result res
+ fun_result other = getTyDescription other
-dataConLiveness _ = mkLiveRegsMask [node]
+getPredTyDescription (ClassP cl tys) = getOccString cl
+getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip)
\end{code}
%************************************************************************
%* *
-\subsection[ClosureInfo-Profiling-funs]{Misc functions about for profiling info.}
+\subsection{Making argument bitmaps}
%* *
%************************************************************************
-Profiling requires three pices of information to be determined for
-each closure's info table --- kind, description and type.
+\begin{code}
+-- bring in ARG_P, ARG_N, etc.
+#include "../includes/StgFun.h"
+
+data ArgDescr
+ = ArgSpec
+ !Int -- ARG_P, ARG_N, ...
+ | ArgGen
+ CLabel -- label for a slow-entry point
+ Liveness -- the arg bitmap: describes pointedness of arguments
+
+mkArgDescr :: Name -> [Id] -> ArgDescr
+mkArgDescr nm args = argDescr nm (filter nonVoidRep (map idPrimRep args))
+ where nonVoidRep VoidRep = False
+ nonVoidRep _ = True
+
+argDescr nm [PtrRep] = ArgSpec ARG_P
+argDescr nm [FloatRep] = ArgSpec ARG_F
+argDescr nm [DoubleRep] = ArgSpec ARG_D
+argDescr nm [r] | is64BitRep r = ArgSpec ARG_L
+argDescr nm [r] | isNonPtrRep r = ArgSpec ARG_N
+
+argDescr nm [r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NN
+argDescr nm [r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NP
+argDescr nm [PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PN
+argDescr nm [PtrRep,PtrRep] = ArgSpec ARG_PP
+
+argDescr nm [r1,r2,r3] | isNonPtrRep r1 && isNonPtrRep r2 && isNonPtrRep r3 = ArgSpec ARG_NNN
+argDescr nm [r1,r2,PtrRep] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NNP
+argDescr nm [r1,PtrRep,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NPN
+argDescr nm [r1,PtrRep,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NPP
+argDescr nm [PtrRep,r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_PNN
+argDescr nm [PtrRep,r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_PNP
+argDescr nm [PtrRep,PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PPN
+argDescr nm [PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPP
+
+argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPP
+argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPP
+argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPPP
+
+argDescr name reps = ArgGen (mkSlowEntryLabel name) liveness
+ where bitmap = argBits reps
+ lbl = mkBitmapLabel name
+ liveness = Liveness lbl (length bitmap) (mkBitmap bitmap)
+
+argBits [] = []
+argBits (rep : args)
+ | isFollowableRep rep = False : argBits args
+ | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args
+\end{code}
-The description is stored directly in the @CClosureInfoTable@ when the
-info table is built.
-The kind is determined from the @LambdaForm@ stored in the closure
-info using @closureKind@.
+%************************************************************************
+%* *
+\subsection{Generating info tables}
+%* *
+%************************************************************************
-The type is determined from the type information stored with the @Id@
-in the closure info using @closureTypeDescr@.
+Here we make a concrete info table, represented as a list of CAddrMode
+(it can't be simply a list of Word, because the SRT field is
+represented by a label+offset expression).
\begin{code}
-closureKind :: ClosureInfo -> String
+mkInfoTable :: ClosureInfo -> [CAddrMode]
+mkInfoTable cl_info
+ | tablesNextToCode = extra_bits ++ std_info
+ | otherwise = std_info ++ extra_bits
+ where
+ std_info = mkStdInfoTable entry_amode
+ ty_descr_amode cl_descr_amode cl_type srt_len layout_amode
+
+ entry_amode = CLbl (entryLabelFromCI cl_info) CodePtrRep
+
+ closure_descr =
+ case cl_info of
+ ClosureInfo { closureDescr = descr } -> descr
+ ConInfo { closureCon = con } -> occNameUserString (getOccName con)
+
+ ty_descr_amode = CLit (MachStr (mkFastString (closureTypeDescr cl_info)))
+ cl_descr_amode = CLit (MachStr (mkFastString closure_descr))
+
+ cl_type = getSMRepClosureTypeInt (closureSMRep cl_info)
+
+ srt = closureSRT cl_info
+ needs_srt = needsSRT srt
+
+ semi_tag = closureSemiTag cl_info
+ is_con = isJust semi_tag
+
+ (srt_label,srt_len)
+ | Just tag <- semi_tag = (mkIntCLit 0, fromIntegral tag) -- constructor
+ | otherwise =
+ case srt of
+ NoC_SRT -> (mkIntCLit 0, 0)
+ C_SRT lbl off bitmap ->
+ (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
+ bitmap)
+
+ ptrs = closurePtrsSize cl_info
+ nptrs = size - ptrs
+ size = closureNonHdrSize cl_info
+
+ layout_info :: StgWord
+#ifdef WORDS_BIGENDIAN
+ layout_info = (fromIntegral ptrs `shiftL` hALF_WORD) .|. fromIntegral nptrs
+#else
+ layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` hALF_WORD)
+#endif
+
+ layout_amode = mkWordCLit layout_info
+
+ extra_bits
+ | is_fun = fun_extra_bits
+ | is_con = []
+ | needs_srt = [srt_label]
+ | otherwise = []
+
+ maybe_fun_stuff = closureFunInfo cl_info
+ is_fun = isJust maybe_fun_stuff
+ (Just (arity, arg_descr)) = maybe_fun_stuff
+
+ fun_extra_bits
+ | tablesNextToCode = reg_fun_extra_bits
+ | otherwise = reverse reg_fun_extra_bits
+
+ reg_fun_extra_bits
+ | ArgGen slow_lbl liveness <- arg_descr
+ = [
+ CLbl slow_lbl CodePtrRep,
+ livenessToAddrMode liveness,
+ srt_label,
+ fun_amode
+ ]
+ | needs_srt = [srt_label, fun_amode]
+ | otherwise = [fun_amode]
+
+#ifdef WORDS_BIGENDIAN
+ fun_desc = (fromIntegral fun_type `shiftL` hALF_WORD) .|. fromIntegral arity
+#else
+ fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` hALF_WORD)
+#endif
-closureKind (MkClosureInfo _ lf _)
- = case lf of
- LFReEntrant _ n _ -> if n > 0 then "FN_K" else "THK_K"
- LFCon _ _ -> "CON_K"
- LFTuple _ _ -> "CON_K"
- LFThunk _ _ _ _ -> "THK_K"
- LFBlackHole -> "THK_K" -- consider BHs as thunks for the moment... (ToDo?)
- LFImported -> panic "IMP_KIND"
+ fun_amode = mkWordCLit fun_desc
+
+ fun_type = case arg_descr of
+ ArgSpec n -> n
+ ArgGen _ (Liveness _ size _)
+ | size <= mAX_SMALL_BITMAP_SIZE -> ARG_GEN
+ | otherwise -> ARG_GEN_BIG
+
+-- Return info tables come in two flavours: direct returns and
+-- vectored returns.
+
+mkRetInfoTable :: CLabel -> C_SRT -> Liveness -> [CAddrMode]
+mkRetInfoTable entry_lbl srt liveness
+ = mkBitmapInfoTable (CLbl entry_lbl CodePtrRep) srt liveness []
+
+mkVecInfoTable :: [CAddrMode] -> C_SRT -> Liveness -> [CAddrMode]
+mkVecInfoTable vector srt liveness
+ = mkBitmapInfoTable zero_amode srt liveness vector
+
+mkBitmapInfoTable
+ :: CAddrMode
+ -> C_SRT -> Liveness
+ -> [CAddrMode]
+ -> [CAddrMode]
+mkBitmapInfoTable entry_amode srt liveness vector
+ | tablesNextToCode = extra_bits ++ std_info
+ | otherwise = std_info ++ extra_bits
+ where
+ std_info = mkStdInfoTable entry_amode zero_amode zero_amode
+ cl_type srt_len liveness_amode
+
+ liveness_amode = livenessToAddrMode liveness
+
+ (srt_label,srt_len) =
+ case srt of
+ NoC_SRT -> (mkIntCLit 0, 0)
+ C_SRT lbl off bitmap ->
+ (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep),
+ bitmap)
+
+ cl_type = case (null vector, isBigLiveness liveness) of
+ (True, True) -> rET_BIG
+ (True, False) -> rET_SMALL
+ (False, True) -> rET_VEC_BIG
+ (False, False) -> rET_VEC_SMALL
+
+ srt_bit | needsSRT srt || not (null vector) = [srt_label]
+ | otherwise = []
+
+ extra_bits | tablesNextToCode = reverse vector ++ srt_bit
+ | otherwise = srt_bit ++ vector
+
+-- The standard bits of an info table. This part of the info table
+-- corresponds to the StgInfoTable type defined in InfoTables.h.
+
+mkStdInfoTable
+ :: CAddrMode -- entry label
+ -> CAddrMode -- closure type descr (profiling)
+ -> CAddrMode -- closure descr (profiling)
+ -> Int -- closure type
+ -> StgHalfWord -- SRT length
+ -> CAddrMode -- layout field
+ -> [CAddrMode]
+mkStdInfoTable entry_lbl type_descr closure_descr cl_type srt_len layout_amode
+ = std_info
+ where
+ std_info
+ | tablesNextToCode = std_info'
+ | otherwise = entry_lbl : std_info'
+
+ std_info' =
+ -- par info
+ prof_info ++
+ -- ticky info
+ -- debug info
+ [layout_amode] ++
+ CLit (MachWord (fromIntegral type_info)) :
+ []
+
+ prof_info
+ | opt_SccProfilingOn = [ type_descr, closure_descr ]
+ | otherwise = []
+
+ -- sigh: building up the info table is endian-dependent.
+ -- ToDo: do this using .byte and .word directives.
+ type_info :: StgWord
+#ifdef WORDS_BIGENDIAN
+ type_info = (fromIntegral cl_type `shiftL` hALF_WORD) .|.
+ (fromIntegral srt_len)
+#else
+ type_info = (fromIntegral cl_type) .|.
+ (fromIntegral srt_len `shiftL` hALF_WORD)
+#endif
-closureTypeDescr :: ClosureInfo -> String
-closureTypeDescr (MkClosureInfo id lf _)
- = if (isDataCon id) then -- DataCon has function types
- _UNPK_ (getLocalName (dataConTyCon id)) -- We want the TyCon not the ->
- else
- getTyDescription (idType id)
+isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE
+
+livenessToAddrMode :: Liveness -> CAddrMode
+livenessToAddrMode (Liveness lbl size bits)
+ | size <= mAX_SMALL_BITMAP_SIZE = small
+ | otherwise = CLbl lbl DataPtrRep
+ where
+ small = mkWordCLit (fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT))
+ small_bits = case bits of
+ [] -> 0
+ [b] -> fromIntegral b
+ _ -> panic "livenessToAddrMode"
+
+zero_amode = mkIntCLit 0
+
+-- IA64 mangler doesn't place tables next to code
+tablesNextToCode :: Bool
+#ifdef ia64_TARGET_ARCH
+tablesNextToCode = False
+#else
+tablesNextToCode = not opt_Unregisterised
+#endif
\end{code}
projects / ghc-hetmet.git / blobdiff