closureName, infoTableLabelFromCI,
closureLabelFromCI, closureSRT,
- closureLFInfo, closureSMRep, closureUpdReqd,
+ closureLFInfo, isLFThunk,closureSMRep, closureUpdReqd,
+ closureNeedsUpdSpace, closureIsThunk,
closureSingleEntry, closureReEntrant, isConstrClosure_maybe,
closureFunInfo, isStandardFormThunk, isKnownFun,
- enterIdLabel, enterReturnPtLabel,
+ enterIdLabel, enterLocalIdLabel, enterReturnPtLabel,
nodeMustPointToIt,
CallMethod(..), getCallMethod,
import CLabel
-import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject )
-import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling,
- opt_Parallel, opt_DoTickyProfiling,
- opt_SMP )
+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 ( occNameUserString )
+import OccName ( occNameString )
import Type ( isUnLiftedType, Type, repType, splitTyConApp_maybe )
import TcType ( tcSplitSigmaTy )
import TyCon ( isFunTyCon, isAbstractTyCon )
-- 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...
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}
+
%************************************************************************
%* *
Building ClosureInfos
name = idName id
sm_rep = chooseSMRep is_static lf_info tot_wds ptr_wds
-mkConInfo :: Bool -- Is static
+mkConInfo :: HomeModules
+ -> Bool -- Is static
-> DataCon
-> Int -> Int -- Total and pointer words
-> ClosureInfo
-mkConInfo is_static data_con tot_wds ptr_wds
+mkConInfo hmods is_static data_con tot_wds ptr_wds
= ConInfo { closureSMRep = sm_rep,
- closureCon = data_con }
+ closureCon = data_con,
+ closureDllCon = isDllName hmods (dataConName data_con) }
where
sm_rep = chooseSMRep is_static (mkConLFInfo data_con) tot_wds ptr_wds
\end{code}
\begin{code}
closureSize :: ClosureInfo -> WordOff
-closureSize cl_info = fixedHdrSize + closureNonHdrSize cl_info
+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
- (closureSMRep cl_info)
- (closureNeedsUpdSpace cl_info)
+ = tot_wds + computeSlopSize tot_wds cl_info
where
tot_wds = closureGoodStuffSize cl_info
--- we leave space for an update if either (a) the closure is updatable
--- or (b) it is a static thunk. This is because a static thunk needs
--- a static link field in a predictable place (after the slop), regardless
--- of whether it is updatable or not.
-closureNeedsUpdSpace (ClosureInfo { closureLFInfo =
- LFThunk TopLevel _ _ _ _ }) = True
-closureNeedsUpdSpace cl_info = closureUpdReqd cl_info
-
-slopSize :: ClosureInfo -> WordOff
-slopSize cl_info
- = computeSlopSize (closureGoodStuffSize cl_info)
- (closureSMRep cl_info)
- (closureNeedsUpdSpace cl_info)
-
closureGoodStuffSize :: ClosureInfo -> WordOff
closureGoodStuffSize cl_info
= let (ptrs, nonptrs) = sizes_from_SMRep (closureSMRep cl_info)
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 :: WordOff -> SMRep -> Bool -> WordOff
+slopSize cl_info = computeSlopSize payload_size cl_info
+ where payload_size = closureGoodStuffSize cl_info
-computeSlopSize tot_wds (GenericRep _ _ _ _) True -- Updatable
- = max 0 (mIN_UPD_SIZE - tot_wds)
-
-computeSlopSize tot_wds (GenericRep True _ _ _) False -- Non updatable
- = 0 -- Static
+computeSlopSize :: WordOff -> ClosureInfo -> WordOff
+computeSlopSize payload_size cl_info
+ = max 0 (minPayloadSize smrep updatable - payload_size)
+ where
+ smrep = closureSMRep cl_info
+ updatable = closureNeedsUpdSpace cl_info
-computeSlopSize tot_wds (GenericRep False _ _ _) False -- Non updatable
- = max 0 (mIN_SIZE_NonUpdHeapObject - tot_wds) -- Dynamic
+-- 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
-computeSlopSize tot_wds BlackHoleRep _ -- Updatable
- = max 0 (mIN_UPD_SIZE - tot_wds)
+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
+ 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}
%************************************************************************
CLabel -- The code label
Int -- Its arity
-getCallMethod :: Name -- Function being applied
+getCallMethod :: HomeModules
+ -> Name -- Function being applied
-> LambdaFormInfo -- Its info
-> Int -- Number of available arguments
-> CallMethod
-getCallMethod name lf_info n_args
+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 name (LFReEntrant _ arity _ _) n_args
+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 name) arity
+ | otherwise = DirectEntry (enterIdLabel hmods name) arity
-getCallMethod name (LFCon con) n_args
+getCallMethod hmods name (LFCon con) n_args
= ASSERT( n_args == 0 )
ReturnCon con
-getCallMethod name (LFThunk _ _ updatable std_form_info is_fun) n_args
+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
- || opt_SMP -- Always enter via node on SMP, since the
- -- thunk might have been blackholed in the
- -- meantime.
+ {- 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 name std_form_info updatable)
+ JumpToIt (thunkEntryLabel hmods name std_form_info updatable)
-getCallMethod name (LFUnknown True) n_args
+getCallMethod hmods name (LFUnknown True) n_args
= SlowCall -- might be a function
-getCallMethod name (LFUnknown False) n_args
+getCallMethod hmods name (LFUnknown False) n_args
= ASSERT2 ( n_args == 0, ppr name <+> ppr n_args )
EnterIt -- Not a function
-getCallMethod name (LFBlackHole _) n_args
+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 name (LFLetNoEscape 0) n_args
+getCallMethod hmods name (LFLetNoEscape 0) n_args
= JumpToIt (enterReturnPtLabel (nameUnique name))
-getCallMethod name (LFLetNoEscape arity) n_args
+getCallMethod hmods name (LFLetNoEscape arity) n_args
| n_args == arity = DirectEntry (enterReturnPtLabel (nameUnique name)) arity
| otherwise = pprPanic "let-no-escape: " (ppr name <+> ppr arity)
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
LFThunk _ _ upd_flag (ApThunk arity) _ ->
mkApInfoTableLabel upd_flag arity
- LFThunk{} -> mkInfoTableLabel name
+ LFThunk{} -> mkLocalInfoTableLabel 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
-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"
-- thunkEntryLabel is a local help function, not exported. It's used from both
-- entryLabelFromCI and getCallMethod.
-thunkEntryLabel thunk_id (ApThunk arity) is_updatable
+thunkEntryLabel hmods thunk_id (ApThunk arity) is_updatable
= enterApLabel is_updatable arity
-thunkEntryLabel thunk_id (SelectorThunk offset) upd_flag
+thunkEntryLabel hmods thunk_id (SelectorThunk offset) upd_flag
= enterSelectorLabel upd_flag offset
-thunkEntryLabel thunk_id _ is_updatable
- = enterIdLabel thunk_id
+thunkEntryLabel hmods thunk_id _ is_updatable
+ = enterIdLabel hmods thunk_id
enterApLabel is_updatable arity
| tablesNextToCode = mkApInfoTableLabel is_updatable arity
| tablesNextToCode = mkSelectorInfoLabel upd_flag offset
| otherwise = mkSelectorEntryLabel upd_flag offset
-enterIdLabel id
- | tablesNextToCode = mkInfoTableLabel id
- | otherwise = mkEntryLabel id
+enterIdLabel hmods id
+ | tablesNextToCode = mkInfoTableLabel hmods id
+ | otherwise = mkEntryLabel hmods id
+
+enterLocalIdLabel id
+ | tablesNextToCode = mkLocalInfoTableLabel id
+ | otherwise = mkLocalEntryLabel id
enterReturnPtLabel name
| tablesNextToCode = mkReturnInfoLabel name
closureValDescr (ClosureInfo {closureDescr = descr})
= descr
closureValDescr (ConInfo {closureCon = con})
- = occNameUserString (getOccName 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
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
}
projects / ghc-hetmet.git / blobdiff