diff options
Diffstat (limited to 'ghc/compiler/profiling')
| -rw-r--r-- | ghc/compiler/profiling/CostCentre.lhs | 89 | ||||
| -rw-r--r-- | ghc/compiler/profiling/SCCauto.lhs | 83 | ||||
| -rw-r--r-- | ghc/compiler/profiling/SCCfinal.lhs | 266 |
3 files changed, 177 insertions, 261 deletions
diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index ad36f041f3..635e2459de 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -16,9 +16,10 @@ module CostCentre ( overheadCostCentre, dontCareCostCentre, mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC, - cafifyCC, unCafifyCC, dupifyCC, + cafifyCC, dupifyCC, isCafCC, isDictCC, isDupdCC, - setToAbleCostCentre, + isSccCountCostCentre, + sccAbleCostCentre, ccFromThisModule, ccMentionsId, @@ -29,9 +30,8 @@ module CostCentre ( IMP_Ubiq(){-uitous-} -import Id ( externallyVisibleId, GenId, Id(..) ) +import Id ( externallyVisibleId, GenId, SYN_IE(Id) ) import CStrings ( identToC, stringToC ) -import Maybes ( Maybe(..) ) import Name ( showRdr, getOccName, RdrName ) import Pretty ( ppShow, prettyToUn ) import PprStyle ( PprStyle(..) ) @@ -180,10 +180,10 @@ mkAllCafsCC m g = AllCafsCC m g mkAllDictsCC m g is_dupd = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC) -cafifyCC, unCafifyCC, dupifyCC :: CostCentre -> CostCentre +cafifyCC, dupifyCC :: CostCentre -> CostCentre -cafifyCC cc@(AllDictsCC _ _ _) = cc -- ???????? ToDo -cafifyCC cc@(PreludeDictsCC _) = cc -- ditto +cafifyCC cc@(AllDictsCC _ _ _) = cc -- ToDo ??? +cafifyCC cc@(PreludeDictsCC _) = cc -- ditto cafifyCC (NormalCC kind m g is_dupd is_caf) = ASSERT(not_a_calf_already is_caf) NormalCC kind m g is_dupd IsCafCC @@ -192,14 +192,6 @@ cafifyCC (NormalCC kind m g is_dupd is_caf) not_a_calf_already _ = True cafifyCC cc = panic ("cafifyCC"++(showCostCentre PprDebug False cc)) --- WDP 95/07: pretty dodgy -unCafifyCC (NormalCC kind m g is_dupd IsCafCC) = NormalCC kind m g is_dupd IsNotCafCC -unCafifyCC (AllCafsCC _ _) = CurrentCC -unCafifyCC PreludeCafsCC = CurrentCC -unCafifyCC (AllDictsCC _ _ _) = CurrentCC -unCafifyCC (PreludeDictsCC _) = CurrentCC -unCafifyCC other_cc = other_cc - dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC dupifyCC (NormalCC kind m g is_dupd is_caf) @@ -223,20 +215,33 @@ isDupdCC (PreludeDictsCC ADupdCC) = True isDupdCC (NormalCC _ _ _ ADupdCC _) = True isDupdCC _ = False -setToAbleCostCentre :: CostCentre -> Bool - -- Is this a cost-centre to which CCC might reasonably - -- be set? setToAbleCostCentre is allowed to panic on - -- "nonsense" cases, too... +isSccCountCostCentre :: CostCentre -> Bool + -- Is this a cost-centre which records scc counts -#ifdef DEBUG -setToAbleCostCentre NoCostCentre = panic "setToAbleCC:NoCostCentre" -setToAbleCostCentre SubsumedCosts = panic "setToAbleCC:SubsumedCosts" -setToAbleCostCentre CurrentCC = panic "setToAbleCC:CurrentCC" -setToAbleCostCentre DontCareCC = panic "setToAbleCC:DontCareCC" +#if DEBUG +isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre" +isSccCountCostCentre SubsumedCosts = panic "isSccCount:SubsumedCosts" +isSccCountCostCentre CurrentCC = panic "isSccCount:CurrentCC" +isSccCountCostCentre DontCareCC = panic "isSccCount:DontCareCC" #endif - -setToAbleCostCentre OverheadCC = False -- see comments in type defn -setToAbleCostCentre other = not (isCafCC other || isDictCC other) +isSccCountCostCentre OverheadCC = False +isSccCountCostCentre cc | isCafCC cc = False + | isDupdCC cc = False + | isDictCC cc = True + | otherwise = True + +sccAbleCostCentre :: CostCentre -> Bool + -- Is this a cost-centre which can be sccd ? + +#if DEBUG +sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre" +sccAbleCostCentre SubsumedCosts = panic "sccAbleCC:SubsumedCosts" +sccAbleCostCentre CurrentCC = panic "sccAbleCC:CurrentCC" +sccAbleCostCentre DontCareCC = panic "sccAbleCC:DontCareCC" +#endif +sccAbleCostCentre OverheadCC = False +sccAbleCostCentre cc | isCafCC cc = False + | otherwise = True ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool @@ -270,8 +275,8 @@ cmpCostCentre DontCareCC DontCareCC = EQ_ cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2) -- first key is module name, then we use "kinds" (which include - -- names) - = _CMP_STRING_ m1 m2 `thenCmp` cmp_kind k1 k2 + -- names) and finally the caf flag + = _CMP_STRING_ m1 m2 `thenCmp` cmp_kind k1 k2 `thenCmp` cmp_caf c1 c2 cmpCostCentre other_1 other_2 = let @@ -307,6 +312,11 @@ cmp_kind other_1 other_2 tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT) tag_CcKind (AutoCC _) = ILIT(2) tag_CcKind (DictCC _) = ILIT(3) + +cmp_caf IsNotCafCC IsCafCC = LT_ +cmp_caf IsNotCafCC IsNotCafCC = EQ_ +cmp_caf IsCafCC IsCafCC = EQ_ +cmp_caf IsCafCC IsNotCafCC = GT_ \end{code} \begin{code} @@ -344,8 +354,7 @@ uppCostCentre sty print_as_string cc = let prefix_CC = uppPStr SLIT("CC_") - basic_thing -- (basic_thing, suffix_CAF) - = do_cc cc + basic_thing = do_cc cc basic_thing_string = if friendly_sty then basic_thing else stringToC basic_thing @@ -361,9 +370,6 @@ uppCostCentre sty print_as_string cc where friendly_sty = friendly_style sty - add_module_name_maybe m str - = if print_as_string then str else (str ++ ('.' : m)) - ---------------- do_cc OverheadCC = "OVERHEAD" do_cc DontCareCC = "DONT_CARE" @@ -384,14 +390,16 @@ uppCostCentre sty print_as_string cc do_cc (NormalCC kind mod_name grp_name is_dupd is_caf) = let - basic_kind = do_kind kind - is_a_calf = do_calved is_caf + basic_kind = do_caf is_caf ++ do_kind kind in if friendly_sty then - do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name) ++ is_a_calf) + do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name)) else basic_kind where + do_caf IsCafCC = "CAF:" + do_caf _ = "" + do_kind (UserCC name) = _UNPK_ name do_kind (AutoCC id) = do_id id ++ (if friendly_sty then "/AUTO" else "") do_kind (DictCC id) = do_id id ++ (if friendly_sty then "/DICT" else "") @@ -402,9 +410,6 @@ uppCostCentre sty print_as_string cc then showRdr sty (getOccName id) -- use occ name else showId sty id -- we really do - do_calved IsCafCC = "/CAF" - do_calved _ = "" - --------------- do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str do_dupd _ str = str @@ -419,7 +424,7 @@ friendly_style sty -- i.e., probably for human consumption Printing unfoldings is sufficiently weird that we do it separately. This should only apply to CostCentres that can be ``set to'' (cf -@setToAbleCostCentre@). That excludes CAFs and +@sccAbleCostCentre@). That excludes CAFs and `overhead'---which are added at the very end---but includes dictionaries. Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info; even if we won't ultimately do a \tr{SET_CCC} from it. @@ -430,7 +435,7 @@ upp_cc_uf (AllDictsCC m g d) = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), upp_dupd d] upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf) - = ASSERT(isDictCC cc || setToAbleCostCentre cc) + = ASSERT(sccAbleCostCentre cc) uppCat [pp_kind cc_kind, uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), upp_dupd is_dupd, pp_caf is_caf] where diff --git a/ghc/compiler/profiling/SCCauto.lhs b/ghc/compiler/profiling/SCCauto.lhs deleted file mode 100644 index 331c37189b..0000000000 --- a/ghc/compiler/profiling/SCCauto.lhs +++ /dev/null @@ -1,83 +0,0 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 -% -\section[SCCauto]{Automated SCC annotations} - -Automatic insertion of \tr{_scc_} annotations for top-level bindings. - -Automatic insertion of \tr{_scc_} annotations on CAFs is better left -until STG land. We do DICT annotations there, too, but maybe that -will turn out to be a bummer... (WDP 94/06) - -This is a Core-to-Core pass (usually run {\em last}). - -\begin{code} -#include "HsVersions.h" - -module SCCauto ( addAutoCostCentres ) where - -IMP_Ubiq(){-uitous-} - -import CmdLineOpts ( opt_AutoSccsOnAllToplevs, - opt_AutoSccsOnExportedToplevs, - opt_SccGroup - ) -import CoreSyn -import CostCentre ( mkAutoCC, IsCafCC(..) ) -import Id ( isTopLevId, GenId{-instances-} ) -import Name ( isExported ) -\end{code} - -\begin{code} -addAutoCostCentres - :: FAST_STRING -- module name - -> [CoreBinding] -- input - -> [CoreBinding] -- output - -addAutoCostCentres mod_name binds - = if not doing_something then - binds -- now *that* was quick... - else - map scc_top_bind binds - where - doing_something = auto_all_switch_on || auto_exported_switch_on - - auto_all_switch_on = opt_AutoSccsOnAllToplevs -- only use! - auto_exported_switch_on = opt_AutoSccsOnExportedToplevs -- only use! - - grp_name - = case opt_SccGroup of - Just xx -> _PK_ xx - Nothing -> mod_name -- default: module name - - ----------------------------- - scc_top_bind (NonRec binder rhs) - = NonRec binder (scc_auto binder rhs) - - scc_top_bind (Rec pairs) - = Rec (map scc_pair pairs) - where - scc_pair (binder, rhs) = (binder, scc_auto binder rhs) - - ----------------------------- - -- Automatic scc annotation for user-defined top-level Ids - - scc_auto binder rhs - = if isTopLevId binder - && (auto_all_switch_on || isExported binder) - then scc_rhs rhs - else rhs - where - -- park auto SCC inside lambdas; don't put one there - -- if there already is one. - - scc_rhs rhs - = let - (usevars, tyvars, vars, body) = collectBinders rhs - in - case body of - SCC _ _ -> rhs -- leave it - Con _ _ -> rhs - _ -> mkUseLam usevars (mkLam tyvars vars - (SCC (mkAutoCC binder mod_name grp_name IsNotCafCC) body)) -\end{code} diff --git a/ghc/compiler/profiling/SCCfinal.lhs b/ghc/compiler/profiling/SCCfinal.lhs index 7a61c5520d..89c4062197 100644 --- a/ghc/compiler/profiling/SCCfinal.lhs +++ b/ghc/compiler/profiling/SCCfinal.lhs @@ -32,11 +32,12 @@ IMP_Ubiq(){-uitous-} import StgSyn import CmdLineOpts ( opt_AutoSccsOnIndividualCafs, - opt_CompilingPrelude + opt_CompilingGhcInternals ) import CostCentre -- lots of things import Id ( idType, mkSysLocal, emptyIdSet ) import Maybes ( maybeToBool ) +import PprStyle -- ToDo: rm import SrcLoc ( mkUnknownSrcLoc ) import Type ( splitSigmaTy, getFunTy_maybe ) import UniqSupply ( getUnique, splitUniqSupply ) @@ -72,7 +73,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2) where do_auto_sccs_on_cafs = opt_AutoSccsOnIndividualCafs -- only use! - doing_prelude = opt_CompilingPrelude + doing_prelude = opt_CompilingGhcInternals all_cafs_cc = if doing_prelude then preludeCafsCostCentre @@ -81,7 +82,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds ---------- do_top_binding :: StgBinding -> MassageM StgBinding - do_top_binding (StgNonRec b rhs) + do_top_binding (StgNonRec b rhs) = do_top_rhs b rhs `thenMM` \ rhs' -> returnMM (StgNonRec b rhs') @@ -89,71 +90,75 @@ stgMassageForProfiling mod_name grp_name us stg_binds = mapMM do_pair pairs `thenMM` \ pairs2 -> returnMM (StgRec pairs2) where - do_pair (b, rhs) + do_pair (b, rhs) = do_top_rhs b rhs `thenMM` \ rhs2 -> returnMM (b, rhs2) ---------- do_top_rhs :: Id -> StgRhs -> MassageM StgRhs - do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc (StgCon con args lvs))) - -- top-level _scc_ around nothing but static data; toss it -- it's pointless + do_top_rhs binder (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs))) + | not (isSccCountCostCentre cc) + -- Trivial _scc_ around nothing but static data + -- Eliminate _scc_ ... and turn into StgRhsCon = returnMM (StgRhsCon dontCareCostCentre con args) - do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc expr)) - -- Top level CAF with explicit scc expression. Attach CAF - -- cost centre to StgRhsClosure and collect. - = let - calved_cc = cafifyCC cc - in - collectCC calved_cc `thenMM_` - set_prevailing_cc calved_cc ( - do_expr expr - ) `thenMM` \ expr' -> - returnMM (StgRhsClosure calved_cc bi fv u [] expr') - - do_top_rhs binder (StgRhsClosure cc bi fv u [] body) - | noCostCentreAttached cc || currentOrSubsumedCosts cc - -- Top level CAF without a cost centre attached: Collect - -- cost centre with binder name, if collecting CAFs. + do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr)) + | (noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc) + && not (isSccCountCostCentre cc) + -- Top level CAF without a cost centre attached + -- Attach and collect cc of trivial _scc_ in body + = collectCC cc `thenMM_` + set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' -> + returnMM (StgRhsClosure cc bi fv u [] expr') + + do_top_rhs binder (StgRhsClosure no_cc bi fv u [] body) + | noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc + -- Top level CAF without a cost centre attached + -- Attach CAF cc (collect if individual CAF ccs) = let - (did_something, cc2) + (collect, caf_cc) = if do_auto_sccs_on_cafs then (True, mkAutoCC binder mod_name grp_name IsCafCC) else (False, all_cafs_cc) in - (if did_something - then collectCC cc2 - else nopMM) `thenMM_` - set_prevailing_cc cc2 ( - do_expr body - ) `thenMM` \body2 -> - returnMM (StgRhsClosure cc2 bi fv u [] body2) - - do_top_rhs binder (StgRhsClosure _ bi fv u args body@(StgSCC ty cc expr)) - -- We blindly use the cc off the _scc_ - = set_prevailing_cc cc ( - do_expr body - ) `thenMM` \ body2 -> - returnMM (StgRhsClosure cc bi fv u args body2) + (if collect then collectCC caf_cc else nopMM) `thenMM_` + set_prevailing_cc caf_cc (do_expr body) `thenMM` \ body' -> + returnMM (StgRhsClosure caf_cc bi fv u [] body') + + do_top_rhs binder (StgRhsClosure cc bi fv u [] body) + -- Top level CAF with cost centre attached + -- Should this be a CAF cc ??? Does this ever occur ??? + = trace ("SCCfinal: CAF with cc: " ++ showCostCentre PprDebug False cc) $ + collectCC cc `thenMM_` + set_prevailing_cc cc (do_expr body) `thenMM` \ body' -> + returnMM (StgRhsClosure cc bi fv u [] body') + + do_top_rhs binder (StgRhsClosure _ bi fv u args (StgSCC ty cc expr)) + | not (isSccCountCostCentre cc) + -- Top level function with trivial _scc_ in body + -- Attach and collect cc of trivial _scc_ + = collectCC cc `thenMM_` + set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' -> + returnMM (StgRhsClosure cc bi fv u args expr') do_top_rhs binder (StgRhsClosure cc bi fv u args body) + -- Top level function, probably subsumed = let - cc2 = if noCostCentreAttached cc - then subsumedCosts -- it's not a thunk; it is top-level & arity > 0 - else cc - in - set_prevailing_cc cc2 ( - do_expr body - ) `thenMM` \ body' -> - returnMM (StgRhsClosure cc2 bi fv u args body') + (cc_closure, cc_body) + = if noCostCentreAttached cc + then (subsumedCosts, useCurrentCostCentre) + else (cc, cc) + in + set_prevailing_cc cc_body (do_expr body) `thenMM` \ body' -> + returnMM (StgRhsClosure cc_closure bi fv u args body') do_top_rhs binder (StgRhsCon cc con args) - = returnMM (StgRhsCon dontCareCostCentre con args) -- Top-level (static) data is not counted in heap -- profiles; nor do we set CCC from it; so we -- just slam in dontCareCostCentre + = returnMM (StgRhsCon dontCareCostCentre con args) ------ do_expr :: StgExpr -> MassageM StgExpr @@ -168,10 +173,8 @@ stgMassageForProfiling mod_name grp_name us stg_binds = boxHigherOrderArgs (StgPrim op) args lvs do_expr (StgSCC ty cc expr) -- Ha, we found a cost centre! - = collectCC cc `thenMM_` - set_prevailing_cc cc ( - do_expr expr - ) `thenMM` \ expr' -> + = collectCC cc `thenMM_` + set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' -> returnMM (StgSCC ty cc expr') do_expr (StgCase expr fv1 fv2 uniq alts) @@ -179,7 +182,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds do_alts alts `thenMM` \ alts' -> returnMM (StgCase expr' fv1 fv2 uniq alts') where - do_alts (StgAlgAlts ty alts def) + do_alts (StgAlgAlts ty alts def) = mapMM do_alt alts `thenMM` \ alts' -> do_deflt def `thenMM` \ def' -> returnMM (StgAlgAlts ty alts' def') @@ -188,7 +191,7 @@ stgMassageForProfiling mod_name grp_name us stg_binds = do_expr e `thenMM` \ e' -> returnMM (id, bs, use_mask, e') - do_alts (StgPrimAlts ty alts def) + do_alts (StgPrimAlts ty alts def) = mapMM do_alt alts `thenMM` \ alts' -> do_deflt def `thenMM` \ def' -> returnMM (StgPrimAlts ty alts' def') @@ -198,26 +201,24 @@ stgMassageForProfiling mod_name grp_name us stg_binds returnMM (l,e') do_deflt StgNoDefault = returnMM StgNoDefault - do_deflt (StgBindDefault b is_used e) + do_deflt (StgBindDefault b is_used e) = do_expr e `thenMM` \ e' -> returnMM (StgBindDefault b is_used e') do_expr (StgLet b e) - = set_prevailing_cc_maybe useCurrentCostCentre ( - do_binding b `thenMM` \ b' -> - do_expr e `thenMM` \ e' -> - returnMM (StgLet b' e') ) + = do_binding b `thenMM` \ b' -> + do_expr e `thenMM` \ e' -> + returnMM (StgLet b' e') do_expr (StgLetNoEscape lvs1 lvs2 rhs body) - = set_prevailing_cc_maybe useCurrentCostCentre ( - do_binding rhs `thenMM` \ rhs' -> - do_expr body `thenMM` \ body' -> - returnMM (StgLetNoEscape lvs1 lvs2 rhs' body') ) + = do_binding rhs `thenMM` \ rhs' -> + do_expr body `thenMM` \ body' -> + returnMM (StgLetNoEscape lvs1 lvs2 rhs' body') ---------- do_binding :: StgBinding -> MassageM StgBinding - do_binding (StgNonRec b rhs) + do_binding (StgNonRec b rhs) = do_rhs rhs `thenMM` \ rhs' -> returnMM (StgNonRec b rhs') @@ -231,33 +232,30 @@ stgMassageForProfiling mod_name grp_name us stg_binds do_rhs :: StgRhs -> MassageM StgRhs -- We play much the same game as we did in do_top_rhs above; - -- but we don't have to worry about cafifying, etc. - -- (ToDo: consolidate??) + -- but we don't have to worry about cafs etc. -{- Patrick says NO: it will mess up our counts (WDP 95/07) - do_rhs (StgRhsClosure _ bi fv u [] (StgSCC _ cc (StgCon con args lvs))) + do_rhs (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs))) + | not (isSccCountCostCentre cc) = collectCC cc `thenMM_` returnMM (StgRhsCon cc con args) --} - do_rhs (StgRhsClosure _ bi fv u args body@(StgSCC _ cc _)) - = set_prevailing_cc cc ( - do_expr body - ) `thenMM` \ body' -> - returnMM (StgRhsClosure cc bi fv u args body') + do_rhs (StgRhsClosure _ bi fv u args (StgSCC ty cc expr)) + | not (isSccCountCostCentre cc) + = collectCC cc `thenMM_` + set_prevailing_cc cc (do_expr expr) `thenMM` \ expr' -> + returnMM (StgRhsClosure cc bi fv u args expr') do_rhs (StgRhsClosure cc bi fv u args body) - = use_prevailing_cc_maybe cc `thenMM` \ cc2 -> - set_prevailing_cc cc2 ( - do_expr body - ) `thenMM` \ body' -> - returnMM (StgRhsClosure cc2 bi fv u args body') + = set_prevailing_cc_maybe cc $ \ cc' -> + set_lambda_cc (do_expr body) `thenMM` \ body' -> + returnMM (StgRhsClosure cc' bi fv u args body') do_rhs (StgRhsCon cc con args) - = use_prevailing_cc_maybe cc `thenMM` \ cc2 -> - returnMM (StgRhsCon cc2 con args) - -- ToDo: Box args (if lex) Pass back let binding??? - -- Nope: maybe later? WDP 94/06 + = set_prevailing_cc_maybe cc $ \ cc' -> + returnMM (StgRhsCon cc' con args) + + -- ToDo: Box args and sort out any let bindings ??? + -- Nope: maybe later? WDP 94/06 \end{code} %************************************************************************ @@ -269,53 +267,58 @@ stgMassageForProfiling mod_name grp_name us stg_binds \begin{code} boxHigherOrderArgs :: ([StgArg] -> StgLiveVars -> StgExpr) - -- An application lacking its arguments and live-var info - -> [StgArg] -- arguments which we might box + -- An application lacking its arguments and live-var info + -> [StgArg] -- arguments which we might box -> StgLiveVars -- live var info, which we do *not* try -- to maintain/update (setStgVarInfo will -- do that) -> MassageM StgExpr boxHigherOrderArgs almost_expr args live_vars - = mapAccumMM do_arg [] args `thenMM` \ (let_bindings, new_args) -> - get_prevailing_cc `thenMM` \ cc -> - returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings) + = returnMM (almost_expr args live_vars) + +{- No boxing for now ... should be moved to desugarer and preserved ... + +boxHigherOrderArgs almost_expr args live_vars + = get_prevailing_cc `thenMM` \ cc -> + if (isCafCC cc || isDictCC cc) then + -- no boxing required inside CAF/DICT cc + -- since CAF/DICT functions are subsumed anyway + returnMM (almost_expr args live_vars) + else + mapAccumMM do_arg [] args `thenMM` \ (let_bindings, new_args) -> + returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings) where --------------- - do_arg bindings atom@(StgLitArg _) = returnMM (bindings, atom) + do_arg bindings atom@(StgLitAtom _) = returnMM (bindings, atom) - do_arg bindings atom@(StgVarArg old_var) + do_arg bindings atom@(StgVarAtom old_var) = let - var_type = idType old_var + var_type = getIdUniType old_var in - if not (is_fun_type var_type) then - returnMM (bindings, atom) -- easy - else - -- make a trivial let-binding for the higher-order guy + if toplevelishId old_var && isFunType (getTauType var_type) + then + -- make a trivial let-binding for the top-level function getUniqueMM `thenMM` \ uniq -> let new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc in - returnMM ( (new_var, old_var) : bindings, StgVarArg new_var ) - where - is_fun_type ty - = case (splitSigmaTy ty) of { (_, _, tau_ty) -> - maybeToBool (getFunTy_maybe tau_ty) } + returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var ) + else + returnMM (bindings, atom) --------------- mk_stg_let :: CostCentre -> (Id, Id) -> StgExpr -> StgExpr mk_stg_let cc (new_var, old_var) body = let - rhs_body = StgApp (StgVarArg old_var) [{-no args-}] bOGUS_LVs - - rhs = StgRhsClosure cc - stgArgOcc -- safe... - [{-junk-}] Updatable [{-no args-}] rhs_body - in - StgLet (StgNonRec new_var rhs) body + rhs_body = StgApp (StgVarAtom old_var) [{-args-}] bOGUS_LVs + rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant [{-args-}] rhs_body + in + StgLet (StgNonRec new_var rhs_closure) body where - bOGUS_LVs = emptyIdSet -- easier to print than: panic "mk_stg_let: LVs" + bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs" +-} \end{code} %************************************************************************ @@ -341,7 +344,7 @@ initMM :: FAST_STRING -- module name, which we may consult -> MassageM a -> (CollectedCCs, a) -initMM mod_name init_us m = m mod_name subsumedCosts{-top-level-} init_us ([],[]) +initMM mod_name init_us m = m mod_name noCostCentre init_us ([],[]) thenMM :: MassageM a -> (a -> MassageM b) -> MassageM b thenMM_ :: MassageM a -> (MassageM b) -> MassageM b @@ -383,47 +386,38 @@ getUniqueMM mod scope_cc us ccs = (ccs, getUnique us) \end{code} \begin{code} -set_prevailing_cc, set_prevailing_cc_maybe - :: CostCentre -> MassageM a -> MassageM a - +set_prevailing_cc :: CostCentre -> MassageM a -> MassageM a set_prevailing_cc cc_to_set_to action mod scope_cc us ccs + -- set unconditionally = action mod cc_to_set_to us ccs - -- set unconditionally -set_prevailing_cc_maybe cc_to_set_to action mod scope_cc us ccs +set_prevailing_cc_maybe :: CostCentre -> (CostCentre -> MassageM a) -> MassageM a +set_prevailing_cc_maybe cc_to_try action mod scope_cc us ccs + -- set only if a real cost centre = let - -- used when switching from top-level to nested - -- scope; if we were chugging along as "subsumed", - -- we change to the new thing; otherwise we - -- keep what we had. + cc_to_use + = if noCostCentreAttached cc_to_try || currentOrSubsumedCosts cc_to_try + then scope_cc -- carry on as before + else cc_to_try -- use new cost centre + in + action cc_to_use mod cc_to_use us ccs +set_lambda_cc :: MassageM a -> MassageM a +set_lambda_cc action mod scope_cc us ccs + -- used when moving inside a lambda; + -- if we were chugging along as "caf/dict" we change to "ccc" + = let cc_to_use - = if (costsAreSubsumed scope_cc) - then cc_to_set_to - else scope_cc -- carry on as before + = if isCafCC scope_cc || isDictCC scope_cc + then useCurrentCostCentre + else scope_cc in action mod cc_to_use us ccs + get_prevailing_cc :: MassageM CostCentre get_prevailing_cc mod scope_cc us ccs = (ccs, scope_cc) -use_prevailing_cc_maybe :: CostCentre -> MassageM CostCentre - -use_prevailing_cc_maybe cc_to_try mod scope_cc us ccs - = let - cc_to_use - = if not (noCostCentreAttached cc_to_try - || currentOrSubsumedCosts cc_to_try) then - cc_to_try - else - uncalved_scope_cc - -- carry on as before, but be sure it - -- isn't marked as CAFish (we're - -- crossing a lambda...) - in - (ccs, cc_to_use) - where - uncalved_scope_cc = unCafifyCC scope_cc \end{code} \begin{code} |