From 74b1006ed8565ff3c39edcdaf859d606dd652641 Mon Sep 17 00:00:00 2001 From: simonm Date: Thu, 11 Mar 1999 11:32:29 +0000 Subject: [PATCH] [project @ 1999-03-11 11:32:22 by simonm] Save a few bytes by ommitting the static link field on closures with an empty SRT. --- ghc/compiler/absCSyn/AbsCSyn.lhs | 3 +- ghc/compiler/absCSyn/AbsCUtils.lhs | 4 +- ghc/compiler/absCSyn/Costs.lhs | 2 +- ghc/compiler/absCSyn/PprAbsC.lhs | 19 +++-- ghc/compiler/codeGen/CgClosure.lhs | 26 +++--- ghc/compiler/codeGen/CgConTbls.lhs | 8 +- ghc/compiler/codeGen/CgExpr.lhs | 13 +-- ghc/compiler/codeGen/ClosureInfo.lhs | 138 ++++++++++++++++++++------------ ghc/compiler/codeGen/CodeGen.lhs | 8 +- ghc/compiler/nativeGen/AbsCStixGen.lhs | 16 ++-- ghc/compiler/nativeGen/StixInfo.lhs | 13 +-- 11 files changed, 146 insertions(+), 104 deletions(-) diff --git a/ghc/compiler/absCSyn/AbsCSyn.lhs b/ghc/compiler/absCSyn/AbsCSyn.lhs index da3b412..dfaf400 100644 --- a/ghc/compiler/absCSyn/AbsCSyn.lhs +++ b/ghc/compiler/absCSyn/AbsCSyn.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: AbsCSyn.lhs,v 1.20 1999/03/03 17:41:13 simonm Exp $ +% $Id: AbsCSyn.lhs,v 1.21 1999/03/11 11:32:22 simonm Exp $ % \section[AbstractC]{Abstract C: the last stop before machine code} @@ -185,7 +185,6 @@ stored in a mixed type location.) AbstractC -- Slow entry point code (Maybe AbstractC) -- Fast entry point code, if any - (CLabel,SRT) -- SRT info String -- Closure description; NB we can't get this -- from ClosureInfo, because the latter refers -- to the *right* hand side of a defn, whereas diff --git a/ghc/compiler/absCSyn/AbsCUtils.lhs b/ghc/compiler/absCSyn/AbsCUtils.lhs index 3ffafcb..e90719c 100644 --- a/ghc/compiler/absCSyn/AbsCUtils.lhs +++ b/ghc/compiler/absCSyn/AbsCUtils.lhs @@ -305,11 +305,11 @@ flatAbsC (AbsCStmts s1 s2) returnFlt (mkAbsCStmts inline_s1 inline_s2, mkAbsCStmts top_s1 top_s2) -flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast srt descr) +flatAbsC (CClosureInfoAndCode cl_info slow maybe_fast descr) = flatAbsC slow `thenFlt` \ (slow_heres, slow_tops) -> flat_maybe maybe_fast `thenFlt` \ (fast_heres, fast_tops) -> returnFlt (AbsCNop, mkAbstractCs [slow_tops, fast_tops, - CClosureInfoAndCode cl_info slow_heres fast_heres srt descr] + CClosureInfoAndCode cl_info slow_heres fast_heres descr] ) flatAbsC (CCodeBlock label abs_C) diff --git a/ghc/compiler/absCSyn/Costs.lhs b/ghc/compiler/absCSyn/Costs.lhs index 5296a1b..3588fe5 100644 --- a/ghc/compiler/absCSyn/Costs.lhs +++ b/ghc/compiler/absCSyn/Costs.lhs @@ -217,7 +217,7 @@ costs absC = CStaticClosure _ _ _ _ -> nullCosts - CClosureInfoAndCode _ _ _ _ _ -> nullCosts + CClosureInfoAndCode _ _ _ _ -> nullCosts CRetDirect _ _ _ _ -> nullCosts diff --git a/ghc/compiler/absCSyn/PprAbsC.lhs b/ghc/compiler/absCSyn/PprAbsC.lhs index 5aeb8b7..67b22b5 100644 --- a/ghc/compiler/absCSyn/PprAbsC.lhs +++ b/ghc/compiler/absCSyn/PprAbsC.lhs @@ -359,7 +359,7 @@ pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ ppLocalnessMacro True{-include dyn-} info_lbl, char ')' ], - nest 2 (ppr_payload (amodes ++ padding_wds)), + nest 2 (ppr_payload (amodes ++ padding_wds ++ static_link_field)), ptext SLIT("};") ] } where @@ -378,16 +378,18 @@ pprAbsC stmt@(CStaticClosure closure_lbl cl_info cost_centre amodes) _ where rep = getAmodeRep item - -- always at least one padding word: this is the static link field for - -- the garbage collector. padding_wds = if not (closureUpdReqd cl_info) then - [mkIntCLit 0] + [] else - case 1 + (max 0 (mIN_UPD_SIZE - length amodes)) of { still_needed -> + case max 0 (mIN_UPD_SIZE - length amodes) of { still_needed -> nOfThem still_needed (mkIntCLit 0) } -- a bunch of 0s -pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _ + static_link_field + | staticClosureNeedsLink cl_info = [mkIntCLit 0] + | otherwise = [] + +pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast cl_descr) _ = vcat [ hcat [ ptext SLIT("INFO_TABLE"), @@ -435,7 +437,8 @@ pprAbsC stmt@(CClosureInfoAndCode cl_info slow maybe_fast srt cl_descr) _ is_constr = maybeToBool maybe_tag (Just tag) = maybe_tag - needs_srt = has_srt srt && needsSRT cl_info + needs_srt = infoTblNeedsSRT cl_info + srt = getSRTInfo cl_info size = closureNonHdrSize cl_info @@ -1461,7 +1464,7 @@ ppr_decls_AbsC (CStaticClosure closure_lbl closure_info cost_centre amodes) -- ToDo: strictly speaking, should chk "cost_centre" amode = ppr_decls_Amodes amodes -ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _ _) +ppr_decls_AbsC (CClosureInfoAndCode cl_info slow maybe_fast _) = ppr_decls_Amodes [entry_lbl] `thenTE` \ p1 -> ppr_decls_AbsC slow `thenTE` \ p2 -> (case maybe_fast of diff --git a/ghc/compiler/codeGen/CgClosure.lhs b/ghc/compiler/codeGen/CgClosure.lhs index c1ddff2..fbd57ad 100644 --- a/ghc/compiler/codeGen/CgClosure.lhs +++ b/ghc/compiler/codeGen/CgClosure.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgClosure.lhs,v 1.24 1999/03/02 14:34:36 sof Exp $ +% $Id: CgClosure.lhs,v 1.25 1999/03/11 11:32:25 simonm Exp $ % \section[CgClosure]{Code generation for closures} @@ -72,13 +72,12 @@ They should have no free variables. cgTopRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo - -> SRT -> [Id] -- Args -> StgExpr -> LambdaFormInfo -> FCode (Id, CgIdInfo) -cgTopRhsClosure id ccs binder_info srt args body lf_info +cgTopRhsClosure id ccs binder_info args body lf_info = -- LAY OUT THE OBJECT let closure_info = layOutStaticNoFVClosure name lf_info @@ -107,7 +106,7 @@ cgTopRhsClosure id ccs binder_info srt args body lf_info `thenC` -- GENERATE THE INFO TABLE (IF NECESSARY) - forkClosureBody (closureCodeBody binder_info srt closure_info + forkClosureBody (closureCodeBody binder_info closure_info ccs args body) ) `thenC` @@ -132,7 +131,6 @@ cgStdRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo - -> SRT -- SRT info -> [Id] -- Free vars -> [Id] -- Args -> StgExpr @@ -140,7 +138,7 @@ cgStdRhsClosure -> [StgArg] -- payload -> FCode (Id, CgIdInfo) -cgStdRhsClosure binder cc binder_info srt fvs args body lf_info payload +cgStdRhsClosure binder cc binder_info fvs args body lf_info payload -- AHA! A STANDARD-FORM THUNK = ( -- LAY OUT THE OBJECT @@ -169,14 +167,13 @@ Here's the general case. cgRhsClosure :: Id -> CostCentreStack -- Optional cost centre annotation -> StgBinderInfo - -> SRT -- SRT info -> [Id] -- Free vars -> [Id] -- Args -> StgExpr -> LambdaFormInfo -> FCode (Id, CgIdInfo) -cgRhsClosure binder cc binder_info srt fvs args body lf_info +cgRhsClosure binder cc binder_info fvs args body lf_info = ( -- LAY OUT THE OBJECT -- @@ -223,7 +220,7 @@ cgRhsClosure binder cc binder_info srt fvs args body lf_info nopC) `thenC` -- Compile the body - closureCodeBody binder_info srt closure_info cc args body + closureCodeBody binder_info closure_info cc args body ) `thenC` -- BUILD THE OBJECT @@ -245,7 +242,6 @@ cgRhsClosure binder cc binder_info srt fvs args body lf_info \begin{code} closureCodeBody :: StgBinderInfo - -> SRT -> ClosureInfo -- Lots of information about this closure -> CostCentreStack -- Optional cost centre attached to closure -> [Id] @@ -260,14 +256,13 @@ no argument satisfaction check, so fast and slow entry-point labels are the same. \begin{code} -closureCodeBody binder_info srt closure_info cc [] body +closureCodeBody binder_info closure_info cc [] body = -- thunks cannot have a primitive type! getAbsC body_code `thenFC` \ body_absC -> moduleName `thenFC` \ mod_name -> - getSRTLabel `thenFC` \ srt_label -> absC (CClosureInfoAndCode closure_info body_absC Nothing - (srt_label, srt) (cl_descr mod_name)) + (cl_descr mod_name)) where cl_descr mod_name = closureDescription mod_name (closureName closure_info) @@ -291,7 +286,7 @@ argSatisfactionCheck (by calling fetchAndReschedule). There info if Node points to closure is available. -- HWL \begin{code} -closureCodeBody binder_info srt closure_info cc all_args body +closureCodeBody binder_info closure_info cc all_args body = getEntryConvention name lf_info (map idPrimRep all_args) `thenFC` \ entry_conv -> @@ -408,7 +403,6 @@ closureCodeBody binder_info srt closure_info cc all_args body `thenFC` \ slow_abs_c -> forkAbsC fast_entry_code `thenFC` \ fast_abs_c -> moduleName `thenFC` \ mod_name -> - getSRTLabel `thenFC` \ srt_label -> -- Now either construct the info table, or put the fast code in alone -- (We never have slow code without an info table) @@ -417,7 +411,7 @@ closureCodeBody binder_info srt closure_info cc all_args body absC ( if info_table_needed then CClosureInfoAndCode closure_info slow_abs_c (Just fast_abs_c) - (srt_label, srt) (cl_descr mod_name) + (cl_descr mod_name) else CCodeBlock fast_label fast_abs_c ) diff --git a/ghc/compiler/codeGen/CgConTbls.lhs b/ghc/compiler/codeGen/CgConTbls.lhs index d2fddad..6e4a149 100644 --- a/ghc/compiler/codeGen/CgConTbls.lhs +++ b/ghc/compiler/codeGen/CgConTbls.lhs @@ -138,13 +138,9 @@ genConInfo comp_info tycon data_con closure_code = if zero_arity_con then AbsCNop else - CClosureInfoAndCode closure_info body Nothing - srt_info con_descr + CClosureInfoAndCode closure_info body Nothing con_descr - srt_info = (error "genConInfo: no srt label", NoSRT) - - static_code = CClosureInfoAndCode static_ci body Nothing - srt_info con_descr + static_code = CClosureInfoAndCode static_ci body Nothing con_descr tag = dataConTag data_con diff --git a/ghc/compiler/codeGen/CgExpr.lhs b/ghc/compiler/codeGen/CgExpr.lhs index ddf179d..9dbe3a2 100644 --- a/ghc/compiler/codeGen/CgExpr.lhs +++ b/ghc/compiler/codeGen/CgExpr.lhs @@ -1,7 +1,7 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -% $Id: CgExpr.lhs,v 1.19 1999/01/14 17:58:46 sof Exp $ +% $Id: CgExpr.lhs,v 1.20 1999/03/11 11:32:26 simonm Exp $ % %******************************************************** %* * @@ -303,7 +303,7 @@ mkRhsClosure bndr cc bi srt && maybeToBool maybe_offset -- Selectee is a component of the tuple && offset_into_int <= mAX_SPEC_SELECTEE_SIZE -- Offset is small enough = ASSERT(is_single_constructor) - cgStdRhsClosure bndr cc bi srt [the_fv] [] body lf_info [StgVarArg the_fv] + cgStdRhsClosure bndr cc bi [the_fv] [] body lf_info [StgVarArg the_fv] where lf_info = mkSelectorLFInfo (idType bndr) offset_into_int (isUpdatable upd_flag) @@ -345,7 +345,7 @@ mkRhsClosure bndr cc bi srt && arity <= mAX_SPEC_AP_SIZE -- Ha! an Ap thunk - = cgStdRhsClosure bndr cc bi srt fvs [] body lf_info payload + = cgStdRhsClosure bndr cc bi fvs [] body lf_info payload where lf_info = mkApLFInfo (idType bndr) upd_flag arity @@ -359,8 +359,11 @@ The default case ~~~~~~~~~~~~~~~~ \begin{code} mkRhsClosure bndr cc bi srt fvs upd_flag args body - = cgRhsClosure bndr cc bi srt fvs args body lf_info - where lf_info = mkClosureLFInfo bndr NotTopLevel fvs upd_flag args + = getSRTLabel `thenFC` \ srt_label -> + let lf_info = + mkClosureLFInfo bndr NotTopLevel fvs upd_flag args srt_label srt + in + cgRhsClosure bndr cc bi fvs args body lf_info \end{code} diff --git a/ghc/compiler/codeGen/ClosureInfo.lhs b/ghc/compiler/codeGen/ClosureInfo.lhs index c02317d..7a6ff6f 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.34 1999/03/04 17:52:08 simonm Exp $ +% $Id: ClosureInfo.lhs,v 1.35 1999/03/11 11:32:27 simonm Exp $ % \section[ClosureInfo]{Data structures which describe closures} @@ -50,7 +50,10 @@ module ClosureInfo ( allocProfilingMsg, blackHoleClosureInfo, maybeSelectorInfo, - needsSRT + + infoTblNeedsSRT, + staticClosureNeedsLink, + getSRTInfo ) where #include "HsVersions.h" @@ -118,6 +121,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 +138,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"... @@ -199,20 +206,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,10 +238,14 @@ 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. @@ -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,14 +452,14 @@ 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 _ _ _ True _ -> THUNK - LFThunk _ _ _ False _ -> FUN - _ -> 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 @@ -457,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 @@ -465,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 @@ -523,7 +541,7 @@ 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 } -- If it is not top level we will point to it @@ -550,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): @@ -560,7 +578,7 @@ 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. @@ -633,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 @@ -659,7 +677,7 @@ getEntryConvention name lf_info arg_kinds -- Should have no args (meaning what?) StdEntry (mkConEntryLabel (dataConName tup)) - LFThunk _ _ _ updatable std_form_info + LFThunk _ _ _ updatable std_form_info _ _ -> if updatable then ViaNode else StdEntry (thunkEntryLabel name std_form_info updatable) @@ -694,9 +712,9 @@ 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 @@ -704,23 +722,45 @@ blackHoleOnEntry (MkClosureInfo _ lf_info _) 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 @@ -791,7 +831,7 @@ staticClosureRequired -> LambdaFormInfo -> Bool staticClosureRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) - (LFReEntrant _ top_level _ _) -- It's a function + (LFReEntrant _ top_level _ _ _ _) -- It's a function = ASSERT( case top_level of { TopLevel -> True; other -> False } ) -- Assumption: it's a top-level, no-free-var binding arg_occ -- There's an argument occurrence @@ -821,7 +861,7 @@ funInfoTableRequired -> LambdaFormInfo -> Bool funInfoTableRequired binder (StgBinderInfo arg_occ unsat_occ _ _ _) - (LFReEntrant _ top_level _ _) + (LFReEntrant _ top_level _ _ _ _) = (case top_level of { NotTopLevel -> True; TopLevel -> False }) || arg_occ -- There's an argument occurrence || unsat_occ -- There's an unsaturated call @@ -852,7 +892,7 @@ closureLFInfo (MkClosureInfo _ lf_info _) = lf_info closureUpdReqd :: ClosureInfo -> Bool -closureUpdReqd (MkClosureInfo _ (LFThunk _ _ _ upd _) _) = upd +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. @@ -860,7 +900,7 @@ closureUpdReqd other_closure = False closureSingleEntry :: ClosureInfo -> Bool -closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _) _) = not upd +closureSingleEntry (MkClosureInfo _ (LFThunk _ _ _ upd _ _ _) _) = not upd closureSingleEntry other_closure = False \end{code} @@ -879,8 +919,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} @@ -895,7 +935,7 @@ Label generation. \begin{code} fastLabelFromCI :: ClosureInfo -> CLabel -fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _) _) +fastLabelFromCI (MkClosureInfo name (LFReEntrant _ _ arity _ _ _) _) = mkFastEntryLabel name arity fastLabelFromCI (MkClosureInfo name _ _) @@ -909,10 +949,10 @@ infoTableLabelFromCI (MkClosureInfo id lf_info rep) LFBlackHole -> mkBlackHoleInfoTableLabel - 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 @@ -945,7 +985,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 @@ -966,10 +1006,10 @@ 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") + LFThunk _ _ _ _ _ _ _ -> SLIT("TICK_ALLOC_THK") LFBlackHole -> SLIT("TICK_ALLOC_BH") LFImported -> panic "TICK_ALLOC_IMP" \end{code} @@ -999,9 +1039,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) diff --git a/ghc/compiler/codeGen/CodeGen.lhs b/ghc/compiler/codeGen/CodeGen.lhs index 6d38827..c6d94f4 100644 --- a/ghc/compiler/codeGen/CodeGen.lhs +++ b/ghc/compiler/codeGen/CodeGen.lhs @@ -183,7 +183,9 @@ cgTopRhs bndr (StgRhsCon cc con args) cgTopRhs bndr (StgRhsClosure cc bi srt fvs upd_flag args body) = ASSERT(null fvs) -- There should be no free variables - forkStatics (cgTopRhsClosure bndr cc bi srt args body lf_info) - where - lf_info = mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args + getSRTLabel `thenFC` \srt_label -> + let lf_info = + mkClosureLFInfo bndr TopLevel [{-no fvs-}] upd_flag args srt_label srt + in + forkStatics (cgTopRhsClosure bndr cc bi args body lf_info) \end{code} diff --git a/ghc/compiler/nativeGen/AbsCStixGen.lhs b/ghc/compiler/nativeGen/AbsCStixGen.lhs index 08dce9f..1588f3c 100644 --- a/ghc/compiler/nativeGen/AbsCStixGen.lhs +++ b/ghc/compiler/nativeGen/AbsCStixGen.lhs @@ -23,7 +23,8 @@ import SMRep ( fixedItblSize, import Constants ( mIN_UPD_SIZE ) import CLabel ( CLabel, mkReturnInfoLabel, mkReturnPtLabel ) import ClosureInfo ( infoTableLabelFromCI, entryLabelFromCI, - fastLabelFromCI, closureUpdReqd + fastLabelFromCI, closureUpdReqd, + staticClosureNeedsLink ) import Const ( Literal(..) ) import Maybes ( maybeToBool ) @@ -97,7 +98,7 @@ Here we handle top-level things, like @CCodeBlock@s and LvSmall _ -> rET_SMALL LvLarge _ -> rET_BIG - gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _ _) + gentopcode stmt@(CClosureInfoAndCode cl_info slow Nothing _) | slow_is_empty = genCodeInfoTable stmt `thenUs` \ itbl -> @@ -112,7 +113,7 @@ Here we handle top-level things, like @CCodeBlock@s and slow_is_empty = not (maybeToBool (nonemptyAbsC slow)) slow_lbl = entryLabelFromCI cl_info - gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _ _) = + gentopcode stmt@(CClosureInfoAndCode cl_info slow (Just fast) _) = -- ToDo: what if this is empty? ------------------------^^^^ genCodeInfoTable stmt `thenUs` \ itbl -> gencode slow `thenUs` \ slow_code -> @@ -171,14 +172,17 @@ Here we handle top-level things, like @CCodeBlock@s and where table = StData PtrRep [StCLbl (infoTableLabelFromCI cl_info)] : map (\amode -> StData (getAmodeRep amode) [a2stix amode]) amodes ++ - [StData PtrRep padding_wds] + [StData PtrRep (padding_wds ++ static_link)] -- always at least one padding word: this is the static link field -- for the garbage collector. padding_wds = if closureUpdReqd cl_info then - take (1 + max 0 (mIN_UPD_SIZE - length amodes)) zeros + take (max 0 (mIN_UPD_SIZE - length amodes)) zeros else - [StInt 0] + [] + + static_link | staticClosureNeedsLink cl_info = [StInt 0] + | otherwise = [] zeros = StInt 0 : zeros diff --git a/ghc/compiler/nativeGen/StixInfo.lhs b/ghc/compiler/nativeGen/StixInfo.lhs index 28e20ca..b72675f 100644 --- a/ghc/compiler/nativeGen/StixInfo.lhs +++ b/ghc/compiler/nativeGen/StixInfo.lhs @@ -13,7 +13,8 @@ import CLabel ( CLabel ) import StgSyn ( SRT(..) ) import ClosureInfo ( closurePtrsSize, closureNonHdrSize, closureSMRep, - infoTableLabelFromCI + infoTableLabelFromCI, + infoTblNeedsSRT, getSRTInfo ) import PrimRep ( PrimRep(..) ) import SMRep ( SMRep(..), getSMRepClosureTypeInt ) @@ -33,15 +34,14 @@ genCodeInfoTable :: AbstractC -> UniqSM StixTreeList -genCodeInfoTable (CClosureInfoAndCode cl_info _ _ srt cl_descr) +genCodeInfoTable (CClosureInfoAndCode cl_info _ _ cl_descr) = returnUs (\xs -> StData PtrRep table : StLabel info_lbl : xs) where info_lbl = infoTableLabelFromCI cl_info - table = case srt_len of - 0 -> rest_of_table - _ -> srt_label : rest_of_table + table | infoTblNeedsSRT cl_info = srt_label : rest_of_table + | otherwise = rest_of_table rest_of_table = [ @@ -62,7 +62,8 @@ genCodeInfoTable (CClosureInfoAndCode cl_info _ _ srt cl_descr) (fromInt closure_type `shiftL` 8) .|. (fromInt srt_len `shiftL` 16) #endif - + srt = getSRTInfo cl_info + (srt_label,srt_len) = case srt of (lbl, NoSRT) -> (StInt 0, 0) -- 1.7.10.4