-
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+%
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
+%
+% $Id: ClosureInfo.lhs,v 1.31 1998/12/02 13:17:55 simonm Exp $
%
\section[ClosureInfo]{Data structures which describe closures}
the STG paper.
\begin{code}
-#include "HsVersions.h"
-
module ClosureInfo (
ClosureInfo, LambdaFormInfo, SMRep, -- all abstract
StandardFormInfo,
EntryConvention(..),
- mkClosureLFInfo, mkConLFInfo,
- mkLFImported, mkLFArgument, mkLFLetNoEscape,
+ mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo,
+ mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape,
+ UpdateFlag,
- closureSize, closureHdrSize,
- closureNonHdrSize, closureSizeWithoutFixedHdr,
- closureGoodStuffSize, closurePtrsSize, -- UNUSED: closureNonPtrsSize,
- slopSize, fitsMinUpdSize,
+ closureSize, closureNonHdrSize,
+ closureGoodStuffSize, closurePtrsSize,
+ slopSize,
layOutDynClosure, layOutDynCon, layOutStaticClosure,
- layOutStaticNoFVClosure, layOutPhantomClosure,
- mkVirtHeapOffsets, -- for GHCI
+ layOutStaticNoFVClosure,
+ mkVirtHeapOffsets,
+
+ nodeMustPointToIt, getEntryConvention,
+ FCode, CgInfoDownwards, CgState,
- nodeMustPointToIt, getEntryConvention,
blackHoleOnEntry,
- staticClosureRequired,
+ staticClosureRequired,
slowFunEntryCodeRequired, funInfoTableRequired,
- stdVapRequired, noUpdVapRequired,
- closureId, infoTableLabelFromCI,
+ closureName, infoTableLabelFromCI, fastLabelFromCI,
closureLabelFromCI,
- entryLabelFromCI, fastLabelFromCI,
+ entryLabelFromCI,
closureLFInfo, closureSMRep, closureUpdReqd,
- closureSingleEntry, closureSemiTag, closureType,
- closureReturnsUnboxedType, getStandardFormThunkInfo,
+ closureSingleEntry, closureSemiTag,
+ isStandardFormThunk,
+ GenStgArg,
---OLD auxInfoTableLabelFromCI, isIntLikeRep, -- go away in 0.23
-
- closureKind, closureTypeDescr, -- profiling
+ isToplevClosure,
+ closureTypeDescr, -- profiling
- isConstantRep, isSpecRep, isPhantomRep, -- ToDo: Should be in SMRep, perhaps?
- isStaticClosure, allocProfilingMsg,
+ isStaticClosure,
+ allocProfilingMsg,
blackHoleClosureInfo,
- getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr,
- ltSMRepHdr, --UNUSED: equivSMRepHdr,
maybeSelectorInfo,
-
- dataConLiveness, -- concurrency
-
- -- and to make the interface self-sufficient...
- AbstractC, CAddrMode, HeapOffset, MagicId,
- CgInfoDownwards, CgState, CgIdInfo, CompilationInfo,
- CLabel, Id, Maybe, PrimKind, FCode(..), TyCon, StgExpr,
- StgAtom, StgBinderInfo,
- DataCon(..), PlainStgExpr(..), PlainStgLiveVars(..),
- PlainStgAtom(..),
- UniqSet(..), UniqFM, UpdateFlag(..) -- not abstract
-
- IF_ATTACK_PRAGMAS(COMMA mkClosureLabel)
- IF_ATTACK_PRAGMAS(COMMA getUniDataSpecTyCon_maybe)
+ needsSRT
) where
-import AbsCSyn
-import CgMonad
-import SMRep
+#include "HsVersions.h"
+
+import AbsCSyn ( MagicId, node, VirtualHeapOffset, HeapOffset )
import StgSyn
+import CgMonad
-import AbsUniType
-import CgCompInfo -- some magic constants
-import CgRetConv
-import CLabelInfo -- Lots of label-making things
-import CmdLineOpts ( GlobalSwitch(..) )
-import Id
-import IdInfo -- SIGH
-import Maybes ( maybeToBool, assocMaybe, Maybe(..) )
-import Outputable -- needed for INCLUDE_FRC_METHOD
-import Pretty -- ( ppStr, Pretty(..) )
-import PrimKind ( PrimKind, getKindSize, separateByPtrFollowness )
-import Util
+import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
+import CgRetConv ( assignRegs )
+import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel,
+ mkInfoTableLabel,
+ mkConInfoTableLabel, mkStaticClosureLabel,
+ mkBlackHoleInfoTableLabel,
+ mkStaticInfoTableLabel, mkStaticConEntryLabel,
+ mkConEntryLabel, mkClosureLabel,
+ mkSelectorInfoLabel, mkSelectorEntryLabel,
+ mkApInfoTableLabel, mkApEntryLabel,
+ mkReturnPtLabel
+ )
+import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
+ opt_Parallel )
+import Id ( Id, idType, getIdArity )
+import DataCon ( DataCon, dataConTag, fIRST_TAG,
+ isNullaryDataCon, isTupleCon, dataConName
+ )
+import IdInfo ( ArityInfo(..) )
+import Name ( Name, isExternallyVisibleName, nameUnique )
+import PprType ( getTyDescription )
+import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep )
+import SMRep -- all of it
+import Type ( isUnLiftedType, Type )
+import BasicTypes ( TopLevelFlag(..) )
+import Util ( mapAccumL )
+import Outputable
\end{code}
The ``wrapper'' data type for closure information:
\begin{code}
data ClosureInfo
= MkClosureInfo
- Id -- The thing bound to this closure
+ Name -- The thing bound to this closure
LambdaFormInfo -- info derivable from the *source*
SMRep -- representation used by storage manager
\end{code}
%************************************************************************
%* *
-\subsection[ClosureInfo-OLD-DOC]{OLD DOCUMENTATION PROBABLY SUPERCEDED BY stg-details}
-%* *
-%************************************************************************
-
-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 )
-
-x's EntryInfo in its own module:
-\begin{verbatim}
- Base-label = Cons -- Not x!!
- NodeMustPoint = True
- ClosureClass = Constructor
-\end{verbatim}
-
- So if x is entered, Node will be set up and
- we'll jump direct to the Cons code.
-
-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 LambdaFormInfo
= LFReEntrant -- Reentrant closure; used for PAPs too
- Bool -- True if top level
- Int -- Arity
- Bool -- True <=> no fvs
+ Type -- Type of closure (ToDo: remove)
+ TopLevelFlag -- True if top level
+ !Int -- Arity
+ !Bool -- True <=> no fvs
| LFCon -- Constructor
- DataCon -- The constructor (may be specialised)
+ DataCon -- The constructor
Bool -- True <=> zero arity
| LFTuple -- Tuples
- DataCon -- The tuple constructor (may be specialised)
+ DataCon -- The tuple constructor
Bool -- True <=> zero arity
-
+
| LFThunk -- Thunk (zero arity)
- Bool -- True <=> top level
- Bool -- True <=> no free vars
+ Type -- Type of the thunk (ToDo: remove)
+ TopLevelFlag
+ !Bool -- True <=> no free vars
Bool -- True <=> updatable (i.e., *not* single-entry)
StandardFormInfo
| LFLetNoEscape -- See LetNoEscape module for precise description of
-- these "lets".
Int -- arity;
- PlainStgLiveVars-- list of variables live in the RHS of the let.
- -- (ToDo: maybe not used)
| 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.
- -- 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
- case x of
- 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
- [PlainStgAtom] -- Args
- Bool -- True <=> the function is not top-level, so
- -- must be stored in the thunk too
-
-{- A VapThunk is of form
-
- f a1 ... an
-
- 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.
+ case x of
+ con a1,..,an -> ak
+
+ and the constructor is from a single-constr type.
-}
-
-mkLFArgument = LFArgument
-mkLFBlackHole = LFBlackHole
-mkLFLetNoEscape = LFLetNoEscape
+ | ApThunk
+ Int -- arity
+
+{- An ApThunk is of form
+
+ x1 ... xn
+
+ 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.
+-}
-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
- -> PlainStgExpr -- 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 (idType bndr) top (length args) (null fvs)
-mkClosureLFInfo top fvs ReEntrant [] body
- = LFReEntrant top 0 (null fvs)
-\end{code}
+mkClosureLFInfo bndr top fvs ReEntrant []
+ = LFReEntrant (idType bndr) top 0 (null fvs)
-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 (StgVarAtom scrutinee) [{-no args-}] _)
- _ _ _ -- ignore live vars and uniq...
- (StgAlgAlts case_ty
- [(con, params, use_mask,
- (StgApp (StgVarAtom 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 []
+#ifdef DEBUG
+ | isUnLiftedType ty = pprPanic "mkClosureLFInfo" (ppr bndr <+> ppr ty)
+#endif
+ | otherwise
+ = LFThunk ty top (null fvs) (isUpdatable upd_flag) NonStandardThunk
where
- (_, params_w_offsets) = layOutDynCon con getIdKind 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 (maybeSingleConstructorTyCon tycon)
- (_,_,_, tycon) = getDataConSig con
+ ty = idType bndr
\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 (StgVarAtom 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
+mkConLFInfo :: DataCon -> LambdaFormInfo
- -- 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
+mkConLFInfo con
+ = -- the isNullaryDataCon will do this: ASSERT(isDataCon con)
+ (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con)
- is_elem = isIn "mkClosureLFInfo"
-\end{code}
+mkSelectorLFInfo rhs_ty offset updatable
+ = LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset)
-Finally, the general updatable-thing case:
-\begin{code}
-mkClosureLFInfo top fvs upd_flag [] body
- = LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk
-
-isUpdatable ReEntrant = False
-isUpdatable SingleEntry = False
-isUpdatable Updatable = True
+mkApLFInfo rhs_ty upd_flag arity
+ = LFThunk rhs_ty NotTopLevel (arity == 0) (isUpdatable upd_flag)
+ (ApThunk arity)
\end{code}
-@mkConLFInfo@ is similar, for constructors.
+Miscellaneous LF-infos.
\begin{code}
-mkConLFInfo :: DataCon -> LambdaFormInfo
+mkLFArgument = LFArgument
+mkLFBlackHole = LFBlackHole
+mkLFLetNoEscape = LFLetNoEscape
-mkConLFInfo con
- = ASSERT(isDataCon con)
- let
- arity = getDataConArity con
- in
- if isTupleCon con then
- LFTuple con (arity == 0)
- else
- LFCon con (arity == 0)
+mkLFImported :: Id -> LambdaFormInfo
+mkLFImported id
+ = case getIdArity id of
+ ArityExactly 0 -> LFThunk (idType id)
+ TopLevel True{-no fvs-}
+ True{-updatable-} NonStandardThunk
+ ArityExactly n -> LFReEntrant (idType id) TopLevel n True -- n > 0
+ other -> LFImported -- Not sure of exact arity
\end{code}
-
%************************************************************************
%* *
\subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}}
\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
+ = 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?
+ = tot_wds + computeSlopSize tot_wds sm_rep (closureUpdReqd cl_info)
+ --ToDo: pass lf_info?
where
tot_wds = closureGoodStuffSize cl_info
in ptrs
-- not exported:
-sizes_from_SMRep (SpecialisedRep k ptrs nonptrs _) = (ptrs, nonptrs)
+sizes_from_SMRep :: SMRep -> (Int,Int)
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 (StaticRep ptrs nonptrs _) = (ptrs, nonptrs)
+sizes_from_SMRep ConstantRep = (0, 0)
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
\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}
+Static closures have an extra ``static link field'' at the end, but we
+don't bother taking that into account here.
+
\begin{code}
slopSize cl_info@(MkClosureInfo _ lf_info sm_rep)
- = computeSlopSize (closureGoodStuffSize cl_info) sm_rep (closureUpdReqd cl_info)
+ = computeSlopSize (closureGoodStuffSize cl_info) sm_rep
+ (closureUpdReqd cl_info)
computeSlopSize :: Int -> SMRep -> Bool -> Int
-computeSlopSize tot_wds (SpecialisedRep ConstantRep _ _ _) _
- = 0
-computeSlopSize tot_wds (SpecialisedRep CharLikeRep _ _ _) _
- = 0
-
-computeSlopSize tot_wds (SpecialisedRep _ _ _ _) True -- Updatable
+computeSlopSize tot_wds (StaticRep _ _ _) True -- Updatable
= max 0 (mIN_UPD_SIZE - tot_wds)
-computeSlopSize tot_wds (StaticRep _ _) True -- Updatable
+computeSlopSize tot_wds (StaticRep _ _ _) False
+ = 0 -- non updatable, non-heap object
+computeSlopSize tot_wds (GenericRep _ _ _) True -- Updatable
= max 0 (mIN_UPD_SIZE - tot_wds)
-computeSlopSize tot_wds BlackHoleRep _ -- Updatable
- = max 0 (mIN_UPD_SIZE - tot_wds)
-
-computeSlopSize tot_wds (SpecialisedRep _ _ _ _) False -- Not updatable
+computeSlopSize tot_wds (GenericRep _ _ _) False
= max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds)
-
-computeSlopSize tot_wds other_rep _ -- Any other rep
+computeSlopSize tot_wds ConstantRep _
= 0
+computeSlopSize tot_wds BlackHoleRep _ -- Updatable
+ = max 0 (mIN_UPD_SIZE - tot_wds)
\end{code}
%************************************************************************
\begin{code}
layOutDynClosure, layOutStaticClosure
- :: Id -- STG identifier w/ which this closure assoc'd
- -> (a -> PrimKind) -- function w/ which to be able to get a PrimKind
+ :: Name -- 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
-> (ClosureInfo, -- info about the closure
ptr_wds, -- #ptr_wds
things_w_offsets) = mkVirtHeapOffsets sm_rep kind_fn things
sm_rep = chooseDynSMRep 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)
- 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
\end{code}
A wrapper for when used with data constructors:
+
\begin{code}
layOutDynCon :: DataCon
- -> (a -> PrimKind)
+ -> (a -> PrimRep)
-> [a]
-> (ClosureInfo, [(a,VirtualHeapOffset)])
-layOutDynCon con kind_fn args
- = ASSERT(isDataCon con)
- layOutDynClosure con kind_fn args (mkConLFInfo con)
+layOutDynCon con kind_fn args
+ = layOutDynClosure (dataConName con) kind_fn args (mkConLFInfo con)
\end{code}
+%************************************************************************
+%* *
+\subsection[layOutStaticClosure]{Lay out a static closure}
+%* *
+%************************************************************************
+
+layOutStaticClosure is only used for laying out static constructors at
+the moment.
+
+Static closures for functions are laid out using
+layOutStaticNoFVClosure.
+
+\begin{code}
+layOutStaticClosure name kind_fn things lf_info
+ = (MkClosureInfo name lf_info
+ (StaticRep ptr_wds (tot_wds - ptr_wds) closure_type),
+ things_w_offsets)
+ where
+ (tot_wds, -- #ptr_wds + #nonptr_wds
+ ptr_wds, -- #ptr_wds
+ things_w_offsets) = mkVirtHeapOffsets (StaticRep bot bot bot) kind_fn things
+ -- constructors with no pointer fields will definitely be NOCAF things.
+ -- this is a compromise until we can generate both kinds of constructor
+ -- (a normal static kind and the NOCAF_STATIC kind).
+ closure_type = case lf_info of
+ LFCon _ _ | ptr_wds == 0 -> CONSTR_NOCAF
+ _ -> getClosureType lf_info
+
+ bot = panic "layoutStaticClosure"
+
+layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> ClosureInfo
+layOutStaticNoFVClosure name lf_info
+ = MkClosureInfo name lf_info (StaticRep 0 0 (getClosureType lf_info))
+\end{code}
%************************************************************************
%* *
chooseDynSMRep 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
+ closure_type = getClosureType 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
-
- (LFTuple _ _) -> SpecRep
-
- (LFCon _ True) -> ConstantRep
-
- (LFCon con _ ) -> if maybeToBool (maybeCharLikeTyCon tycon) then CharLikeRep
- else if maybeToBool (maybeIntLikeTyCon tycon) then IntLikeRep
- else SpecRep
- where
- tycon = getDataConTyCon con
+ case lf_info of
+ LFTuple _ True -> ConstantRep
+ LFCon _ True -> ConstantRep
+ _ -> GenericRep ptr_wds nonptr_wds closure_type
- _ -> SpecRep
- in
- SpecialisedRep spec_kind ptr_wds nonptr_wds updatekind
- else
- GenericRep ptr_wds nonptr_wds updatekind
+getClosureType :: LambdaFormInfo -> ClosureType
+getClosureType lf_info =
+ case lf_info of
+ LFCon con True -> CONSTR_NOCAF
+ LFCon con False -> CONSTR
+ LFReEntrant _ _ _ _ -> FUN
+ LFTuple _ _ -> CONSTR
+ LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR
+ LFThunk _ _ _ _ _ -> THUNK
+ _ -> panic "getClosureType"
+ -- ToDo: could be anything else here?
\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 -> PrimKind) -- 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
+mkVirtHeapOffsets :: SMRep -- Representation to be used by storage manager
+ -> (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
-- First in list gets lowest offset, which is initial offset + 1.
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 + (getKindSize . kind_fun) thing,
- (thing, (offset_of_first_word `addOff` (intOff wds_so_far)))
+ = (wds_so_far + (getPrimRepSize . kind_fun) thing,
+ (thing, fixedHdrSize + wds_so_far)
)
\end{code}
\begin{code}
nodeMustPointToIt :: LambdaFormInfo -> FCode Bool
nodeMustPointToIt lf_info
- = isSwitchSetC SccProfilingOn `thenFC` \ do_profiling ->
- case lf_info of
- LFReEntrant top arity no_fvs -> returnFC (
+ = case lf_info of
+ LFReEntrant ty 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 top of { TopLevel -> False; _ -> True }
+ -- 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
---OLD: || (arity == 0 && do_profiling)
--- -- Access to cost centre required for 0 arity if profiling
--- -- Simon: WHY? (94/12)
-
-- For lex_profiling we also access the cost centre for a
-- non-inherited function i.e. not top level
-- the not top case above ensures this is ok.
-- 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)
+ LFThunk _ _ no_fvs updatable some_standard_form_thunk
+ -> returnFC True
+ -- Node must point to any standard-form thunk.
+
LFArgument -> returnFC True
LFImported -> 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,
0 arg, fvs @\u@ & yes & yes & n/a & node\\
\end{tabular}
-When black-holing, single-entry closures could also be entered via node
+When black-holing, single-entry closures could also be entered via node
(rather than directly) to catch double-entry.
\begin{code}
= ViaNode -- The "normal" convention
| StdEntry CLabel -- Jump to this code, with args on stack
- (Maybe CLabel) -- possibly setting infoptr to this
- | DirectEntry -- Jump directly to code, with args in regs
+ | 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
- -> [PrimKind] -- Available arguments
+getEntryConvention :: Name -- Function being applied
+ -> LambdaFormInfo -- Its info
+ -> [PrimRep] -- Available arguments
-> FCode EntryConvention
-getEntryConvention id lf_info arg_kinds
+getEntryConvention name lf_info arg_kinds
= nodeMustPointToIt lf_info `thenFC` \ node_points ->
- isSwitchSetC ForConcurrent `thenFC` \ is_concurrent ->
- getIntSwitchChkrC `thenFC` \ isw_chkr ->
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 ViaNode 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
- else
- DirectEntry (mkFastEntryLabel id arity) arity arg_regs
+ LFReEntrant _ _ arity _ ->
+ if arity == 0 || (length arg_kinds) < arity then
+ StdEntry (mkStdEntryLabel name)
+ else
+ DirectEntry (mkFastEntryLabel name arity) arity arg_regs
where
- (arg_regs, _) = assignRegs isw_chkr live_regs (take arity arg_kinds)
+ (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
+ LFCon con True{-zero_arity-}
+ -- 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?)
+ StdEntry (mkStaticConEntryLabel (dataConName con))
+
+ LFCon con False{-non-zero_arity-}
+ -> --false:ASSERT (null arg_kinds)
+ -- Should have no args (meaning what?)
+ StdEntry (mkConEntryLabel (dataConName con))
+
+ LFTuple tup zero_arity
+ -> --false:ASSERT (null arg_kinds)
+ -- Should have no args (meaning what?)
+ StdEntry (mkConEntryLabel (dataConName tup))
+
+ LFThunk _ _ _ updatable std_form_info
-> if updatable
then ViaNode
- else StdEntry (thunkEntryLabel id std_form_info updatable) Nothing
+ else StdEntry (thunkEntryLabel name std_form_info updatable)
- LFArgument -> ViaNode
- LFImported -> ViaNode
- LFBlackHole -> ViaNode -- Presumably the black hole has by now
+ 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 _
+ LFLetNoEscape 0
+ -> StdEntry (mkReturnPtLabel (nameUnique name))
+
+ LFLetNoEscape arity
-> ASSERT(arity == length arg_kinds)
- DirectEntry (mkStdEntryLabel id) arity arg_regs
+ DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs
where
- (arg_regs, _) = assignRegs isw_chkr 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 (MkClosureInfo _ _ (StaticRep _ _ _)) = False
-blackHoleOnEntry no_black_holing (MkClosureInfo _ lf_info _)
+blackHoleOnEntry (MkClosureInfo _ lf_info _)
= 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
+ then not opt_OmitBlackHoling
else not no_fvs
- other -> panic "blackHoleOnEntry" -- Should never happen
+ other -> panic "blackHoleOnEntry" -- Should never happen
-getStandardFormThunkInfo
- :: LambdaFormInfo
- -> Maybe [PlainStgAtom] -- 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 [StgVarAtom 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 (StgVarAtom fun_id : args)
- | otherwise = Just args
+maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ _
+ (SelectorThunk offset)) _) = Just offset
+maybeSelectorInfo _ = Nothing
-getStandardFormThunkInfo other_lf_info = Nothing
+-- Does this thunk's info table have an SRT?
-maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ (SelectorThunk _ con offset)) _) = Just (con,offset)
-maybeSelectorInfo _ = Nothing
+needsSRT :: ClosureInfo -> Bool
+needsSRT (MkClosureInfo _ info _) =
+ case info of
+ LFThunk _ _ _ _ (SelectorThunk _) -> False -- not for selectors
+ LFThunk _ _ _ _ _ -> True
+ LFReEntrant _ _ _ _ -> True
+ _ -> False
\end{code}
Avoiding generating entries and info tables
OR (b) the function is passed as an arg
OR (c) if the function has free vars (ie not top level)
- Why case (a) here? Because if the arg-satis check fails,
+ Why case (a) here? Because if the arg-satis check fails,
UpdatePAP stuffs a pointer to the function closure in the PAP.
[Could be changed; UpdatePAP could stuff in a code ptr instead,
but doesn't seem worth it.]
- [NB: these conditions imply that we might need the closure
+ [NB: these conditions imply that we might need the closure
without the slow-entry code. Here's how.
f x y = let g w = ...x..y..w...
Needed iff (a) we have any un-saturated calls to the function
OR (b) the function is passed as an arg
OR (c) the function has free vars (ie not top level)
-
+
NB. In the sequential world, (c) is only required so that the function closure has
an info table to point to, to keep the storage manager happy.
If (c) alone is true we could fake up an info table by choosing
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
- -> StgBinderInfo
+ :: 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
+staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
+ (LFReEntrant _ top_level _ _) -- It's a function
+ = ASSERT( case top_level of { TopLevel -> True; other -> False } )
+ -- 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
+ || isExternallyVisibleName binder
staticClosureRequired binder other_binder_info other_lf_info = True
slowFunEntryCodeRequired -- Assumption: it's a function, not a thunk.
- :: Id
+ :: Name
-> StgBinderInfo
+ -> EntryConvention
-> Bool
-slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
+slowFunEntryCodeRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) entry_conv
= arg_occ -- There's an argument occurrence
|| unsat_occ -- There's an unsaturated call
- || externallyVisibleId binder
- {- HAS FREE VARS AND IS PARALLEL WORLD -}
+ || isExternallyVisibleName binder
+ || (case entry_conv of { DirectEntry _ _ _ -> False; other -> True })
+ {- The last case deals with the parallel world; a function usually
+ as a DirectEntry convention, but if it doesn't we must generate slow-entry code -}
-slowFunEntryCodeRequired binder NoStgBinderInfo = True
+slowFunEntryCodeRequired binder NoStgBinderInfo _ = True
funInfoTableRequired
- :: Id
+ :: Name
-> StgBinderInfo
-> LambdaFormInfo
-> Bool
funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _)
- (LFReEntrant top_level _ _)
- = not top_level
+ (LFReEntrant _ top_level _ _)
+ = (case top_level of { NotTopLevel -> True; TopLevel -> False })
|| arg_occ -- There's an argument occurrence
|| unsat_occ -- There's an unsaturated call
- || externallyVisibleId binder
+ || isExternallyVisibleName 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}
-isConstantRep, isSpecRep, isStaticRep, isPhantomRep, isIntLikeRep :: SMRep -> Bool
-isConstantRep (SpecialisedRep ConstantRep _ _ _) = True
-isConstantRep other = False
-
-isSpecRep (SpecialisedRep kind _ _ _) = True -- All the kinds of Spec closures
-isSpecRep other = False -- True indicates that the _VHS is 0 !
-
-isStaticRep (StaticRep _ _) = True
-isStaticRep _ = False
-
-isPhantomRep PhantomRep = True
-isPhantomRep _ = False
-
-isIntLikeRep (SpecialisedRep IntLikeRep _ _ _) = True
-isIntLikeRep other = False
isStaticClosure :: ClosureInfo -> Bool
isStaticClosure (MkClosureInfo _ _ rep) = isStaticRep rep
-closureId :: ClosureInfo -> Id
-closureId (MkClosureInfo id _ _) = id
+closureName :: ClosureInfo -> Name
+closureName (MkClosureInfo name _ _) = name
closureSMRep :: ClosureInfo -> SMRep
closureSMRep (MkClosureInfo _ _ sm_rep) = sm_rep
closureUpdReqd :: ClosureInfo -> Bool
-closureUpdReqd (MkClosureInfo _ (LFThunk _ _ upd _) _) = upd
+closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _) _) = upd
closureUpdReqd (MkClosureInfo _ 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.
closureSingleEntry :: ClosureInfo -> Bool
-closureSingleEntry (MkClosureInfo _ (LFThunk _ _ upd _) _) = not upd
+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, [UniType], [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 _)) _)
- = getUniDataSpecTyCon_maybe (funResultTy de_foralld_ty (length args))
- where
- (_, de_foralld_ty) = splitForalls (getIdUniType fun_id)
+closureSemiTag :: ClosureInfo -> Maybe Int
-closureType (MkClosureInfo id lf _) = getUniDataSpecTyCon_maybe (getIdUniType id)
+closureSemiTag (MkClosureInfo _ lf_info _)
+ = case lf_info of
+ LFCon data_con _ -> Just (dataConTag data_con - fIRST_TAG)
+ LFTuple _ _ -> Just 0
+ _ -> Nothing
\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 (funResultTy de_foralld_ty arity)
- where
- (_, de_foralld_ty) = splitForalls (getIdUniType fun_id)
+isToplevClosure :: ClosureInfo -> Bool
-closureReturnsUnboxedType other_closure = False
- -- All non-function closures aren't functions,
- -- and hence are boxed, since they are heap alloc'd
+isToplevClosure (MkClosureInfo _ lf_info _)
+ = case lf_info of
+ LFReEntrant _ TopLevel _ _ -> True
+ LFThunk _ TopLevel _ _ _ -> True
+ other -> False
\end{code}
\begin{code}
-closureSemiTag :: ClosureInfo -> Int
+isLetNoEscape :: ClosureInfo -> Bool
-closureSemiTag (MkClosureInfo _ lf_info _)
- = case lf_info of
- LFCon data_con _ -> getDataConTag data_con - fIRST_TAG
- LFTuple _ _ -> 0
- --UNUSED: LFIndirection -> fromInteger iND_TAG
- _ -> fromInteger oTHER_TAG
+isLetNoEscape (MkClosureInfo _ (LFLetNoEscape _) _) = True
+isLetNoEscape _ = False
\end{code}
Label generation.
\begin{code}
-infoTableLabelFromCI :: ClosureInfo -> CLabel
+fastLabelFromCI :: ClosureInfo -> CLabel
+fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _) _)
+ = mkFastEntryLabel name arity
+
+fastLabelFromCI (MkClosureInfo name _ _)
+ = pprPanic "fastLabelFromCI" (ppr name)
+infoTableLabelFromCI :: ClosureInfo -> CLabel
infoTableLabelFromCI (MkClosureInfo id lf_info rep)
= case lf_info of
LFCon con _ -> mkConInfoPtr con rep
LFBlackHole -> mkBlackHoleInfoTableLabel
- 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
-
-{- 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.
-
- Later, perhaps, we'll have some standard RTS code for selector-thunk info tables,
- in which case this line will spring back to life.
+ LFThunk _ _ _ upd_flag (SelectorThunk offset) ->
+ mkSelectorInfoLabel upd_flag offset
- LFThunk _ _ upd_flag (SelectorThunk _ _ offset) -> mkSelectorInfoTableLabel upd_flag offset
- -- Ditto for selectors
--}
+ LFThunk _ _ _ upd_flag (ApThunk arity) ->
+ mkApInfoTableLabel upd_flag arity
other -> {-NO: if isStaticRep rep
then mkStaticInfoTableLabel id
else -} mkInfoTableLabel id
-mkConInfoPtr :: Id -> SMRep -> CLabel
-mkConInfoPtr id rep =
- case rep of
- PhantomRep -> mkPhantomInfoTableLabel id
- StaticRep _ _ -> mkStaticInfoTableLabel id
- _ -> mkInfoTableLabel id
+mkConInfoPtr :: DataCon -> SMRep -> CLabel
+mkConInfoPtr con rep
+ = case rep of
+ StaticRep _ _ _ -> mkStaticInfoTableLabel name
+ _ -> mkConInfoTableLabel name
+ where
+ name = dataConName con
-mkConEntryPtr :: Id -> SMRep -> CLabel
-mkConEntryPtr id rep =
- case rep of
- StaticRep _ _ -> mkStaticConEntryLabel id
- _ -> mkConEntryLabel id
+mkConEntryPtr :: DataCon -> SMRep -> CLabel
+mkConEntryPtr con rep
+ = case rep of
+ StaticRep _ _ _ -> mkStaticConEntryLabel (dataConName con)
+ _ -> mkConEntryLabel (dataConName con)
+ where
+ name = dataConName con
+closureLabelFromCI (MkClosureInfo name _ rep)
+ | isConstantRep rep
+ = mkStaticClosureLabel name
+ -- This case catches those pesky static closures for nullary constructors
-closureLabelFromCI (MkClosureInfo id _ _) = mkClosureLabel id
+closureLabelFromCI (MkClosureInfo id _ other_rep) = mkClosureLabel id
entryLabelFromCI :: ClosureInfo -> CLabel
entryLabelFromCI (MkClosureInfo id lf_info 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
+ LFCon con _ -> mkConEntryPtr con rep
+ LFTuple tup _ -> mkConEntryPtr tup rep
+ other -> mkStdEntryLabel id
-- 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 _ 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)
\end{code}
\begin{code}
allocProfilingMsg (MkClosureInfo _ 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")
- --UNUSED: LFIndirection -> panic "ALLOC_IND"
- LFImported -> panic "ALLOC_IMP"
+ LFReEntrant _ _ _ _ -> SLIT("TICK_ALLOC_FUN")
+ LFCon _ _ -> SLIT("TICK_ALLOC_CON")
+ LFTuple _ _ -> SLIT("TICK_ALLOC_CON")
+ LFThunk _ _ _ _ _ -> SLIT("TICK_ALLOC_THK")
+ LFBlackHole -> SLIT("TICK_ALLOC_BH")
+ LFImported -> panic "TICK_ALLOC_IMP"
\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.
+We need a black-hole closure info to pass to @allocDynClosure@ when we
+want to allocate the black hole on entry to a CAF.
\begin{code}
-blackHoleClosureInfo (MkClosureInfo id _ _) = MkClosureInfo id LFBlackHole BlackHoleRep
-\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.
-
-\begin{code}
-
-dataConLiveness isw_chkr (MkClosureInfo con _ PhantomRep)
- = case (dataReturnConvAlg isw_chkr con) of
- ReturnInRegs regs -> mkLiveRegsBitMask regs
- ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???"
-
-dataConLiveness _ _ = mkLiveRegsBitMask [node]
+blackHoleClosureInfo (MkClosureInfo name _ _)
+ = MkClosureInfo name LFBlackHole BlackHoleRep
\end{code}
%************************************************************************
%* *
%************************************************************************
-Profiling requires three pices of information to be determined for
-each closure's info table --- kind, description and type.
+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 kind is determined from the @LambdaForm@ stored in the closure
-info using @closureKind@.
-
The type is determined from the type information stored with the @Id@
in the closure info using @closureTypeDescr@.
\begin{code}
-closureKind :: ClosureInfo -> String
-
-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?)
- --UNUSED: LFIndirection -> panic "IND_KIND"
- LFImported -> panic "IMP_KIND"
-
closureTypeDescr :: ClosureInfo -> String
-closureTypeDescr (MkClosureInfo id lf _)
- = if (isDataCon id) then -- DataCon has function types
- _UNPK_ (getOccurrenceName (getDataConTyCon id)) -- We want the TyCon not the ->
- else
- getUniTyDescription (getIdUniType id)
+closureTypeDescr (MkClosureInfo name (LFThunk ty _ _ _ _) _)
+ = getTyDescription ty
+closureTypeDescr (MkClosureInfo name (LFReEntrant ty _ _ _) _)
+ = getTyDescription ty
+closureTypeDescr (MkClosureInfo name lf _)
+ = showSDoc (ppr name)
\end{code}
projects / ghc-hetmet.git / blobdiff