X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FcodeGen%2FClosureInfo.lhs;h=157a6b70e21f83261b1a426328b13e9c8bb70362;hb=c2b053f3228a8e32cf4d4909c2e97b338e3ac3c1;hp=9e99002671dedf2c618d6e58b5411fb12224d2be;hpb=7e602b0a11e567fcb035d1afd34015aebcf9a577;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index 9e99002..157a6b7 100644 --- a/ghc/compiler/codeGen/ClosureInfo.lhs +++ b/ghc/compiler/codeGen/ClosureInfo.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: ClosureInfo.lhs,v 1.32 1998/12/18 17:40:54 simonpj Exp $ +% $Id: ClosureInfo.lhs,v 1.39 1999/11/02 15:05:44 simonmar Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -39,7 +39,7 @@ module ClosureInfo ( closureLabelFromCI, entryLabelFromCI, closureLFInfo, closureSMRep, closureUpdReqd, - closureSingleEntry, closureSemiTag, + closureSingleEntry, closureReEntrant, closureSemiTag, isStandardFormThunk, GenStgArg, @@ -48,9 +48,12 @@ module ClosureInfo ( isStaticClosure, allocProfilingMsg, - blackHoleClosureInfo, + cafBlackHoleClosureInfo, seCafBlackHoleClosureInfo, maybeSelectorInfo, - needsSRT + + infoTblNeedsSRT, + staticClosureNeedsLink, + getSRTInfo ) where #include "HsVersions.h" @@ -59,12 +62,14 @@ import AbsCSyn ( MagicId, node, VirtualHeapOffset, HeapOffset ) import StgSyn import CgMonad -import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject ) +import Constants ( mIN_UPD_SIZE, mIN_SIZE_NonUpdHeapObject, + mAX_SPEC_FUN_SIZE, mAX_SPEC_THUNK_SIZE, mAX_SPEC_CONSTR_SIZE ) import CgRetConv ( assignRegs ) import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, mkInfoTableLabel, mkConInfoTableLabel, mkStaticClosureLabel, - mkBlackHoleInfoTableLabel, + mkCAFBlackHoleInfoTableLabel, + mkSECAFBlackHoleInfoTableLabel, mkStaticInfoTableLabel, mkStaticConEntryLabel, mkConEntryLabel, mkClosureLabel, mkSelectorInfoLabel, mkSelectorEntryLabel, @@ -72,7 +77,8 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, mkReturnPtLabel ) import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, - opt_Parallel ) + opt_Parallel, opt_DoTickyProfiling, + opt_SMP ) import Id ( Id, idType, getIdArity ) import DataCon ( DataCon, dataConTag, fIRST_TAG, isNullaryDataCon, isTupleCon, dataConName @@ -83,7 +89,7 @@ import PprType ( getTyDescription ) import PrimRep ( getPrimRepSize, separateByPtrFollowness, PrimRep ) import SMRep -- all of it import Type ( isUnLiftedType, Type ) -import BasicTypes ( TopLevelFlag(..) ) +import BasicTypes ( TopLevelFlag(..), isNotTopLevel, isTopLevel ) import Util ( mapAccumL ) import Outputable \end{code} @@ -117,6 +123,8 @@ data LambdaFormInfo TopLevelFlag -- True if top level !Int -- Arity !Bool -- True <=> no fvs + CLabel -- SRT label + SRT -- SRT info | LFCon -- Constructor DataCon -- The constructor @@ -132,6 +140,8 @@ data LambdaFormInfo !Bool -- True <=> no free vars Bool -- True <=> updatable (i.e., *not* single-entry) StandardFormInfo + CLabel -- SRT label + SRT -- SRT info | LFArgument -- Used for function arguments. We know nothing about -- this closure. Treat like updatable "LFThunk"... @@ -147,9 +157,9 @@ data LambdaFormInfo Int -- arity; | LFBlackHole -- Used for the closures allocated to hold the result - -- of a CAF. We want the target of the update frame to -- be in the heap, so we make a black hole to hold it. + CLabel -- Flavour (info label, eg CAF_BLACKHOLE_info). data StandardFormInfo -- Tells whether this thunk has one of a small number @@ -198,20 +208,23 @@ mkClosureLFInfo :: Id -- The binder -> [Id] -- Free vars -> UpdateFlag -- Update flag -> [Id] -- Args + -> CLabel -- SRT label + -> SRT -- SRT info -> LambdaFormInfo -mkClosureLFInfo bndr top fvs upd_flag args@(_:_) -- Non-empty args - = LFReEntrant (idType bndr) top (length args) (null fvs) +mkClosureLFInfo bndr top fvs upd_flag args@(_:_) srt_label srt -- Non-empty args + = LFReEntrant (idType bndr) top (length args) (null fvs) srt_label srt -mkClosureLFInfo bndr top fvs ReEntrant [] - = LFReEntrant (idType bndr) top 0 (null fvs) +mkClosureLFInfo bndr top fvs ReEntrant [] srt_label srt + = LFReEntrant (idType bndr) top 0 (null fvs) srt_label srt -mkClosureLFInfo bndr top fvs upd_flag [] +mkClosureLFInfo bndr top fvs upd_flag [] srt_label srt #ifdef DEBUG | isUnLiftedType ty = pprPanic "mkClosureLFInfo" (ppr bndr <+> ppr ty) #endif | otherwise = LFThunk ty top (null fvs) (isUpdatable upd_flag) NonStandardThunk + srt_label srt where ty = idType bndr \end{code} @@ -227,17 +240,20 @@ mkConLFInfo con mkSelectorLFInfo rhs_ty offset updatable = LFThunk rhs_ty NotTopLevel False updatable (SelectorThunk offset) + (error "mkSelectorLFInfo: no srt label") + (error "mkSelectorLFInfo: no srt") mkApLFInfo rhs_ty upd_flag arity = LFThunk rhs_ty NotTopLevel (arity == 0) (isUpdatable upd_flag) (ApThunk arity) + (error "mkApLFInfo: no srt label") + (error "mkApLFInfo: no srt") \end{code} Miscellaneous LF-infos. \begin{code} mkLFArgument = LFArgument -mkLFBlackHole = LFBlackHole mkLFLetNoEscape = LFLetNoEscape mkLFImported :: Id -> LambdaFormInfo @@ -246,7 +262,11 @@ mkLFImported id ArityExactly 0 -> LFThunk (idType id) TopLevel True{-no fvs-} True{-updatable-} NonStandardThunk + (error "mkLFImported: no srt label") + (error "mkLFImported: no srt") ArityExactly n -> LFReEntrant (idType id) TopLevel n True -- n > 0 + (error "mkLFImported: no srt label") + (error "mkLFImported: no srt") other -> LFImported -- Not sure of exact arity \end{code} @@ -393,18 +413,19 @@ layOutStaticClosure name kind_fn things lf_info (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 + _ -> getStaticClosureType lf_info bot = panic "layoutStaticClosure" layOutStaticNoFVClosure :: Name -> LambdaFormInfo -> ClosureInfo layOutStaticNoFVClosure name lf_info - = MkClosureInfo name lf_info (StaticRep 0 0 (getClosureType lf_info)) + = MkClosureInfo name lf_info (StaticRep 0 0 (getStaticClosureType lf_info)) \end{code} %************************************************************************ @@ -422,24 +443,54 @@ chooseDynSMRep chooseDynSMRep lf_info tot_wds ptr_wds = let nonptr_wds = tot_wds - ptr_wds - closure_type = getClosureType lf_info + closure_type = getClosureType tot_wds ptr_wds nonptr_wds lf_info in case lf_info of LFTuple _ True -> ConstantRep LFCon _ True -> ConstantRep _ -> GenericRep ptr_wds nonptr_wds closure_type -getClosureType :: LambdaFormInfo -> ClosureType -getClosureType lf_info = +getStaticClosureType :: LambdaFormInfo -> ClosureType +getStaticClosureType lf_info = + case lf_info of + LFCon con True -> CONSTR_NOCAF + LFCon con False -> CONSTR + LFReEntrant _ _ _ _ _ _ -> FUN + LFTuple _ _ -> CONSTR + LFThunk _ _ _ _ (SelectorThunk _) _ _ -> THUNK_SELECTOR + LFThunk _ _ _ True _ _ _ -> THUNK + LFThunk _ _ _ False _ _ _ -> FUN + _ -> panic "getClosureType" + +-- 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 :: Int -> Int -> Int -> LambdaFormInfo -> ClosureType +getClosureType tot_wds ptrs nptrs 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 + + LFCon con False + | tot_wds > 0 && tot_wds <= mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n ptrs nptrs + | otherwise -> CONSTR + + LFReEntrant _ _ _ _ _ _ + | tot_wds > 0 && tot_wds <= mAX_SPEC_FUN_SIZE -> FUN_p_n ptrs nptrs + | otherwise -> FUN + + LFTuple _ _ + | tot_wds > 0 && tot_wds <= mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n ptrs nptrs + | otherwise -> CONSTR + + LFThunk _ _ _ _ (SelectorThunk _) _ _ -> THUNK_SELECTOR + + LFThunk _ _ _ _ _ _ _ + | tot_wds > 0 && tot_wds <= mAX_SPEC_THUNK_SIZE -> THUNK_p_n ptrs nptrs + | otherwise -> THUNK + _ -> panic "getClosureType" - -- ToDo: could be anything else here? \end{code} %************************************************************************ @@ -491,9 +542,9 @@ nodeMustPointToIt :: LambdaFormInfo -> FCode Bool nodeMustPointToIt lf_info = case lf_info of - LFReEntrant ty top arity no_fvs -> returnFC ( + LFReEntrant ty top arity no_fvs _ _ -> returnFC ( not no_fvs || -- Certainly if it has fvs we need to point to it - case top of { TopLevel -> False; _ -> True } + 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 @@ -518,7 +569,7 @@ nodeMustPointToIt lf_info -- having Node point to the result of an update. SLPJ -- 27/11/92. - LFThunk _ _ no_fvs updatable NonStandardThunk + LFThunk _ _ no_fvs updatable NonStandardThunk _ _ -> returnFC (updatable || not no_fvs || opt_SccProfilingOn) -- For the non-updatable (single-entry case): @@ -528,13 +579,13 @@ 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 + 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 + LFArgument -> returnFC True + LFImported -> returnFC True + LFBlackHole _ -> returnFC True -- BH entry may require Node to point LFLetNoEscape _ -> returnFC False @@ -601,7 +652,7 @@ getEntryConvention name lf_info arg_kinds case lf_info of - LFReEntrant _ _ arity _ -> + LFReEntrant _ _ arity _ _ _ -> if arity == 0 || (length arg_kinds) < arity then StdEntry (mkStdEntryLabel name) else @@ -627,16 +678,19 @@ getEntryConvention name lf_info arg_kinds -- Should have no args (meaning what?) StdEntry (mkConEntryLabel (dataConName tup)) - LFThunk _ _ _ updatable std_form_info - -> if updatable + LFThunk _ _ _ updatable std_form_info _ _ + -> if 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. then ViaNode - else StdEntry (thunkEntryLabel name std_form_info updatable) + else StdEntry (thunkEntryLabel name std_form_info updatable) - LFArgument -> ViaNode - LFImported -> ViaNode - LFBlackHole -> ViaNode -- Presumably the black hole has by now - -- been updated, but we don't know with - -- what, so we enter via Node + LFArgument -> ViaNode + LFImported -> ViaNode + LFBlackHole _ -> ViaNode -- Presumably the black hole has by now + -- been updated, but we don't know with + -- what, so we enter via Node LFLetNoEscape 0 -> StdEntry (mkReturnPtLabel (nameUnique name)) @@ -662,33 +716,58 @@ blackHoleOnEntry (MkClosureInfo _ _ (StaticRep _ _ _)) = False blackHoleOnEntry (MkClosureInfo _ lf_info _) = case lf_info of - LFReEntrant _ _ _ _ -> False + LFReEntrant _ _ _ _ _ _ -> False LFLetNoEscape _ -> False - LFThunk _ _ no_fvs updatable _ + LFThunk _ _ no_fvs updatable _ _ _ -> if updatable then not opt_OmitBlackHoling - else not no_fvs + else opt_DoTickyProfiling || not no_fvs + -- the former to catch double entry, + -- and the latter to plug space-leaks. KSW/SDM 1999-04. + other -> panic "blackHoleOnEntry" -- Should never happen isStandardFormThunk :: LambdaFormInfo -> Bool -isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _)) = True -isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _)) = True -isStandardFormThunk other_lf_info = False +isStandardFormThunk (LFThunk _ _ _ _ (SelectorThunk _) _ _) = True +isStandardFormThunk (LFThunk _ _ _ _ (ApThunk _) _ _) = True +isStandardFormThunk other_lf_info = False maybeSelectorInfo (MkClosureInfo _ (LFThunk _ _ _ _ - (SelectorThunk offset)) _) = Just offset + (SelectorThunk offset) _ _) _) = Just offset maybeSelectorInfo _ = Nothing +\end{code} --- Does this thunk's info table have an SRT? +----------------------------------------------------------------------------- +SRT-related stuff -needsSRT :: ClosureInfo -> Bool -needsSRT (MkClosureInfo _ info _) = + +\begin{code} +infoTblNeedsSRT :: ClosureInfo -> Bool +infoTblNeedsSRT (MkClosureInfo _ info _) = case info of - LFThunk _ _ _ _ (SelectorThunk _) -> False -- not for selectors - LFThunk _ _ _ _ _ -> True - LFReEntrant _ _ _ _ -> True + LFThunk _ _ _ _ _ _ NoSRT -> False + LFThunk _ _ _ _ _ _ _ -> True + + LFReEntrant _ _ _ _ _ NoSRT -> False + LFReEntrant _ _ _ _ _ _ -> True + _ -> False + +staticClosureNeedsLink :: ClosureInfo -> Bool +staticClosureNeedsLink (MkClosureInfo _ info _) = + case info of + LFThunk _ _ _ _ _ _ NoSRT -> False + LFReEntrant _ _ _ _ _ NoSRT -> False + LFCon _ True -> False -- zero arity constructors + _ -> True + +getSRTInfo :: ClosureInfo -> (CLabel, SRT) +getSRTInfo (MkClosureInfo _ info _) = + case info of + LFThunk _ _ _ _ _ lbl srt -> (lbl,srt) + LFReEntrant _ _ _ _ lbl srt -> (lbl,srt) + _ -> panic "getSRTInfo" \end{code} Avoiding generating entries and info tables @@ -759,8 +838,8 @@ staticClosureRequired -> LambdaFormInfo -> Bool staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) - (LFReEntrant _ top_level _ _) -- It's a function - = ASSERT( case top_level of { TopLevel -> True; other -> False } ) + (LFReEntrant _ top_level _ _ _ _) -- It's a function + = ASSERT( isTopLevel top_level ) -- Assumption: it's a top-level, no-free-var binding arg_occ -- There's an argument occurrence || unsat_occ -- There's an unsaturated call @@ -789,8 +868,8 @@ funInfoTableRequired -> LambdaFormInfo -> Bool funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) - (LFReEntrant _ top_level _ _) - = (case top_level of { NotTopLevel -> True; TopLevel -> False }) + (LFReEntrant _ top_level _ _ _ _) + = isNotTopLevel top_level || arg_occ -- There's an argument occurrence || unsat_occ -- There's an unsaturated call || isExternallyVisibleName binder @@ -819,22 +898,23 @@ closureLFInfo :: ClosureInfo -> LambdaFormInfo closureLFInfo (MkClosureInfo _ lf_info _) = lf_info closureUpdReqd :: ClosureInfo -> Bool - -closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _) _) = upd -closureUpdReqd (MkClosureInfo _ LFBlackHole _) = True +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. closureUpdReqd other_closure = False closureSingleEntry :: ClosureInfo -> Bool - -closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _) _) = not upd +closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = not upd closureSingleEntry other_closure = False + +closureReEntrant :: ClosureInfo -> Bool +closureReEntrant (MkClosureInfo _ (LFReEntrant _ _ _ _ _ _) _) = True +closureReEntrant other_closure = False \end{code} \begin{code} closureSemiTag :: ClosureInfo -> Maybe Int - closureSemiTag (MkClosureInfo _ lf_info _) = case lf_info of LFCon data_con _ -> Just (dataConTag data_con - fIRST_TAG) @@ -847,8 +927,8 @@ isToplevClosure :: ClosureInfo -> Bool isToplevClosure (MkClosureInfo _ lf_info _) = case lf_info of - LFReEntrant _ TopLevel _ _ -> True - LFThunk _ TopLevel _ _ _ -> True + LFReEntrant _ TopLevel _ _ _ _ -> True + LFThunk _ TopLevel _ _ _ _ _ -> True other -> False \end{code} @@ -863,7 +943,7 @@ Label generation. \begin{code} fastLabelFromCI :: ClosureInfo -> CLabel -fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _) _) +fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _ _ _) _) = mkFastEntryLabel name arity fastLabelFromCI (MkClosureInfo name _ _) @@ -872,15 +952,15 @@ fastLabelFromCI (MkClosureInfo name _ _) infoTableLabelFromCI :: ClosureInfo -> CLabel infoTableLabelFromCI (MkClosureInfo id lf_info rep) = case lf_info of - LFCon con _ -> mkConInfoPtr con rep - LFTuple tup _ -> mkConInfoPtr tup rep + LFCon con _ -> mkConInfoPtr con rep + LFTuple tup _ -> mkConInfoPtr tup rep - LFBlackHole -> mkBlackHoleInfoTableLabel + LFBlackHole info -> info - LFThunk _ _ _ upd_flag (SelectorThunk offset) -> + LFThunk _ _ _ upd_flag (SelectorThunk offset) _ _ -> mkSelectorInfoLabel upd_flag offset - LFThunk _ _ _ upd_flag (ApThunk arity) -> + LFThunk _ _ _ upd_flag (ApThunk arity) _ _ -> mkApInfoTableLabel upd_flag arity other -> {-NO: if isStaticRep rep @@ -913,7 +993,7 @@ 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 + 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 @@ -934,20 +1014,26 @@ allocProfilingMsg :: ClosureInfo -> FAST_STRING allocProfilingMsg (MkClosureInfo _ lf_info _) = case lf_info of - LFReEntrant _ _ _ _ -> SLIT("TICK_ALLOC_FUN") + 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") + LFThunk _ _ _ True _ _ _ -> SLIT("TICK_ALLOC_UP_THK") -- updatable + LFThunk _ _ _ False _ _ _ -> SLIT("TICK_ALLOC_SE_THK") -- nonupdatable + LFBlackHole _ -> SLIT("TICK_ALLOC_BH") LFImported -> panic "TICK_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. +want to allocate the black hole on entry to a CAF. These are the only +ways to build an LFBlackHole, maintaining the invariant that it really +is a black hole and not something else. \begin{code} -blackHoleClosureInfo (MkClosureInfo name _ _) - = MkClosureInfo name LFBlackHole BlackHoleRep +cafBlackHoleClosureInfo (MkClosureInfo name _ _) + = MkClosureInfo name (LFBlackHole mkCAFBlackHoleInfoTableLabel) BlackHoleRep + +seCafBlackHoleClosureInfo (MkClosureInfo name _ _) + = MkClosureInfo name (LFBlackHole mkSECAFBlackHoleInfoTableLabel) BlackHoleRep \end{code} %************************************************************************ @@ -967,9 +1053,9 @@ in the closure info using @closureTypeDescr@. \begin{code} closureTypeDescr :: ClosureInfo -> String -closureTypeDescr (MkClosureInfo name (LFThunk ty _ _ _ _) _) +closureTypeDescr (MkClosureInfo name (LFThunk ty _ _ _ _ _ _) _) = getTyDescription ty -closureTypeDescr (MkClosureInfo name (LFReEntrant ty _ _ _) _) +closureTypeDescr (MkClosureInfo name (LFReEntrant ty _ _ _ _ _) _) = getTyDescription ty closureTypeDescr (MkClosureInfo name lf _) = showSDoc (ppr name)