X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FClosureInfo.lhs;h=84d9dd95efcf7a94d0e137080e0ff6897b779ef7;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=476aa2aa950499637d031e881ccd6f83b393b4cc;hpb=23f40f0e9be6d4aa5cf9ea31d73f4013f8e7b4bd;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 476aa2a..84d9dd9 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -29,11 +29,12 @@ module ClosureInfo ( 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, @@ -60,14 +61,14 @@ import SMRep -- all of it 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 ) @@ -114,7 +115,8 @@ data ClosureInfo -- 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... @@ -293,6 +295,16 @@ 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} + %************************************************************************ %* * Building ClosureInfos @@ -318,13 +330,15 @@ mkClosureInfo is_static id lf_info tot_wds ptr_wds srt_info descr 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} @@ -337,30 +351,21 @@ mkConInfo is_static data_con tot_wds ptr_wds \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) @@ -381,44 +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 :: 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} %************************************************************************ @@ -557,59 +560,62 @@ data CallMethod 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) @@ -759,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 @@ -810,35 +824,33 @@ infoTableLabelFromCI (ClosureInfo { closureName = name, 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 @@ -848,9 +860,13 @@ enterSelectorLabel upd_flag offset | 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 @@ -905,12 +921,12 @@ closureValDescr, closureTypeDescr :: ClosureInfo -> String 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 @@ -919,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 }