X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FClosureInfo.lhs;h=50271c6611cc1696e92d4c28f551f89ee1b8419c;hb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;hp=dddeddf47158db8fc51e1bb5199b0d67fc85c754;hpb=6c381e873e222417d9a67aeec77b9555eca7b7a8;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index dddeddf..50271c6 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,5 +1,7 @@ - -% (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} @@ -7,71 +9,83 @@ Much of the rationale for these things is in the ``details'' part of 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, + closureSize, closureNonHdrSize, closureGoodStuffSize, closurePtrsSize, - slopSize, fitsMinUpdSize, + slopSize, layOutDynClosure, layOutDynCon, layOutStaticClosure, - layOutStaticNoFVClosure, layOutPhantomClosure, - mkVirtHeapOffsets, -- for GHCI + layOutStaticNoFVClosure, + mkVirtHeapOffsets, + + nodeMustPointToIt, getEntryConvention, + FCode, CgInfoDownwards, CgState, - nodeMustPointToIt, getEntryConvention, blackHoleOnEntry, 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, - closureKind, closureTypeDescr, -- profiling + isToplevClosure, + closureTypeDescr, -- profiling - isConstantRep, isSpecRep, isPhantomRep, -- ToDo: Should be in SMRep, perhaps? - isStaticClosure, allocProfilingMsg, + isStaticClosure, + allocProfilingMsg, blackHoleClosureInfo, - getSMInfoStr, getSMInitHdrStr, getSMUpdInplaceHdrStr, - ltSMRepHdr, maybeSelectorInfo, - - dataConLiveness -- concurrency - - -- and to make the interface self-sufficient... + needsSRT ) where -import AbsCSyn -import CgMonad -import SMRep +#include "HsVersions.h" + +import AbsCSyn ( MagicId, node, VirtualHeapOffset, HeapOffset ) import StgSyn +import CgMonad -import Type -import CgCompInfo -- some magic constants -import CgRetConv -import CLabel -- 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 PrimRep ( PrimRep, getPrimRepSize, 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: @@ -79,160 +93,13 @@ 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} %* * %************************************************************************ @@ -246,21 +113,23 @@ mkConEntryInfo lbl \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 @@ -276,28 +145,22 @@ data LambdaFormInfo | 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) | 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 @@ -305,39 +168,20 @@ data StandardFormInfo -- Tells whether this thunk has one of a small number con a1,..,an -> ak and the constructor is from a single-constr type. - If we can't convert the heap-offset of the selectee into an Int, e.g., - it's "GEN_VHS+i", we just give up. -} - | VapThunk - Id -- Function - [StgArg] -- Args - Bool -- True <=> the function is not top-level, so - -- must be stored in the thunk too + | ApThunk + Int -- arity -{- A VapThunk is of form +{- An ApThunk is of form - f a1 ... an + x1 ... xn - where f is a known function, with arity n - So for this thunk we can use the label for f's heap-entry - info table (generated when f's defn was dealt with), - rather than generating a one-off info table and entry code - for this one thunk. + The code for the thunk just pushes x2..xn on the stack and enters x1. + There are a few of these (for 1 <= n <= MAX_SPEC_AP_SIZE) pre-compiled + in the RTS to save space. -} - -mkLFArgument = LFArgument -mkLFBlackHole = LFBlackHole -mkLFLetNoEscape = LFLetNoEscape - -mkLFImported :: Id -> LambdaFormInfo -mkLFImported id - = case arityMaybe (getIdArity id) of - Nothing -> LFImported - Just 0 -> LFThunk True{-top-lev-} True{-no fvs-} - True{-updatable-} NonStandardThunk - Just n -> LFReEntrant True n True -- n > 0 \end{code} %************************************************************************ @@ -349,118 +193,63 @@ mkLFImported id @mkClosureLFInfo@ figures out the appropriate LFInfo for the closure. \begin{code} -mkClosureLFInfo :: Bool -- True of top level +mkClosureLFInfo :: Id -- The binder + -> TopLevelFlag -- True of top level -> [Id] -- Free vars -> UpdateFlag -- Update flag -> [Id] -- Args - -> StgExpr -- Body of closure: passed so we - -- can look for selector thunks! -> LambdaFormInfo -mkClosureLFInfo top fvs upd_flag args@(_:_) body -- Non-empty args - = LFReEntrant top (length args) (null fvs) +mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args + = LFReEntrant (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 (StgVarArg scrutinee) [{-no args-}] _) - _ _ _ -- ignore live vars and uniq... - (StgAlgAlts case_ty - [(con, params, use_mask, - (StgApp (StgVarArg selectee) [{-no args-}] _))] - StgNoDefault)) - | the_fv == scrutinee -- Scrutinee is the only free variable - && maybeToBool maybe_offset -- Selectee is a component of the tuple - && maybeToBool offset_into_int_maybe - && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough - = - -- ASSERT(is_single_constructor) -- Should be true, by causes error for SpecTyCon - LFThunk False False True (SelectorThunk scrutinee con offset_into_int) +mkClosureLFInfo bndr top fvs upd_flag [] +#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 getIdPrimRep 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 (StgVarArg fun_id) args _) - | not top_level -- A top-level thunk would require a static - -- vap_info table, which we don't generate just - -- now; so top-level thunks are never standard - -- form. - && isLocallyDefined fun_id -- Must be defined in this module - && maybeToBool arity_maybe -- A known function with known arity - && fun_arity > 0 -- It'd better be a function! - && fun_arity == length args -- Saturated application - = LFThunk top_level (null fvs) (isUpdatable upd_flag) (VapThunk fun_id args store_fun_in_vap) - where - arity_maybe = arityMaybe (getIdArity fun_id) - Just fun_arity = arity_maybe - - -- If the function is a free variable then it must be stored - -- in the thunk too; if it isn't a free variable it must be - -- because it's constant, so it doesn't need to be stored in the thunk - store_fun_in_vap = fun_id `is_elem` fvs +mkConLFInfo :: DataCon -> LambdaFormInfo - is_elem = isIn "mkClosureLFInfo" -\end{code} +mkConLFInfo con + = -- the isNullaryDataCon will do this: ASSERT(isDataCon con) + (if isTupleCon con then LFTuple else LFCon) con (isNullaryDataCon con) -Finally, the general updatable-thing case: -\begin{code} -mkClosureLFInfo top fvs upd_flag [] body - = LFThunk top (null fvs) (isUpdatable upd_flag) NonStandardThunk +mkSelectorLFInfo rhs_ty offset updatable + = LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset) -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}} @@ -470,19 +259,12 @@ mkConLFInfo con \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 @@ -497,23 +279,11 @@ closurePtrsSize (MkClosureInfo _ _ sm_rep) 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 @@ -526,8 +296,6 @@ Slop Requirements: 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 @@ -541,56 +309,30 @@ 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} +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} %************************************************************************ @@ -601,8 +343,8 @@ computeSlopSize tot_wds other_rep _ -- Any other rep \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 + :: 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 @@ -616,32 +358,10 @@ layOutDynClosure name kind_fn things lf_info 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 -> PrimRep) @@ -649,10 +369,43 @@ layOutDynCon :: DataCon -> (ClosureInfo, [(a,VirtualHeapOffset)]) layOutDynCon con kind_fn args - = ASSERT(isDataCon con) - layOutDynClosure con kind_fn args (mkConLFInfo con) + = 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} %************************************************************************ %* * @@ -669,38 +422,26 @@ chooseDynSMRep 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} @@ -712,14 +453,15 @@ 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 +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 + -- 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. @@ -730,10 +472,9 @@ mkVirtHeapOffsets sm_rep kind_fun things in (tot_wds, wds_of_ptrs, ptrs_w_offsets ++ non_ptrs_w_offsets) where - offset_of_first_word = totHdrSize sm_rep computeOffset wds_so_far thing = (wds_so_far + (getPrimRepSize . kind_fun) thing, - (thing, (offset_of_first_word `addOff` (intOff wds_so_far))) + (thing, fixedHdrSize + wds_so_far) ) \end{code} @@ -748,13 +489,12 @@ Be sure to see the stg-details notes about these... \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 @@ -778,8 +518,8 @@ nodeMustPointToIt lf_info -- 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): -- @@ -788,12 +528,16 @@ 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. + 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, @@ -829,53 +573,64 @@ data EntryConvention = 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 +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 _ -> + LFReEntrant _ _ arity _ -> if arity == 0 || (length arg_kinds) < arity then - StdEntry (mkStdEntryLabel id) Nothing + StdEntry (mkStdEntryLabel name) else - DirectEntry (mkFastEntryLabel id arity) arity arg_regs + 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 + 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 - -> StdEntry (mkStdEntryLabel tup) - (Just (mkInfoTableLabel tup)) - -- Should have no args + -> --false:ASSERT (null arg_kinds) + -- Should have no args (meaning what?) + StdEntry (mkConEntryLabel (dataConName tup)) - LFThunk _ _ updatable std_form_info + 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 @@ -883,53 +638,57 @@ getEntryConvention id lf_info arg_kinds -- 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 -getStandardFormThunkInfo - :: LambdaFormInfo - -> Maybe [StgArg] -- Nothing => not a standard-form thunk - -- Just atoms => a standard-form thunk with payload atoms +isStandardFormThunk :: LambdaFormInfo -> Bool -getStandardFormThunkInfo (LFThunk _ _ _ (SelectorThunk scrutinee _ _)) - = --trace "Selector thunk: missed opportunity to save info table + code" - Nothing - -- Just [StgVarArg scrutinee] - -- We can't save the info tbl + code until we have a way to generate - -- a fixed family thereof. +isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _)) = True +isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _)) = True +isStandardFormThunk other_lf_info = False -getStandardFormThunkInfo (LFThunk _ _ _ (VapThunk fun_id args fun_in_payload)) - | fun_in_payload = Just (StgVarArg fun_id : args) - | otherwise = Just args +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 @@ -993,71 +752,50 @@ 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 + (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} %************************************************************************ @@ -1067,27 +805,12 @@ noUpdVapRequired binder_info %************************************************************************ \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 @@ -1097,7 +820,7 @@ closureLFInfo (MkClosureInfo _ lf_info _) = lf_info 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. @@ -1105,65 +828,48 @@ closureUpdReqd other_closure = False 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, [Type], [Id]) +closureSemiTag :: ClosureInfo -> Maybe Int --- 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 (idType fun_id) - -closureType (MkClosureInfo id lf _) = getUniDataSpecTyCon_maybe (idType 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 +isToplevClosure :: ClosureInfo -> Bool -closureReturnsUnboxedType (MkClosureInfo fun_id (LFReEntrant _ arity _) _) - = isPrimType (funResultTy de_foralld_ty arity) - where - (_, de_foralld_ty) = splitForalls (idType fun_id) - -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 - _ -> 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 @@ -1171,68 +877,56 @@ infoTableLabelFromCI (MkClosureInfo id lf_info 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 (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} @@ -1240,34 +934,20 @@ 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 + 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} -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. +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} - -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} %************************************************************************ @@ -1276,35 +956,22 @@ dataConLiveness _ _ = mkLiveRegsBitMask [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 - _UNPK_ (getOccurrenceName (getDataConTyCon id)) -- We want the TyCon not the -> - else - getUniTyDescription (idType id) +closureTypeDescr (MkClosureInfo name (LFThunk ty _ _ _ _) _) + = getTyDescription ty +closureTypeDescr (MkClosureInfo name (LFReEntrant ty _ _ _) _) + = getTyDescription ty +closureTypeDescr (MkClosureInfo name lf _) + = showSDoc (ppr name) \end{code}