X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FClosureInfo.lhs;h=84d9dd95efcf7a94d0e137080e0ff6897b779ef7;hb=beb5737b7ee42c4e9373a505e7d957206d69a30e;hp=2b7a7a1a8578abea3f7f56af30b19d01d1c1dc0f;hpb=f36fb2ce821caf594c1db5669dd10ca082f66361;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 2b7a7a1..84d9dd9 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,11 @@ - -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 % -\section[ClosureInfo]{Data structures which describe closures} +% (c) The Univserity of Glasgow 1992-2004 +% + + Data structures which describe closures, and + operations over those data structures + + Nothing monadic in here Much of the rationale for these things is in the ``details'' part of the STG paper. @@ -9,264 +13,122 @@ the STG paper. \begin{code} module ClosureInfo ( ClosureInfo, LambdaFormInfo, SMRep, -- all abstract - StandardFormInfo, + StandardFormInfo, - EntryConvention(..), + ArgDescr(..), Liveness(..), + C_SRT(..), needsSRT, - mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo, mkVapLFInfo, - mkLFImported, mkLFArgument, mkLFLetNoEscape, - UpdateFlag, + mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, + mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, - closureSize, closureHdrSize, - closureNonHdrSize, closureSizeWithoutFixedHdr, + mkClosureInfo, mkConInfo, + + closureSize, closureNonHdrSize, closureGoodStuffSize, closurePtrsSize, - slopSize, fitsMinUpdSize, + slopSize, + + closureName, infoTableLabelFromCI, + closureLabelFromCI, closureSRT, + closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd, + closureNeedsUpdSpace, closureIsThunk, + closureSingleEntry, closureReEntrant, isConstrClosure_maybe, + closureFunInfo, isStandardFormThunk, isKnownFun, - layOutDynClosure, layOutDynCon, layOutStaticClosure, - layOutStaticNoFVClosure, layOutPhantomClosure, - mkVirtHeapOffsets, + enterIdLabel, enterLocalIdLabel, enterReturnPtLabel, - nodeMustPointToIt, getEntryConvention, - FCode, CgInfoDownwards, CgState, + nodeMustPointToIt, + CallMethod(..), getCallMethod, blackHoleOnEntry, staticClosureRequired, - slowFunEntryCodeRequired, funInfoTableRequired, - stdVapRequired, noUpdVapRequired, - StgBinderInfo, - - closureId, infoTableLabelFromCI, fastLabelFromCI, - closureLabelFromCI, - entryLabelFromCI, - closureLFInfo, closureSMRep, closureUpdReqd, - closureSingleEntry, closureSemiTag, closureType, - closureReturnsUnpointedType, getStandardFormThunkInfo, - GenStgArg, + getClosureType, isToplevClosure, - closureKind, closureTypeDescr, -- profiling + closureValDescr, closureTypeDescr, -- profiling - isStaticClosure, allocProfilingMsg, - blackHoleClosureInfo, - maybeSelectorInfo, + isStaticClosure, + cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo, - dataConLiveness -- concurrency + staticClosureNeedsLink, ) where +#include "../includes/MachDeps.h" #include "HsVersions.h" -import AbsCSyn ( MagicId, node, mkLiveRegsMask, - {- GHC 0.29 only -} AbstractC, CAddrMode - ) import StgSyn -import CgMonad - -import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject, - mAX_SPEC_ALL_PTRS, mAX_SPEC_MIXED_FIELDS, - mAX_SPEC_ALL_NONPTRS, - oTHER_TAG - ) -import CgRetConv ( assignRegs, dataReturnConvAlg, - DataReturnConvention(..) - ) -import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, - mkPhantomInfoTableLabel, mkInfoTableLabel, - mkConInfoTableLabel, mkStaticClosureLabel, - mkBlackHoleInfoTableLabel, mkVapInfoTableLabel, - mkStaticInfoTableLabel, mkStaticConEntryLabel, - mkConEntryLabel, mkClosureLabel, mkVapEntryLabel - ) -import CmdLineOpts ( opt_SccProfilingOn, opt_ForConcurrent ) -import HeapOffs ( intOff, addOff, totHdrSize, varHdrSize, - VirtualHeapOffset, HeapOffset - ) -import Id ( idType, getIdArity, - externallyVisibleId, - dataConTag, fIRST_TAG, - isDataCon, isNullaryDataCon, dataConTyCon, - isTupleCon, DataCon, - GenId{-instance Eq-}, Id - ) -import IdInfo ( ArityInfo(..) ) -import Maybes ( maybeToBool ) -import Name ( getOccString ) -import PprType ( getTyDescription ) -import PrelInfo ( maybeCharLikeCon, maybeIntLikeCon ) -import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep ) import SMRep -- all of it -import TyCon ( TyCon, isNewTyCon ) -import Type ( isUnpointedType, splitForAllTys, splitFunTys, mkFunTys, - splitAlgTyConApp_maybe, applyTys, - Type - ) -import Util ( isIn, mapAccumL ) -import Outputable -import GlaExts --tmp -\end{code} -The ``wrapper'' data type for closure information: +import CLabel + +import Constants ( mIN_PAYLOAD_SIZE ) +import Packages ( isDllName, HomeModules ) +import StaticFlags ( opt_SccProfilingOn, opt_OmitBlackHoling, + opt_Parallel, opt_DoTickyProfiling ) +import Id ( Id, idType, idArity, idName ) +import DataCon ( DataCon, dataConTyCon, isNullaryRepDataCon, dataConName ) +import Name ( Name, nameUnique, getOccName, getOccString ) +import OccName ( occNameString ) +import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe ) +import TcType ( tcSplitSigmaTy ) +import TyCon ( isFunTyCon, isAbstractTyCon ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, ipNameName ) +import FastString +import Outputable +import Constants -\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 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 ) - -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} +Information about a closure, from the code generator's point of view. -{\em Inner non-constructors (@mkEntryInfo@)} +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) -\begin{verbatim} - Base-label = x - NodeMustPoint = True -- If no free vars, would have been - -- lifted to top level - ClosureClass = whatever -\end{verbatim} +We make a ClosureInfo for + - each let binding (both top level and not) + - each data constructor (for its shared static and + dynamic info tables) -{\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, + closureDllCon :: !Bool -- is in a separate DLL + } + +-- C_SRT is what StgSyn.SRT gets translated to... +-- we add a label for the table, and expect only the 'offset/length' form + +data C_SRT = NoC_SRT + | C_SRT !CLabel !WordOff !StgHalfWord {-bitmap or escape-} + +needsSRT :: C_SRT -> Bool +needsSRT NoC_SRT = False +needsSRT (C_SRT _ _ _) = True +\end{code} %************************************************************************ %* * @@ -274,101 +136,102 @@ mkConEntryInfo lbl %* * %************************************************************************ +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. Invariant: always > 0 + !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 + | LFCon -- A saturated constructor application + 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 +------------------------- +-- An ArgDsecr describes the argument pattern of a function - | 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.) +data ArgDescr + = ArgSpec -- Fits one of the standard patterns + !Int -- RTS type identifier ARG_P, ARG_N, ... -{- A SelectorThunk is of form + | ArgGen -- General case + Liveness -- Details about the arguments - 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. --} +------------------------- +-- We represent liveness bitmaps as a Bitmap (whose internal +-- representation really is a bitmap). These are pinned onto case return +-- vectors to indicate the state of the stack for the garbage collector. +-- +-- In the compiled program, liveness bitmaps that fit inside a single +-- word (StgWord) are stored as a single word, while larger bitmaps are +-- stored as a pointer to an array of words. - | VapThunk - Id -- Function - [StgArg] -- Args - Bool -- True <=> the function is not top-level, so - -- must be stored in the thunk too +data Liveness + = SmallLiveness -- Liveness info that fits in one word + StgWord -- Here's the bitmap -{- A VapThunk is of form + | BigLiveness -- Liveness info witha a multi-word bitmap + CLabel -- Label for the bitmap - 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. --} +------------------------- +-- StandardFormInfo tells whether this thunk has one of +-- a small number of standard forms +data StandardFormInfo + = NonStandardThunk + -- Not of of the standard forms -mkLFArgument = LFArgument -mkLFBlackHole = LFBlackHole -mkLFLetNoEscape = LFLetNoEscape + | SelectorThunk + -- A SelectorThunk is of form + -- case x of + -- con a1,..,an -> ak + -- and the constructor is from a single-constr type. + WordOff -- 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.) -mkLFImported :: Id -> LambdaFormInfo -mkLFImported id - = case getIdArity id of - ArityExactly 0 -> LFThunk True{-top-lev-} True{-no fvs-} - True{-updatable-} NonStandardThunk - ArityExactly n -> LFReEntrant True n True -- n > 0 - other -> LFImported -- Not sure of exact arity + | ApThunk + -- 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. + Int -- Arity, n \end{code} %************************************************************************ @@ -377,239 +240,190 @@ mkLFImported id %* * %************************************************************************ -@mkClosureLFInfo@ figures out the appropriate LFInfo for the closure. - \begin{code} -mkClosureLFInfo :: Bool -- True of top level - -> [Id] -- Free vars - -> UpdateFlag -- Update flag - -> [Id] -- Args - -> LambdaFormInfo +mkLFReEntrant :: TopLevelFlag -- True of top level + -> [Id] -- Free vars + -> [Id] -- Args + -> ArgDescr -- Argument descriptor + -> LambdaFormInfo + +mkLFReEntrant top fvs args arg_descr + = LFReEntrant top (length args) (null fvs) arg_descr + +mkLFThunk thunk_ty top fvs upd_flag + = ASSERT( not (isUpdatable upd_flag) || not (isUnLiftedType thunk_ty) ) + LFThunk top (null fvs) + (isUpdatable upd_flag) + NonStandardThunk + (might_be_a_function thunk_ty) + +might_be_a_function :: Type -> Bool +might_be_a_function ty + | Just (tc,_) <- splitTyConApp_maybe (repType ty), + not (isFunTyCon tc) && not (isAbstractTyCon tc) = False + -- don't forget to check for abstract types, which might + -- be functions too. + | otherwise = True +\end{code} -mkClosureLFInfo top fvs upd_flag args@(_:_) -- Non-empty args - = LFReEntrant top (length args) (null fvs) +@mkConLFInfo@ is similar, for constructors. -mkClosureLFInfo top fvs ReEntrant [] - = LFReEntrant top 0 (null fvs) +\begin{code} +mkConLFInfo :: DataCon -> LambdaFormInfo +mkConLFInfo con = LFCon con -mkClosureLFInfo top fvs upd_flag [] - = 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 - = -- the isNullaryDataCon will do this: ASSERT(isDataCon con) - (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con) - -mkSelectorLFInfo scrutinee con offset - = LFThunk False False True (SelectorThunk scrutinee con offset) +mkLFLetNoEscape = LFLetNoEscape -mkVapLFInfo fvs upd_flag fun_id args fun_in_vap - = LFThunk False (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args fun_in_vap) +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} +isLFThunk :: LambdaFormInfo -> Bool +isLFThunk (LFThunk _ _ _ _ _) = True +isLFThunk (LFBlackHole _) = True + -- return True for a blackhole: this function is used to determine + -- whether to use the thunk header in SMP mode, and a blackhole + -- must have one. +isLFThunk _ = False +\end{code} %************************************************************************ %* * -\subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}} + Building ClosureInfos %* * %************************************************************************ \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)) +mkClosureInfo :: Bool -- Is static + -> Id + -> LambdaFormInfo + -> Int -> Int -- Total and pointer words + -> C_SRT + -> String -- String descriptor + -> ClosureInfo +mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr + = ClosureInfo { closureName = name, + closureLFInfo = lf_info, + closureSMRep = sm_rep, + closureSRT = srt_info, + closureType = idType id, + closureDescr = descr } + where + name = idName id + sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds + +mkConInfo :: HomeModules + -> Bool -- Is static + -> DataCon + -> Int -> Int -- Total and pointer words + -> ClosureInfo +mkConInfo hmods is_static data_con tot_wds ptr_wds + = ConInfo { closureSMRep = sm_rep, + closureCon = data_con, + closureDllCon = isDllName hmods (dataConName data_con) } + where + sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds +\end{code} -closureHdrSize :: ClosureInfo -> HeapOffset -closureHdrSize (MkClosureInfo _ _ sm_rep) - = totHdrSize sm_rep +%************************************************************************ +%* * +\subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}} +%* * +%************************************************************************ -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? +\begin{code} +closureSize :: ClosureInfo -> WordOff +closureSize cl_info = hdr_size + closureNonHdrSize cl_info + where hdr_size | closureIsThunk cl_info = thunkHdrSize + | otherwise = fixedHdrSize + -- All thunks use thunkHdrSize, even if they are non-updatable. + -- this is because we don't have separate closure types for + -- updatable vs. non-updatable thunks, so the GC can't tell the + -- difference. If we ever have significant numbers of non- + -- updatable thunks, it might be worth fixing this. + +closureNonHdrSize :: ClosureInfo -> WordOff +closureNonHdrSize cl_info + = tot_wds + computeSlopSize tot_wds cl_info where tot_wds = closureGoodStuffSize cl_info -closureGoodStuffSize :: ClosureInfo -> Int -closureGoodStuffSize (MkClosureInfo _ _ sm_rep) - = let (ptrs, nonptrs) = sizes_from_SMRep sm_rep +closureGoodStuffSize :: ClosureInfo -> WordOff +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 :: ClosureInfo -> WordOff +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 -> (WordOff,WordOff) +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 knowledge of what the storage manager does with the various representations... -Slop Requirements: -\begin{itemize} -\item -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 - \end{itemize} -THEREFORE: @mIN_UPD_SIZE = 2@. - -\item -Collectable closures which are allocated in the heap -must be @mIN_SIZE_NonUpdHeapObject@. - -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} +Slop Requirements: every thunk gets an extra padding word in the +header, which takes the the updated value. \begin{code} -slopSize cl_info@(MkClosureInfo _ lf_info sm_rep) - = 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 - = 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 - = max 0 (mIN_UPD_SIZE - tot_wds) - -computeSlopSize tot_wds (SpecialisedRep _ _ _ _) False -- Not updatable - = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds) - -computeSlopSize tot_wds other_rep _ -- Any other rep - = 0 -\end{code} - -%************************************************************************ -%* * -\subsection[layOutDynClosure]{Lay out a dynamic closure} -%* * -%************************************************************************ +slopSize cl_info = computeSlopSize payload_size cl_info + where payload_size = closureGoodStuffSize cl_info -\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 - -> [a] -- the "things" being layed out - -> LambdaFormInfo -- what sort of closure it is - -> (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, - things_w_offsets) +computeSlopSize :: WordOff -> ClosureInfo -> WordOff +computeSlopSize payload_size cl_info + = max 0 (minPayloadSize smrep updatable - payload_size) where - (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 - -layOutStaticClosure name kind_fn things lf_info - = (MkClosureInfo name lf_info (StaticRep ptr_wds (tot_wds - ptr_wds)), - things_w_offsets) + smrep = closureSMRep cl_info + updatable = closureNeedsUpdSpace 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 + +minPayloadSize :: SMRep -> Bool -> WordOff +minPayloadSize smrep updatable + = case smrep of + BlackHoleRep -> min_upd_size + GenericRep _ _ _ _ | updatable -> min_upd_size + GenericRep True _ _ _ -> 0 -- static + GenericRep False _ _ _ -> mIN_PAYLOAD_SIZE + -- ^^^^^___ dynamic 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 -> PrimRep) - -> [a] - -> (ClosureInfo, [(a,VirtualHeapOffset)]) - -layOutDynCon con kind_fn args - = ASSERT(isDataCon con) - layOutDynClosure con kind_fn args (mkConLFInfo con) + min_upd_size = + ASSERT(mIN_PAYLOAD_SIZE <= sIZEOF_StgSMPThunkHeader) + 0 -- check that we already have enough + -- room for mIN_SIZE_NonUpdHeapObject, + -- due to the extra header word in SMP \end{code} - %************************************************************************ %* * \subsection[SMreps]{Choosing SM reps} @@ -617,79 +431,33 @@ layOutDynCon con kind_fn args %************************************************************************ \begin{code} -chooseDynSMRep - :: LambdaFormInfo - -> Int -> Int -- Tot wds, ptr wds +chooseSMRep + :: Bool -- True <=> static closure + -> LambdaFormInfo + -> WordOff -> WordOff -- 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 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 - - (LFTuple _ _) -> SpecRep + GenericRep is_static ptr_wds nonptr_wds closure_type - (LFCon _ True) -> ConstantRep - - (LFCon con _ ) -> if maybeCharLikeCon con then CharLikeRep - else if maybeIntLikeCon con then IntLikeRep - else SpecRep - - _ -> SpecRep - in - SpecialisedRep spec_kind ptr_wds nonptr_wds updatekind - else - GenericRep ptr_wds nonptr_wds updatekind -\end{code} +-- 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. - -%************************************************************************ -%* * -\subsection[mkVirtHeapOffsets]{Assigning heap offsets in a closure} -%* * -%************************************************************************ - -@mkVirtHeapOffsets@ (the heap version) always returns boxed things with -smaller offsets than the unboxed things, and furthermore, the offsets in -the result list - -\begin{code} -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. - -mkVirtHeapOffsets sm_rep 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))) - ) +getClosureType :: Bool -> WordOff -> LambdaFormInfo -> ClosureType +getClosureType is_static 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} %************************************************************************ @@ -701,16 +469,11 @@ mkVirtHeapOffsets sm_rep kind_fun things Be sure to see the stg-details notes about these... \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 +nodeMustPointToIt :: LambdaFormInfo -> Bool +nodeMustPointToIt (LFReEntrant top _ no_fvs _) + = 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 @@ -718,10 +481,8 @@ nodeMustPointToIt lf_info -- 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. - ) - LFCon _ zero_arity -> returnFC True - LFTuple _ zero_arity -> returnFC True +nodeMustPointToIt (LFCon _) = True -- Strictly speaking, the above two don't need Node to point -- to it if the arity = 0. But this is a *really* unlikely @@ -734,9 +495,8 @@ nodeMustPointToIt lf_info -- having Node point to the result of an update. SLPJ -- 27/11/92. - LFThunk _ no_fvs updatable NonStandardThunk - -> returnFC (updatable || not no_fvs || do_profiling) - +nodeMustPointToIt (LFThunk _ no_fvs updatable NonStandardThunk _) + = updatable || not no_fvs || opt_SccProfilingOn -- For the non-updatable (single-entry case): -- -- True if has fvs (in which case we need access to them, and we @@ -744,21 +504,12 @@ nodeMustPointToIt lf_info -- 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. - -- For example, - -- x = f y - -- generates a Vap thunk for (f y), and even if y is a global - -- variable we must still make Node point to the thunk before entering it - -- because that's what the standard-form code expects. - - LFArgument -> returnFC True - LFImported -> returnFC True - LFBlackHole -> returnFC True - -- BH entry may require Node to point - - LFLetNoEscape _ _ -> returnFC False +nodeMustPointToIt (LFThunk _ no_fvs updatable some_standard_form_thunk _) + = True -- Node must point to any standard-form thunk + +nodeMustPointToIt (LFUnknown _) = True +nodeMustPointToIt (LFBlackHole _) = True -- BH entry may require Node to point +nodeMustPointToIt (LFLetNoEscape _) = False \end{code} The entry conventions depend on the type of closure being entered, @@ -790,113 +541,140 @@ When black-holing, single-entry closures could also be entered via node (rather than directly) to catch double-entry. \begin{code} -data EntryConvention - = ViaNode -- The "normal" convention +data CallMethod + = 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 - CLabel -- The code label - Int -- Its arity - [MagicId] -- Its register assignments (possibly empty) + | ReturnIt -- it's a function, but we have + -- zero args to apply to it, so just + -- return it. -getEntryConvention :: Id -- Function being applied - -> LambdaFormInfo -- Its info - -> [PrimRep] -- Available arguments - -> FCode EntryConvention + | ReturnCon DataCon -- It's a data constructor, just return it -getEntryConvention id 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 - - 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 - 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 - mkConInfoTableLabel con - in - --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?) - StdEntry (mkConEntryLabel con) (Just itbl) - - LFTuple tup zero_arity - -> --false:ASSERT (null arg_kinds) -- Should have no args (meaning what?) - StdEntry (mkConEntryLabel tup) (Just (mkConInfoTableLabel tup)) - - 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 - where - (arg_regs, _) = assignRegs live_regs arg_kinds - live_regs = if node_points then [node] else [] - ) - -blackHoleOnEntry :: Bool -- No-black-holing flag - -> ClosureInfo - -> Bool + | SlowCall -- Unknown fun, or known fun with + -- too few args. + + | DirectEntry -- Jump directly, with args in regs + CLabel -- The code label + Int -- Its arity +getCallMethod :: HomeModules + -> Name -- Function being applied + -> LambdaFormInfo -- Its info + -> Int -- Number of available arguments + -> CallMethod + +getCallMethod hmods name lf_info n_args + | nodeMustPointToIt lf_info && opt_Parallel + = -- 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. + EnterIt + +getCallMethod hmods name (LFReEntrant _ arity _ _) n_args + | n_args == 0 = ASSERT( arity /= 0 ) + ReturnIt -- No args at all + | n_args < arity = SlowCall -- Not enough args + | otherwise = DirectEntry (enterIdLabel hmods name) arity + +getCallMethod hmods name (LFCon con) n_args + = ASSERT( n_args == 0 ) + ReturnCon con + +getCallMethod hmods name (LFThunk _ _ updatable std_form_info is_fun) n_args + | is_fun -- Must always "call" a function-typed + = SlowCall -- thing, cannot just enter it [in eval/apply, the entry code + -- is the fast-entry code] + + | updatable || opt_DoTickyProfiling -- to catch double entry + {- OLD: || opt_SMP + I decided to remove this, because in SMP mode it doesn't matter + if we enter the same thunk multiple times, so the optimisation + of jumping directly to the entry code is still valid. --SDM + -} + = ASSERT( n_args == 0 ) EnterIt + + | otherwise -- Jump direct to code for single-entry thunks + = ASSERT( n_args == 0 ) + JumpToIt (thunkEntryLabel hmods name std_form_info updatable) + +getCallMethod hmods name (LFUnknown True) n_args + = SlowCall -- might be a function + +getCallMethod hmods name (LFUnknown False) n_args + = ASSERT2 ( n_args == 0, ppr name <+> ppr n_args ) + EnterIt -- Not a function + +getCallMethod hmods name (LFBlackHole _) n_args + = SlowCall -- Presumably the black hole has by now + -- been updated, but we don't know with + -- what, so we slow call it + +getCallMethod hmods name (LFLetNoEscape 0) n_args + = JumpToIt (enterReturnPtLabel (nameUnique name)) + +getCallMethod hmods name (LFLetNoEscape arity) n_args + | n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity + | otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity) + +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 - other -> panic "blackHoleOnEntry" -- Should never happen + 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. -getStandardFormThunkInfo - :: LambdaFormInfo - -> Maybe [StgArg] -- Nothing => not a standard-form thunk - -- Just atoms => a standard-form thunk with payload atoms + other -> panic "blackHoleOnEntry" -- Should never happen -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 :: LambdaFormInfo -> Bool +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 +isKnownFun :: LambdaFormInfo -> Bool +isKnownFun (LFReEntrant _ _ _ _) = True +isKnownFun (LFLetNoEscape _) = True +isKnownFun _ = False +\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 (isNullaryRepDataCon 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 @@ -960,91 +738,19 @@ have closure, info table, and entry code.] 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 - -> EntryConvention - -> Bool -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 - || (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 - -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} - -@lfArity@ extracts the arity of a function from its LFInfo - -\begin{code} -{- Not needed any more - -lfArity_maybe (LFReEntrant _ arity _) = Just arity - --- Removed SLPJ March 97. I don't believe these two; --- LFCon is used for construcor *applications*, not constructors! --- --- lfArity_maybe (LFCon con _) = Just (dataConArity con) --- lfArity_maybe (LFTuple con _) = Just (dataConArity con) - -lfArity_maybe other = Nothing --} \end{code} %************************************************************************ @@ -1056,231 +762,143 @@ lfArity_maybe other = Nothing \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 ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info +closureUpdReqd ConInfo{} = False -closureUpdReqd (MkClosureInfo _ (LFThunk _ _ upd _) _) = upd -closureUpdReqd (MkClosureInfo _ LFBlackHole _) = True +lfUpdatable :: LambdaFormInfo -> Bool +lfUpdatable (LFThunk _ _ upd _ _) = upd +lfUpdatable (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 +lfUpdatable _ = False -closureSingleEntry :: ClosureInfo -> Bool +closureIsThunk :: ClosureInfo -> Bool +closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info +closureIsThunk ConInfo{} = False -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 _)) _) - = splitAlgTyConApp_maybe (fun_result_ty (length args) (idType fun_id)) - -closureType (MkClosureInfo id lf _) = splitAlgTyConApp_maybe (idType id) -\end{code} - -@closureReturnsUnpointedType@ 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} -closureReturnsUnpointedType :: ClosureInfo -> Bool - -closureReturnsUnpointedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _) - = isUnpointedType (fun_result_ty arity (idType fun_id)) - -closureReturnsUnpointedType other_closure = False - -- All non-function closures aren't functions, - -- and hence are boxed, since they are heap alloc'd - --- fun_result_ty is a disgusting little bit of code that finds the result --- type of a function application. It looks "through" new types. --- We don't have type args available any more, so we are pretty cavilier, --- and quite possibly plain wrong. Let's hope it doesn't matter if we are! - -fun_result_ty arity ty - | arity <= n_arg_tys - = mkFunTys (drop arity arg_tys) res_ty - - | otherwise - = case splitAlgTyConApp_maybe res_ty of - Nothing -> pprPanic "fun_result_ty:" (hsep [int arity, - ppr ty]) - - Just (tycon, tycon_arg_tys, [con]) | isNewTyCon tycon - -> fun_result_ty (arity - n_arg_tys) rep_ty - where - ([rep_ty], _) = splitFunTys (applyTys (idType con) tycon_arg_tys) - Just (_,_,cons) -> trace (showSDoc (ppr ty) ++ showSDoc(ppr cons)) $ panic "fun_result_ty" - where - (_, rho_ty) = splitForAllTys ty - (arg_tys, res_ty) = splitFunTys rho_ty - n_arg_tys = length arg_tys -\end{code} - -\begin{code} -closureSemiTag :: ClosureInfo -> Int - -closureSemiTag (MkClosureInfo _ lf_info _) - = case lf_info of - LFCon data_con _ -> dataConTag data_con - fIRST_TAG - LFTuple _ _ -> 0 - _ -> fromInteger oTHER_TAG +closureSingleEntry :: ClosureInfo -> Bool +closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd +closureSingleEntry other_closure = False + +closureReEntrant :: ClosureInfo -> Bool +closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True +closureReEntrant other_closure = False + +isConstrClosure_maybe :: ClosureInfo -> Maybe DataCon +isConstrClosure_maybe (ConInfo { closureCon = data_con }) = Just data_con +isConstrClosure_maybe _ = Nothing + +closureFunInfo :: ClosureInfo -> Maybe (Int, ArgDescr) +closureFunInfo (ClosureInfo { closureLFInfo = LFReEntrant _ arity _ arg_desc}) + = Just (arity, arg_desc) +closureFunInfo _ + = Nothing \end{code} \begin{code} isToplevClosure :: ClosureInfo -> Bool - -isToplevClosure (MkClosureInfo _ lf_info _) +isToplevClosure (ClosureInfo { closureLFInfo = lf_info }) = case lf_info of - LFReEntrant top _ _ -> top - LFThunk top _ _ _ -> top - _ -> panic "ClosureInfo:isToplevClosure" + LFReEntrant TopLevel _ _ _ -> True + LFThunk TopLevel _ _ _ _ -> True + other -> False +isToplevClosure _ = False \end{code} Label generation. \begin{code} -fastLabelFromCI :: ClosureInfo -> CLabel -fastLabelFromCI (MkClosureInfo id lf_info _) -{- [SLPJ Changed March 97] - (was ok, but is the only call to lfArity, - and the id should guarantee to have the correct arity in it. - - = case lfArity_maybe lf_info of - Just arity -> --} - = case getIdArity id of - ArityExactly arity -> mkFastEntryLabel id arity - other -> pprPanic "fastLabelFromCI" (ppr id) - 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 -> 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. + LFBlackHole info -> info - 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 + LFThunk{} -> mkLocalInfoTableLabel name -mkConInfoPtr :: Id -> SMRep -> CLabel -mkConInfoPtr con rep - = ASSERT(isDataCon con) - case rep of - PhantomRep -> mkPhantomInfoTableLabel con - StaticRep _ _ -> mkStaticInfoTableLabel con - _ -> mkConInfoTableLabel con + LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name -mkConEntryPtr :: Id -> SMRep -> CLabel -mkConEntryPtr con rep - = ASSERT(isDataCon con) - case rep of - StaticRep _ _ -> mkStaticConEntryLabel con - _ -> mkConEntryLabel con + other -> panic "infoTableLabelFromCI" +infoTableLabelFromCI (ConInfo { closureCon = con, + closureSMRep = rep, + closureDllCon = dll }) + | isStaticRep rep = mkStaticInfoTableLabel name dll + | otherwise = mkConInfoTableLabel name dll + where + name = dataConName con -closureLabelFromCI (MkClosureInfo id _ rep) - | isConstantRep rep - = mkStaticClosureLabel id - -- This case catches those pesky static closures for nullary constructors - -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 +-- ClosureInfo for a closure (as opposed to a constructor) is always local +closureLabelFromCI (ClosureInfo { closureName = nm }) = mkLocalClosureLabel nm +closureLabelFromCI _ = panic "closureLabelFromCI" -- 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 - = mkStdEntryLabel thunk_id +-- entryLabelFromCI and getCallMethod. + +thunkEntryLabel hmods thunk_id (ApThunk arity) is_updatable + = enterApLabel is_updatable arity +thunkEntryLabel hmods thunk_id (SelectorThunk offset) upd_flag + = enterSelectorLabel upd_flag offset +thunkEntryLabel hmods thunk_id _ is_updatable + = enterIdLabel hmods thunk_id + +enterApLabel is_updatable arity + | tablesNextToCode = mkApInfoTableLabel is_updatable arity + | otherwise = mkApEntryLabel is_updatable arity + +enterSelectorLabel upd_flag offset + | tablesNextToCode = mkSelectorInfoLabel upd_flag offset + | otherwise = mkSelectorEntryLabel upd_flag offset + +enterIdLabel hmods id + | tablesNextToCode = mkInfoTableLabel hmods id + | otherwise = mkEntryLabel hmods id + +enterLocalIdLabel id + | tablesNextToCode = mkLocalInfoTableLabel id + | otherwise = mkLocalEntryLabel id + +enterReturnPtLabel name + | tablesNextToCode = mkReturnInfoLabel name + | otherwise = mkReturnPtLabel name \end{code} -\begin{code} -allocProfilingMsg :: ClosureInfo -> FAST_STRING - -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") - LFImported -> panic "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. - -\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. +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} -dataConLiveness (MkClosureInfo con _ PhantomRep) - = case (dataReturnConvAlg con) of - ReturnInRegs regs -> mkLiveRegsMask regs - ReturnInHeap -> panic "dataConLiveness:PhantomRep in heap???" - -dataConLiveness _ = mkLiveRegsMask [node] +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} %************************************************************************ @@ -1289,34 +907,45 @@ dataConLiveness _ = mkLiveRegsMask [node] %* * %************************************************************************ -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?) - LFImported -> panic "IMP_KIND" - -closureTypeDescr :: ClosureInfo -> String -closureTypeDescr (MkClosureInfo id lf _) - = if (isDataCon id) then -- DataCon has function types - getOccString (dataConTyCon id) -- We want the TyCon not the -> - else - getTyDescription (idType id) +closureValDescr, closureTypeDescr :: ClosureInfo -> String +closureValDescr (ClosureInfo {closureDescr = descr}) + = descr +closureValDescr (ConInfo {closureCon = con}) + = occNameString (getOccName con) + +closureTypeDescr (ClosureInfo { closureType = ty }) + = getTyDescription ty +closureTypeDescr (ConInfo { closureCon = data_con }) + = occNameString (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 + TyConApp tycon _ -> getOccString tycon + NoteTy (FTVNote _) ty -> getTyDescription ty + PredTy sty -> getPredTyDescription sty + ForAllTy _ ty -> getTyDescription ty + } + where + fun_result (FunTy _ res) = '>' : fun_result res + fun_result other = getTyDescription other + +getPredTyDescription (ClassP cl tys) = getOccString cl +getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip) \end{code} + +