X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FClosureInfo.lhs;h=84d9dd95efcf7a94d0e137080e0ff6897b779ef7;hb=beb5737b7ee42c4e9373a505e7d957206d69a30e;hp=2de88025d4161fdd26d74eb77495c285637804db;hpb=98744cef7b82e7eefbb1c6f1d8b9e28c415939c4;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 2de8802..84d9dd9 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,9 +1,11 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 +% (c) The Univserity of Glasgow 1992-2004 % -% $Id: ClosureInfo.lhs,v 1.61 2003/11/17 14:23:31 simonmar Exp $ -% -\section[ClosureInfo]{Data structures which describe closures} + + 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. @@ -11,86 +13,74 @@ the STG paper. \begin{code} module ClosureInfo ( ClosureInfo, LambdaFormInfo, SMRep, -- all abstract - StandardFormInfo, ArgDescr(..), + StandardFormInfo, - CallingConvention(..), + ArgDescr(..), Liveness(..), + C_SRT(..), needsSRT, - mkClosureLFInfo, mkConLFInfo, mkSelectorLFInfo, + mkLFThunk, mkLFReEntrant, mkConLFInfo, mkSelectorLFInfo, mkApLFInfo, mkLFImported, mkLFArgument, mkLFLetNoEscape, + mkClosureInfo, mkConInfo, + closureSize, closureNonHdrSize, closureGoodStuffSize, closurePtrsSize, - slopSize, + slopSize, - layOutDynClosure, layOutStaticClosure, layOutStaticNoFVClosure, - layOutDynConstr, layOutStaticConstr, - mkVirtHeapOffsets, mkStaticClosure, + closureName, infoTableLabelFromCI, + closureLabelFromCI, closureSRT, + closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd, + closureNeedsUpdSpace, closureIsThunk, + closureSingleEntry, closureReEntrant, isConstrClosure_maybe, + closureFunInfo, isStandardFormThunk, isKnownFun, + + enterIdLabel, enterLocalIdLabel, enterReturnPtLabel, - nodeMustPointToIt, getEntryConvention, - FCode, CgInfoDownwards, CgState, + nodeMustPointToIt, + CallMethod(..), getCallMethod, blackHoleOnEntry, staticClosureRequired, - - closureName, infoTableLabelFromCI, - closureLabelFromCI, closureSRT, - entryLabelFromCI, - closureLFInfo, closureSMRep, closureUpdReqd, - closureSingleEntry, closureReEntrant, closureSemiTag, - closureFunInfo, isStandardFormThunk, + getClosureType, isToplevClosure, - closureTypeDescr, -- profiling + closureValDescr, closureTypeDescr, -- profiling isStaticClosure, - allocProfilingMsg, cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo, staticClosureNeedsLink, - - mkInfoTable, mkRetInfoTable, mkVecInfoTable, ) where -#include "../includes/config.h" #include "../includes/MachDeps.h" #include "HsVersions.h" -import AbsCSyn import StgSyn -import CgMonad +import SMRep -- all of it -import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject ) -import CgRetConv ( assignRegs ) import CLabel -import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, - opt_Parallel, opt_DoTickyProfiling, - opt_SMP, opt_Unregisterised ) -import Id ( Id, idType, idArity, idName, idPrimRep ) -import DataCon ( DataCon, dataConTag, fIRST_TAG, dataConTyCon, - isNullaryDataCon, dataConName - ) -import Name ( Name, nameUnique, getOccName, getName, getOccString ) -import OccName ( occNameUserString ) -import PrimRep -import SMRep -- all of it + +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 ) +import TyCon ( isFunTyCon, isAbstractTyCon ) import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel, ipNameName ) -import Util ( mapAccumL, listLengthCmp, lengthIs ) import FastString import Outputable -import Literal import Constants -import Bitmap - -import Maybe ( isJust ) -import DATA_BITS import TypeRep -- TEMP \end{code} + %************************************************************************ %* * \subsection[ClosureInfo-datatypes]{Data types for closure information} @@ -121,12 +111,23 @@ data ClosureInfo closureDescr :: !String -- closure description (for profiling) } - -- constructor closures don't have a unique info table label (they use + -- 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 + 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} %************************************************************************ @@ -147,11 +148,11 @@ ClosureInfo contains a LambdaFormInfo. data LambdaFormInfo = LFReEntrant -- Reentrant closure (a function) TopLevelFlag -- True if top level - !Int -- Arity + !Int -- Arity. Invariant: always > 0 !Bool -- True <=> no fvs ArgDescr -- Argument descriptor (should reall be in ClosureInfo) - | LFCon -- Constructor + | LFCon -- A saturated constructor application DataCon -- The constructor | LFThunk -- Thunk (zero arity) @@ -179,36 +180,58 @@ data LambdaFormInfo CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info). -data StandardFormInfo -- Tells whether this thunk has one of a small number - -- of standard forms +------------------------- +-- An ArgDsecr describes the argument pattern of a function - = NonStandardThunk -- No, it isn't +data ArgDescr + = ArgSpec -- Fits one of the standard patterns + !Int -- RTS type identifier ARG_P, ARG_N, ... - | 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.) + | ArgGen -- General case + Liveness -- Details about the arguments -{- A SelectorThunk is of form - case x of - con a1,..,an -> ak +------------------------- +-- 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. - and the constructor is from a single-constr type. --} +data Liveness + = SmallLiveness -- Liveness info that fits in one word + StgWord -- Here's the bitmap + + | BigLiveness -- Liveness info witha a multi-word bitmap + CLabel -- Label for the bitmap - | ApThunk - Int -- arity -{- An ApThunk is of form +------------------------- +-- StandardFormInfo tells whether this thunk has one of +-- a small number of standard forms - x1 ... xn +data StandardFormInfo + = NonStandardThunk + -- Not of of the standard forms - 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. --} + | 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.) + | 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} %************************************************************************ @@ -217,31 +240,29 @@ data StandardFormInfo -- Tells whether this thunk has one of a small number %* * %************************************************************************ -@mkClosureLFInfo@ figures out the appropriate LFInfo for the closure. - \begin{code} -mkClosureLFInfo :: Id -- The binder - -> TopLevelFlag -- True of top level - -> [Id] -- Free vars - -> UpdateFlag -- Update flag - -> [Id] -- Args - -> LambdaFormInfo - -mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args - = LFReEntrant top (length args) (null fvs) (mkArgDescr (getName bndr) args) - -mkClosureLFInfo bndr top fvs upd_flag [] - = ASSERT( not updatable || not (isUnLiftedType id_ty) ) - LFThunk top (null fvs) updatable NonStandardThunk - (might_be_a_function id_ty) - where - updatable = isUpdatable upd_flag - id_ty = idType bndr +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) = False + not (isFunTyCon tc) && not (isAbstractTyCon tc) = False + -- don't forget to check for abstract types, which might + -- be functions too. | otherwise = True \end{code} @@ -274,50 +295,89 @@ mkLFImported id 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 = fixedHdrSize + 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 -closureNonHdrSize :: ClosureInfo -> Int -closureNonHdrSize cl_info - = tot_wds + computeSlopSize tot_wds - (closureSMRep cl_info) - (closureNeedsUpdSpace cl_info) +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 - tot_wds = closureGoodStuffSize cl_info + sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds +\end{code} --- 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 +%************************************************************************ +%* * +\subsection[ClosureInfo-sizes]{Functions about closure {\em sizes}} +%* * +%************************************************************************ -slopSize :: ClosureInfo -> Int -slopSize cl_info - = computeSlopSize (closureGoodStuffSize cl_info) - (closureSMRep cl_info) - (closureNeedsUpdSpace cl_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 :: ClosureInfo -> WordOff closureGoodStuffSize cl_info = let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info) in ptrs + nonptrs -closurePtrsSize :: ClosureInfo -> Int +closurePtrsSize :: ClosureInfo -> WordOff closurePtrsSize cl_info = let (ptrs, _) = sizes_from_SMRep (closureSMRep cl_info) in ptrs -- not exported: -sizes_from_SMRep :: SMRep -> (Int,Int) +sizes_from_SMRep :: SMRep -> (WordOff,WordOff) sizes_from_SMRep (GenericRep _ ptrs nonptrs _) = (ptrs, nonptrs) sizes_from_SMRep BlackHoleRep = (0, 0) \end{code} @@ -326,167 +386,42 @@ 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 - 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@ -\end{itemize} - -Static closures have an extra ``static link field'' at the end, but we -don't bother taking that into account here. +Slop Requirements: every thunk gets an extra padding word in the +header, which takes the the updated value. \begin{code} -computeSlopSize :: Int -> SMRep -> Bool -> Int - -computeSlopSize tot_wds (GenericRep _ _ _ _) True -- Updatable - = max 0 (mIN_UPD_SIZE - tot_wds) - -computeSlopSize tot_wds (GenericRep True _ _ _) False -- Non updatable - = 0 -- Static - -computeSlopSize tot_wds (GenericRep False _ _ _) False -- Non updatable - = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds) -- Dynamic - -computeSlopSize tot_wds BlackHoleRep _ -- Updatable - = max 0 (mIN_UPD_SIZE - tot_wds) -\end{code} - -%************************************************************************ -%* * -\subsection[layOutDynClosure]{Lay out a closure} -%* * -%************************************************************************ +slopSize cl_info = computeSlopSize payload_size cl_info + where payload_size = closureGoodStuffSize cl_info -\begin{code} -layOutDynClosure, layOutStaticClosure - :: Id -- STG identifier of this closure - -> (a -> PrimRep) -- how to get a PrimRep for the fields - -> [a] -- the "things" being layed out - -> LambdaFormInfo -- what sort of closure it is - -> C_SRT -- its SRT - -> String -- closure description - -> (ClosureInfo, -- info about the closure - [(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them - -layOutDynClosure = layOutClosure False -layOutStaticClosure = layOutClosure True - -layOutStaticNoFVClosure id lf_info srt_info descr - = fst (layOutClosure True id (panic "kind_fn") [] lf_info srt_info descr) - -layOutClosure - :: Bool -- True <=> static closure - -> Id -- STG identifier of this closure - -> (a -> PrimRep) -- how to get a PrimRep for the fields - -> [a] -- the "things" being layed out - -> LambdaFormInfo -- what sort of closure it is - -> C_SRT -- its SRT - -> String -- closure description - -> (ClosureInfo, -- info about the closure - [(a, VirtualHeapOffset)]) -- things w/ offsets pinned on them - -layOutClosure is_static id kind_fn things lf_info srt_info descr - = (ClosureInfo { closureName = name, - closureLFInfo = lf_info, - closureSMRep = sm_rep, - closureSRT = srt_info, - closureType = idType id, - closureDescr = descr }, - things_w_offsets) +computeSlopSize :: WordOff -> ClosureInfo -> WordOff +computeSlopSize payload_size cl_info + = max 0 (minPayloadSize smrep updatable - payload_size) where - name = idName id - (tot_wds, -- #ptr_wds + #nonptr_wds - ptr_wds, -- #ptr_wds - things_w_offsets) = mkVirtHeapOffsets kind_fn things - sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds - + smrep = closureSMRep cl_info + updatable = closureNeedsUpdSpace cl_info -layOutDynConstr, layOutStaticConstr - :: DataCon - -> (a -> PrimRep) - -> [a] - -> (ClosureInfo, - [(a,VirtualHeapOffset)]) - -layOutDynConstr = layOutConstr False -layOutStaticConstr = layOutConstr True +-- 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 -layOutConstr is_static data_con kind_fn args - = (ConInfo { closureSMRep = sm_rep, - closureCon = data_con }, - things_w_offsets) +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 kind_fn args - sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds -\end{code} - -%************************************************************************ -%* * -\subsection[mkStaticClosure]{Make a static closure} -%* * -%************************************************************************ - -Make a static closure, adding on any extra padding needed for CAFs, -and adding a static link field if necessary. - -\begin{code} -mkStaticClosure lbl cl_info ccs fields cafrefs - | opt_SccProfilingOn = - CStaticClosure - lbl - cl_info - (mkCCostCentreStack ccs) - all_fields - | otherwise = - CStaticClosure - lbl - cl_info - (panic "absent cc") - all_fields - - where - all_fields = fields ++ padding_wds ++ static_link_field - - upd_reqd = closureUpdReqd cl_info - - -- for the purposes of laying out the static closure, we consider all - -- thunks to be "updatable", so that the static link field is always - -- in the same place. - padding_wds - | not upd_reqd = [] - | otherwise = replicate n (mkIntCLit 0) -- a bunch of 0s - where n = max 0 (mIN_UPD_SIZE - length fields) - - -- We always have a static link field for a thunk, it's used to - -- save the closure's info pointer when we're reverting CAFs - -- (see comment in Storage.c) - static_link_field - | upd_reqd || staticClosureNeedsLink cl_info = [static_link_value] - | otherwise = [] - - -- for a static constructor which has NoCafRefs, we set the - -- static link field to a non-zero value so the garbage - -- collector will ignore it. - static_link_value - | cafrefs = mkIntCLit 0 - | otherwise = mkIntCLit 1 + 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} %************************************************************************ @@ -499,23 +434,23 @@ mkStaticClosure lbl cl_info ccs fields cafrefs chooseSMRep :: Bool -- True <=> static closure -> LambdaFormInfo - -> Int -> Int -- Tot wds, ptr wds + -> WordOff -> WordOff -- Tot wds, ptr wds -> SMRep chooseSMRep is_static lf_info tot_wds ptr_wds = let nonptr_wds = tot_wds - ptr_wds - closure_type = getClosureType is_static tot_wds ptr_wds lf_info + closure_type = getClosureType is_static ptr_wds lf_info in GenericRep is_static ptr_wds nonptr_wds closure_type --- we *do* get non-updatable top-level thunks sometimes. eg. f = g +-- 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. -getClosureType :: Bool -> Int -> Int -> LambdaFormInfo -> ClosureType -getClosureType is_static tot_wds ptr_wds lf_info +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 @@ -527,42 +462,6 @@ getClosureType is_static tot_wds ptr_wds lf_info %************************************************************************ %* * -\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 :: - (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 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 - computeOffset wds_so_far thing - = (wds_so_far + (getPrimRepSize . kind_fun) thing, - (thing, fixedHdrSize + wds_so_far) - ) -\end{code} - -%************************************************************************ -%* * \subsection[ClosureInfo-4-questions]{Four major questions about @ClosureInfo@} %* * %************************************************************************ @@ -570,13 +469,10 @@ mkVirtHeapOffsets kind_fun things Be sure to see the stg-details notes about these... \begin{code} -nodeMustPointToIt :: LambdaFormInfo -> FCode Bool -nodeMustPointToIt lf_info - - = case lf_info of - LFReEntrant top _ no_fvs _ -> returnFC ( - not no_fvs || -- Certainly if it has fvs we need to point to it - isNotTopLevel top +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 @@ -585,9 +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 _ -> 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 @@ -600,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 || opt_SccProfilingOn) - +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 @@ -610,15 +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. - - LFUnknown _ -> returnFC True - LFBlackHole _ -> returnFC True - -- BH entry may require Node to point +nodeMustPointToIt (LFThunk _ no_fvs updatable some_standard_form_thunk _) + = True -- Node must point to any standard-form thunk - LFLetNoEscape _ -> returnFC False +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, @@ -650,7 +541,7 @@ When black-holing, single-entry closures could also be entered via node (rather than directly) to catch double-entry. \begin{code} -data CallingConvention +data CallMethod = EnterIt -- no args, not a function | JumpToIt CLabel -- no args, not a function, but we @@ -660,96 +551,75 @@ data CallingConvention -- zero args to apply to it, so just -- return it. + | ReturnCon DataCon -- It's a data constructor, just return it + | SlowCall -- Unknown fun, or known fun with -- too few args. | DirectEntry -- Jump directly, with args in regs CLabel -- The code label Int -- Its arity - [MagicId] -- Its register assignments - -- (possibly empty) - -getEntryConvention :: Name -- Function being applied - -> LambdaFormInfo -- Its info - -> [PrimRep] -- Available arguments - -> FCode CallingConvention - -getEntryConvention name lf_info arg_kinds - = nodeMustPointToIt lf_info `thenFC` \ node_points -> - returnFC ( - - -- if we're parallel, then we must always enter via node. The reason - -- is that the closure may have been fetched since we allocated it. - - if (node_points && opt_Parallel) then EnterIt else - - -- Commented out by SDM after futher thoughts: - -- - the only closure type that can be blackholed is a thunk - -- - we already enter thunks via node (unless the closure is - -- non-updatable, in which case why is it being re-entered...) - - case lf_info of - - LFReEntrant _ arity _ _ -> - if null arg_kinds then - if arity == 0 then - EnterIt -- a non-updatable thunk - else - ReturnIt -- no args at all - else if listLengthCmp arg_kinds arity == LT then - SlowCall -- not enough args - else - DirectEntry (mkEntryLabel name) arity arg_regs - where - (arg_regs, _) = assignRegs [node] (take arity arg_kinds) - -- we don't use node to pass args now (SDM) - - LFCon con - | isNullaryDataCon con - -- a real constructor. Don't bother entering it, just jump - -- to the constructor entry code directly. - -> --false:ASSERT (null arg_kinds) - -- Should have no args (meaning what?) - JumpToIt (mkStaticConEntryLabel (dataConName con)) - - | otherwise {- not nullary -} - -> --false:ASSERT (null arg_kinds) - -- Should have no args (meaning what?) - JumpToIt (mkConEntryLabel (dataConName con)) - - LFThunk _ _ updatable std_form_info is_fun - -- must always "call" a function-typed thing, cannot just enter it - | is_fun -> SlowCall - | updatable || opt_DoTickyProfiling -- to catch double entry - || opt_SMP -- always enter via node on SMP, since the - -- thunk might have been blackholed in the - -- meantime. - -> ASSERT(null arg_kinds) EnterIt - | otherwise - -> ASSERT(null arg_kinds) - JumpToIt (thunkEntryLabel name std_form_info updatable) - - LFUnknown True -> SlowCall -- might be a function - LFUnknown False -> ASSERT2 (null arg_kinds, ppr name <+> ppr arg_kinds) EnterIt -- not a function - - LFBlackHole _ -> SlowCall -- Presumably the black hole has by now - -- been updated, but we don't know with - -- what, so we slow call it - - LFLetNoEscape 0 - -> JumpToIt (mkReturnPtLabel (nameUnique name)) - - LFLetNoEscape arity - -> if (not (arg_kinds `lengthIs` arity)) then pprPanic "let-no-escape: " (ppr name <+> ppr arity) else - DirectEntry (mkReturnPtLabel (nameUnique name)) arity arg_regs - where - (arg_regs, _) = assignRegs [] arg_kinds - -- node never points to a LetNoEscape, see above --SDM - --live_regs = if node_points then [node] else [] - ) -blackHoleOnEntry :: ClosureInfo -> Bool +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; @@ -775,11 +645,14 @@ blackHoleOnEntry (ClosureInfo { closureLFInfo = lf_info, closureSMRep = rep }) other -> panic "blackHoleOnEntry" -- Should never happen isStandardFormThunk :: LambdaFormInfo -> Bool - isStandardFormThunk (LFThunk _ _ _ (SelectorThunk _) _) = True isStandardFormThunk (LFThunk _ _ _ (ApThunk _) _) = True isStandardFormThunk other_lf_info = False +isKnownFun :: LambdaFormInfo -> Bool +isKnownFun (LFReEntrant _ _ _ _) = True +isKnownFun (LFLetNoEscape _) = True +isKnownFun _ = False \end{code} ----------------------------------------------------------------------------- @@ -796,7 +669,7 @@ staticClosureNeedsLink :: ClosureInfo -> Bool staticClosureNeedsLink (ClosureInfo { closureSRT = srt }) = needsSRT srt staticClosureNeedsLink (ConInfo { closureSMRep = sm_rep, closureCon = con }) - = not (isNullaryDataCon con) && not_nocaf_constr + = not (isNullaryRepDataCon con) && not_nocaf_constr where not_nocaf_constr = case sm_rep of @@ -892,11 +765,19 @@ isStaticClosure :: ClosureInfo -> Bool isStaticClosure cl_info = isStaticRep (closureSMRep cl_info) closureUpdReqd :: ClosureInfo -> Bool -closureUpdReqd (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _ }) = upd -closureUpdReqd (ClosureInfo { closureLFInfo = LFBlackHole _ }) = True +closureUpdReqd ClosureInfo{ closureLFInfo = lf_info } = lfUpdatable lf_info +closureUpdReqd ConInfo{} = False + +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 + +closureIsThunk :: ClosureInfo -> Bool +closureIsThunk ClosureInfo{ closureLFInfo = lf_info } = isLFThunk lf_info +closureIsThunk ConInfo{} = False closureSingleEntry :: ClosureInfo -> Bool closureSingleEntry (ClosureInfo { closureLFInfo = LFThunk _ _ upd _ _}) = not upd @@ -906,10 +787,9 @@ closureReEntrant :: ClosureInfo -> Bool closureReEntrant (ClosureInfo { closureLFInfo = LFReEntrant _ _ _ _ }) = True closureReEntrant other_closure = False -closureSemiTag :: ClosureInfo -> Maybe Int -closureSemiTag (ConInfo { closureCon = data_con }) - = Just (dataConTag data_con - fIRST_TAG) -closureSemiTag _ = Nothing +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}) @@ -944,67 +824,55 @@ infoTableLabelFromCI (ClosureInfo { closureName = name, LFThunk _ _ upd_flag (ApThunk arity) _ -> mkApInfoTableLabel upd_flag arity - LFThunk{} -> mkInfoTableLabel name + LFThunk{} -> mkLocalInfoTableLabel name - LFReEntrant _ _ _ (ArgGen _ _) -> mkInfoTableLabel name - LFReEntrant _ _ _ _ -> mkInfoTableLabel name + LFReEntrant _ _ _ _ -> mkLocalInfoTableLabel name other -> panic "infoTableLabelFromCI" -infoTableLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep }) - = mkConInfoPtr con rep - - -mkConInfoPtr :: DataCon -> SMRep -> CLabel -mkConInfoPtr con rep - | isStaticRep rep = mkStaticInfoTableLabel name - | otherwise = mkConInfoTableLabel name +infoTableLabelFromCI (ConInfo { closureCon = con, + closureSMRep = rep, + closureDllCon = dll }) + | isStaticRep rep = mkStaticInfoTableLabel name dll + | otherwise = mkConInfoTableLabel name dll where name = dataConName con -mkConEntryPtr :: DataCon -> SMRep -> CLabel -mkConEntryPtr con rep - | isStaticRep rep = mkStaticConEntryLabel (dataConName con) - | otherwise = mkConEntryLabel (dataConName con) - -closureLabelFromCI (ClosureInfo { closureName = nm }) = mkClosureLabel nm +-- ClosureInfo for a closure (as opposed to a constructor) is always local +closureLabelFromCI (ClosureInfo { closureName = nm }) = mkLocalClosureLabel nm closureLabelFromCI _ = panic "closureLabelFromCI" -entryLabelFromCI :: ClosureInfo -> CLabel -entryLabelFromCI (ClosureInfo { closureName = id, - closureLFInfo = lf_info, - closureSMRep = rep }) - = case lf_info of - LFThunk _ _ upd_flag std_form_info _ -> - thunkEntryLabel id std_form_info upd_flag - other -> mkEntryLabel id - -entryLabelFromCI (ConInfo { closureCon = con, closureSMRep = rep }) - = mkConEntryPtr con rep - - -- thunkEntryLabel is a local help function, not exported. It's used from both --- entryLabelFromCI and getEntryConvention. - -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 - = mkEntryLabel 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 -> FastString -allocProfilingMsg ConInfo{} = FSLIT("TICK_ALLOC_CON") -allocProfilingMsg ClosureInfo{ closureLFInfo = lf_info } - = case lf_info of - LFReEntrant _ _ _ _ -> FSLIT("TICK_ALLOC_FUN") - LFThunk _ _ True _ _ -> FSLIT("TICK_ALLOC_UP_THK") -- updatable - LFThunk _ _ False _ _ -> FSLIT("TICK_ALLOC_SE_THK") -- nonupdatable - LFBlackHole _ -> FSLIT("TICK_ALLOC_BH") - _ -> panic "allocProfilingMsg" -\end{code} We need a black-hole closure info to pass to @allocDynClosure@ when we want to allocate the black hole on entry to a CAF. These are the only @@ -1049,11 +917,16 @@ The type is determined from the type information stored with the @Id@ in the closure info using @closureTypeDescr@. \begin{code} -closureTypeDescr :: ClosureInfo -> String +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 }) - = occNameUserString (getOccName (dataConTyCon data_con)) + = occNameString (getOccName (dataConTyCon data_con)) getTyDescription :: Type -> String getTyDescription ty @@ -1062,10 +935,8 @@ getTyDescription ty TyVarTy _ -> "*" AppTy fun _ -> getTyDescription fun FunTy _ res -> '-' : '>' : fun_result res - NewTcApp tycon _ -> getOccString tycon TyConApp tycon _ -> getOccString tycon NoteTy (FTVNote _) ty -> getTyDescription ty - NoteTy (SynNote ty1) _ -> getTyDescription ty1 PredTy sty -> getPredTyDescription sty ForAllTy _ ty -> getTyDescription ty } @@ -1077,268 +948,4 @@ getPredTyDescription (ClassP cl tys) = getOccString cl getPredTyDescription (IParam ip ty) = getOccString (ipNameName ip) \end{code} -%************************************************************************ -%* * -\subsection{Making argument bitmaps} -%* * -%************************************************************************ - -\begin{code} --- bring in ARG_P, ARG_N, etc. -#include "../includes/StgFun.h" - -data ArgDescr - = ArgSpec - !Int -- ARG_P, ARG_N, ... - | ArgGen - CLabel -- label for a slow-entry point - Liveness -- the arg bitmap: describes pointedness of arguments - -mkArgDescr :: Name -> [Id] -> ArgDescr -mkArgDescr nm args = argDescr nm (filter nonVoidRep (map idPrimRep args)) - where nonVoidRep VoidRep = False - nonVoidRep _ = True - -argDescr nm [PtrRep] = ArgSpec ARG_P -argDescr nm [FloatRep] = ArgSpec ARG_F -argDescr nm [DoubleRep] = ArgSpec ARG_D -argDescr nm [r] | is64BitRep r = ArgSpec ARG_L -argDescr nm [r] | isNonPtrRep r = ArgSpec ARG_N - -argDescr nm [r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NN -argDescr nm [r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NP -argDescr nm [PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PN -argDescr nm [PtrRep,PtrRep] = ArgSpec ARG_PP - -argDescr nm [r1,r2,r3] | isNonPtrRep r1 && isNonPtrRep r2 && isNonPtrRep r3 = ArgSpec ARG_NNN -argDescr nm [r1,r2,PtrRep] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NNP -argDescr nm [r1,PtrRep,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_NPN -argDescr nm [r1,PtrRep,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_NPP -argDescr nm [PtrRep,r1,r2] | isNonPtrRep r1 && isNonPtrRep r2 = ArgSpec ARG_PNN -argDescr nm [PtrRep,r1,PtrRep] | isNonPtrRep r1 = ArgSpec ARG_PNP -argDescr nm [PtrRep,PtrRep,r1] | isNonPtrRep r1 = ArgSpec ARG_PPN -argDescr nm [PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPP - -argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPP -argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPP -argDescr nm [PtrRep,PtrRep,PtrRep,PtrRep,PtrRep,PtrRep] = ArgSpec ARG_PPPPPP - -argDescr name reps = ArgGen (mkSlowEntryLabel name) liveness - where bitmap = argBits reps - lbl = mkBitmapLabel name - liveness = Liveness lbl (length bitmap) (mkBitmap bitmap) - -argBits [] = [] -argBits (rep : args) - | isFollowableRep rep = False : argBits args - | otherwise = take (getPrimRepSize rep) (repeat True) ++ argBits args -\end{code} - -%************************************************************************ -%* * -\subsection{Generating info tables} -%* * -%************************************************************************ - -Here we make a concrete info table, represented as a list of CAddrMode -(it can't be simply a list of Word, because the SRT field is -represented by a label+offset expression). - -\begin{code} -mkInfoTable :: ClosureInfo -> [CAddrMode] -mkInfoTable cl_info - | tablesNextToCode = extra_bits ++ std_info - | otherwise = std_info ++ extra_bits - where - std_info = mkStdInfoTable entry_amode - ty_descr_amode cl_descr_amode cl_type srt_len layout_amode - - entry_amode = CLbl (entryLabelFromCI cl_info) CodePtrRep - - closure_descr = - case cl_info of - ClosureInfo { closureDescr = descr } -> descr - ConInfo { closureCon = con } -> occNameUserString (getOccName con) - - ty_descr_amode = CLit (MachStr (mkFastString (closureTypeDescr cl_info))) - cl_descr_amode = CLit (MachStr (mkFastString closure_descr)) - - cl_type = getSMRepClosureTypeInt (closureSMRep cl_info) - - srt = closureSRT cl_info - needs_srt = needsSRT srt - - semi_tag = closureSemiTag cl_info - is_con = isJust semi_tag - - (srt_label,srt_len) - | Just tag <- semi_tag = (mkIntCLit 0, fromIntegral tag) -- constructor - | otherwise = - case srt of - NoC_SRT -> (mkIntCLit 0, 0) - C_SRT lbl off bitmap -> - (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep), - bitmap) - - ptrs = closurePtrsSize cl_info - nptrs = size - ptrs - size = closureNonHdrSize cl_info - - layout_info :: StgWord -#ifdef WORDS_BIGENDIAN - layout_info = (fromIntegral ptrs `shiftL` hALF_WORD) .|. fromIntegral nptrs -#else - layout_info = (fromIntegral ptrs) .|. (fromIntegral nptrs `shiftL` hALF_WORD) -#endif - - layout_amode = mkWordCLit layout_info - - extra_bits - | is_fun = fun_extra_bits - | is_con = [] - | needs_srt = [srt_label] - | otherwise = [] - - maybe_fun_stuff = closureFunInfo cl_info - is_fun = isJust maybe_fun_stuff - (Just (arity, arg_descr)) = maybe_fun_stuff - - fun_extra_bits - | tablesNextToCode = reg_fun_extra_bits - | otherwise = reverse reg_fun_extra_bits - - reg_fun_extra_bits - | ArgGen slow_lbl liveness <- arg_descr - = [ - CLbl slow_lbl CodePtrRep, - livenessToAddrMode liveness, - srt_label, - fun_amode - ] - | needs_srt = [srt_label, fun_amode] - | otherwise = [fun_amode] - -#ifdef WORDS_BIGENDIAN - fun_desc = (fromIntegral fun_type `shiftL` hALF_WORD) .|. fromIntegral arity -#else - fun_desc = (fromIntegral fun_type) .|. (fromIntegral arity `shiftL` hALF_WORD) -#endif - - fun_amode = mkWordCLit fun_desc - - fun_type = case arg_descr of - ArgSpec n -> n - ArgGen _ (Liveness _ size _) - | size <= mAX_SMALL_BITMAP_SIZE -> ARG_GEN - | otherwise -> ARG_GEN_BIG - --- Return info tables come in two flavours: direct returns and --- vectored returns. - -mkRetInfoTable :: CLabel -> C_SRT -> Liveness -> [CAddrMode] -mkRetInfoTable entry_lbl srt liveness - = mkBitmapInfoTable (CLbl entry_lbl CodePtrRep) srt liveness [] - -mkVecInfoTable :: [CAddrMode] -> C_SRT -> Liveness -> [CAddrMode] -mkVecInfoTable vector srt liveness - = mkBitmapInfoTable zero_amode srt liveness vector - -mkBitmapInfoTable - :: CAddrMode - -> C_SRT -> Liveness - -> [CAddrMode] - -> [CAddrMode] -mkBitmapInfoTable entry_amode srt liveness vector - | tablesNextToCode = extra_bits ++ std_info - | otherwise = std_info ++ extra_bits - where - std_info = mkStdInfoTable entry_amode zero_amode zero_amode - cl_type srt_len liveness_amode - - liveness_amode = livenessToAddrMode liveness - - (srt_label,srt_len) = - case srt of - NoC_SRT -> (mkIntCLit 0, 0) - C_SRT lbl off bitmap -> - (CAddr (CIndex (CLbl lbl DataPtrRep) (mkIntCLit off) WordRep), - bitmap) - - cl_type = case (null vector, isBigLiveness liveness) of - (True, True) -> rET_BIG - (True, False) -> rET_SMALL - (False, True) -> rET_VEC_BIG - (False, False) -> rET_VEC_SMALL - - srt_bit | needsSRT srt || not (null vector) = [srt_label] - | otherwise = [] - - extra_bits | tablesNextToCode = reverse vector ++ srt_bit - | otherwise = srt_bit ++ vector - --- The standard bits of an info table. This part of the info table --- corresponds to the StgInfoTable type defined in InfoTables.h. - -mkStdInfoTable - :: CAddrMode -- entry label - -> CAddrMode -- closure type descr (profiling) - -> CAddrMode -- closure descr (profiling) - -> Int -- closure type - -> StgHalfWord -- SRT length - -> CAddrMode -- layout field - -> [CAddrMode] -mkStdInfoTable entry_lbl type_descr closure_descr cl_type srt_len layout_amode - = std_info - where - std_info - | tablesNextToCode = std_info' - | otherwise = entry_lbl : std_info' - - std_info' = - -- par info - prof_info ++ - -- ticky info - -- debug info - [layout_amode] ++ - CLit (MachWord (fromIntegral type_info)) : - [] - - prof_info - | opt_SccProfilingOn = [ type_descr, closure_descr ] - | otherwise = [] - - -- sigh: building up the info table is endian-dependent. - -- ToDo: do this using .byte and .word directives. - type_info :: StgWord -#ifdef WORDS_BIGENDIAN - type_info = (fromIntegral cl_type `shiftL` hALF_WORD) .|. - (fromIntegral srt_len) -#else - type_info = (fromIntegral cl_type) .|. - (fromIntegral srt_len `shiftL` hALF_WORD) -#endif - -isBigLiveness (Liveness _ size _) = size > mAX_SMALL_BITMAP_SIZE - -livenessToAddrMode :: Liveness -> CAddrMode -livenessToAddrMode (Liveness lbl size bits) - | size <= mAX_SMALL_BITMAP_SIZE = small - | otherwise = CLbl lbl DataPtrRep - where - small = mkWordCLit (fromIntegral size .|. (small_bits `shiftL` bITMAP_BITS_SHIFT)) - small_bits = case bits of - [] -> 0 - [b] -> fromIntegral b - _ -> panic "livenessToAddrMode" - -zero_amode = mkIntCLit 0 - --- IA64 mangler doesn't place tables next to code -tablesNextToCode :: Bool -#ifdef ia64_TARGET_ARCH -tablesNextToCode = False -#else -tablesNextToCode = not opt_Unregisterised -#endif -\end{code}