X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2FcodeGen%2FClosureInfo.lhs;h=3b7b5a1b1bc929c4bafbf043ac09ecbce42d87e7;hb=2004d680b4a7b73dd0dcfe574afdbfee077877f8;hp=f64b8dccc9ee1ee83a796fdc08b8c6fb0c73b65e;hpb=723545930025a24708a8a0923435c95cc7f058c9;p=ghc-hetmet.git diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index f64b8dc..3b7b5a1 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.33 1999/01/26 16:16:33 simonm Exp $ +% $Id: ClosureInfo.lhs,v 1.38 1999/05/18 15:03:50 simonpj 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" @@ -65,7 +68,8 @@ import CgRetConv ( assignRegs ) import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, mkInfoTableLabel, mkConInfoTableLabel, mkStaticClosureLabel, - mkBlackHoleInfoTableLabel, + mkCAFBlackHoleInfoTableLabel, + mkSECAFBlackHoleInfoTableLabel, mkStaticInfoTableLabel, mkStaticConEntryLabel, mkConEntryLabel, mkClosureLabel, mkSelectorInfoLabel, mkSelectorEntryLabel, @@ -73,7 +77,7 @@ import CLabel ( CLabel, mkStdEntryLabel, mkFastEntryLabel, mkReturnPtLabel ) import CmdLineOpts ( opt_SccProfilingOn, opt_OmitBlackHoling, - opt_Parallel ) + opt_Parallel, opt_DoTickyProfiling ) import Id ( Id, idType, getIdArity ) import DataCon ( DataCon, dataConTag, fIRST_TAG, isNullaryDataCon, isTupleCon, dataConName @@ -84,7 +88,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} @@ -118,6 +122,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 @@ -133,6 +139,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"... @@ -148,9 +156,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 @@ -199,20 +207,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} @@ -228,17 +239,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 @@ -247,7 +261,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} @@ -434,13 +452,19 @@ chooseDynSMRep lf_info tot_wds ptr_wds 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 _ _ _ _ _ -> THUNK - _ -> panic "getClosureType" + 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 = @@ -451,7 +475,7 @@ getClosureType tot_wds ptrs nptrs lf_info = | tot_wds > 0 && tot_wds <= mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n ptrs nptrs | otherwise -> CONSTR - LFReEntrant _ _ _ _ + LFReEntrant _ _ _ _ _ _ | tot_wds > 0 && tot_wds <= mAX_SPEC_FUN_SIZE -> FUN_p_n ptrs nptrs | otherwise -> FUN @@ -459,9 +483,9 @@ getClosureType tot_wds ptrs nptrs lf_info = | tot_wds > 0 && tot_wds <= mAX_SPEC_CONSTR_SIZE -> CONSTR_p_n ptrs nptrs | otherwise -> CONSTR - LFThunk _ _ _ _ (SelectorThunk _) -> THUNK_SELECTOR + LFThunk _ _ _ _ (SelectorThunk _) _ _ -> THUNK_SELECTOR - LFThunk _ _ _ _ _ + LFThunk _ _ _ _ _ _ _ | tot_wds > 0 && tot_wds <= mAX_SPEC_THUNK_SIZE -> THUNK_p_n ptrs nptrs | otherwise -> THUNK @@ -517,9 +541,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 @@ -544,7 +568,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): @@ -554,13 +578,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 @@ -627,7 +651,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 @@ -653,16 +677,16 @@ 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 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)) @@ -688,33 +712,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} + +----------------------------------------------------------------------------- +SRT-related stuff --- Does this thunk's info table have an SRT? -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 @@ -785,8 +834,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 @@ -815,8 +864,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 @@ -845,22 +894,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) @@ -873,8 +923,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} @@ -889,7 +939,7 @@ Label generation. \begin{code} fastLabelFromCI :: ClosureInfo -> CLabel -fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _) _) +fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _ _ _) _) = mkFastEntryLabel name arity fastLabelFromCI (MkClosureInfo name _ _) @@ -898,15 +948,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 @@ -939,7 +989,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 @@ -960,20 +1010,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} %************************************************************************ @@ -993,9 +1049,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)