diff options
Diffstat (limited to 'compiler/profiling')
| -rw-r--r-- | compiler/profiling/CostCentre.lhs | 407 | ||||
| -rw-r--r-- | compiler/profiling/SCCfinal.lhs | 285 |
2 files changed, 205 insertions, 487 deletions
diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index 9e08831c97..8c2d938b8e 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -1,35 +1,20 @@ -% -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 -% -\section[CostCentre]{The @CostCentre@ data type} - \begin{code} -{-# OPTIONS -fno-warn-incomplete-patterns #-} --- The above warning supression flag is a temporary kludge. --- While working on this module you are encouraged to remove it and fix --- any warnings in the module. See --- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings --- for details {-# LANGUAGE BangPatterns, DeriveDataTypeable #-} module CostCentre ( - CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..), + CostCentre(..), CcName, IsCafCC(..), -- All abstract except to friend: ParseIface.y CostCentreStack, CollectedCCs, - noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS, + noCCS, currentCCS, dontCareCCS, noCostCentre, noCCAttached, - noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS, - isDerivedFromCurrentCCS, maybeSingletonCCS, - decomposeCCS, pushCCisNop, + noCCSAttached, isCurrentCCS, + maybeSingletonCCS, mkUserCC, mkAutoCC, mkAllCafsCC, - mkSingletonCCS, dupifyCC, pushCCOnCCS, - isCafCCS, isCafCC, - isSccCountCostCentre, - sccAbleCostCentre, - ccFromThisModule, + mkSingletonCCS, + isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule, pprCostCentreCore, costCentreUserName, @@ -37,81 +22,22 @@ module CostCentre ( cmpCostCentre -- used for removing dups in a list ) where -import Var ( Id ) +import Var import Name -import Module ( Module ) +import Module import Unique import Outputable import FastTypes import FastString -import Util ( thenCmp ) +import Util import Data.Data -\end{code} - -A Cost Centre Stack is something that can be attached to a closure. -This is either: - - - the current cost centre stack (CCCS) - - a pre-defined cost centre stack (there are several - pre-defined CCSs, see below). - -\begin{code} -data CostCentreStack - = NoCCS - | CurrentCCS -- Pinned on a let(rec)-bound - -- thunk/function/constructor, this says that the - -- cost centre to be attached to the object, when it - -- is allocated, is whatever is in the - -- current-cost-centre-stack register. - - | SubsumedCCS -- Cost centre stack for top-level subsumed functions - -- (CAFs get an AllCafsCC). - -- Its execution costs get subsumed into the caller. - -- This guy is *only* ever pinned on static closures, - -- and is *never* the cost centre for an SCC construct. - - | OverheadCCS -- We charge costs due to the profiling-system - -- doing its work to "overhead". - -- - -- Objects whose CCS is "Overhead" - -- have their *allocation* charged to "overhead", - -- but have the current CCS put into the object - -- itself. - - -- For example, if we transform "f g" to "let - -- g' = g in f g'" (so that something about - -- profiling works better...), then we charge - -- the *allocation* of g' to OverheadCCS, but - -- we put the cost-centre of the call to f - -- (i.e., current CCS) into the g' object. When - -- g' is entered, the CCS of the call - -- to f will be set. - - | DontCareCCS -- We need a CCS to stick in static closures - -- (for data), but we *don't* expect them to - -- accumulate any costs. But we still need - -- the placeholder. This CCS is it. - - | PushCC CostCentre CostCentreStack - -- These are used during code generation as the CCSs - -- attached to closures. A PushCC never appears as - -- the argument to an _scc_. - -- - -- The tail (2nd argument) is either NoCCS, indicating - -- a staticly allocated CCS, or CurrentCCS indicating - -- a dynamically created CCS. We only support - -- statically allocated *singleton* CCSs at the - -- moment, for the purposes of initialising the CCS - -- field of a CAF. - - deriving (Eq, Ord) -- needed for Ord on CLabel -\end{code} +----------------------------------------------------------------------------- +-- Cost Centres -A Cost Centre is the argument of an _scc_ expression. +-- | A Cost Centre is the argument of an _scc_ expression. -\begin{code} data CostCentre = NoCostCentre -- Having this constructor avoids having -- to use "Maybe CostCentre" all the time. @@ -119,8 +45,7 @@ data CostCentre | NormalCC { cc_name :: CcName, -- Name of the cost centre itself cc_mod :: Module, -- Name of module defining this CC. - cc_is_dupd :: IsDupdCC, -- see below - cc_is_caf :: IsCafCC -- see below + cc_is_caf :: IsCafCC -- see below } | AllCafsCC { @@ -130,113 +55,77 @@ data CostCentre type CcName = FastString -data IsDupdCC - = OriginalCC -- This says how the CC is *used*. Saying that - | DupdCC -- it is DupdCC doesn't make it a different - -- CC, just that it a sub-expression which has - -- been moved ("dupd") into a different scope. - -- - -- The point about a dupd SCC is that we don't - -- count entries to it, because it's not the - -- "original" one. - -- - -- In the papers, it's called "SCCsub", - -- i.e. SCCsub CC == SCC DupdCC, - -- but we are trying to avoid confusion between - -- "subd" and "subsumed". So we call the former - -- "dupd". - deriving (Data, Typeable) - -data IsCafCC = CafCC | NotCafCC - deriving (Data, Typeable) - --- synonym for triple which describes the cost centre info in the generated --- code for a module. -type CollectedCCs - = ( [CostCentre] -- local cost-centres that need to be decl'd - , [CostCentre] -- "extern" cost-centres - , [CostCentreStack] -- pre-defined "singleton" cost centre stacks - ) -\end{code} +data IsCafCC = NotCafCC | CafCC + deriving (Eq, Ord, Data, Typeable) -WILL: Would there be any merit to recording ``I am now using a -cost-centre from another module''? I don't know if this would help a -user; it might be interesting to us to know how much computation is -being moved across module boundaries. +noCostCentre :: CostCentre +noCostCentre = NoCostCentre -SIMON: Maybe later... -\begin{code} -noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS :: CostCentreStack +instance Eq CostCentre where + c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } -noCCS = NoCCS -subsumedCCS = SubsumedCCS -currentCCS = CurrentCCS -overheadCCS = OverheadCCS -dontCareCCS = DontCareCCS +instance Ord CostCentre where + compare = cmpCostCentre -noCostCentre :: CostCentre -noCostCentre = NoCostCentre -\end{code} +cmpCostCentre :: CostCentre -> CostCentre -> Ordering -Predicates on Cost-Centre Stacks +cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) + = m1 `compare` m2 -\begin{code} -noCCSAttached :: CostCentreStack -> Bool -noCCSAttached NoCCS = True -noCCSAttached _ = False +cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1}) + (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2}) + -- first key is module name, then the name, then the cafness + = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `compare` c2) -noCCAttached :: CostCentre -> Bool -noCCAttached NoCostCentre = True -noCCAttached _ = False +cmpCostCentre other_1 other_2 + = let + !tag1 = tag_CC other_1 + !tag2 = tag_CC other_2 + in + if tag1 <# tag2 then LT else GT + where + tag_CC NoCostCentre = _ILIT(0) + tag_CC (NormalCC {}) = _ILIT(1) + tag_CC (AllCafsCC {}) = _ILIT(2) -isCurrentCCS :: CostCentreStack -> Bool -isCurrentCCS CurrentCCS = True -isCurrentCCS _ = False -isSubsumedCCS :: CostCentreStack -> Bool -isSubsumedCCS SubsumedCCS = True -isSubsumedCCS _ = False +----------------------------------------------------------------------------- +-- Predicates on CostCentre -isCafCCS :: CostCentreStack -> Bool -isCafCCS (PushCC cc NoCCS) = isCafCC cc -isCafCCS _ = False +isCafCC :: CostCentre -> Bool +isCafCC (AllCafsCC {}) = True +isCafCC (NormalCC {cc_is_caf = CafCC}) = True +isCafCC _ = False -isDerivedFromCurrentCCS :: CostCentreStack -> Bool -isDerivedFromCurrentCCS CurrentCCS = True -isDerivedFromCurrentCCS (PushCC _ ccs) = isDerivedFromCurrentCCS ccs -isDerivedFromCurrentCCS _ = False +-- | Is this a cost-centre which records scc counts +isSccCountCC :: CostCentre -> Bool +isSccCountCC cc | isCafCC cc = False + | otherwise = True -currentOrSubsumedCCS :: CostCentreStack -> Bool -currentOrSubsumedCCS SubsumedCCS = True -currentOrSubsumedCCS CurrentCCS = True -currentOrSubsumedCCS _ = False +-- | Is this a cost-centre which can be sccd ? +sccAbleCC :: CostCentre -> Bool +sccAbleCC NoCostCentre = panic "sccAbleCC:NoCostCentre" +sccAbleCC cc | isCafCC cc = False + | otherwise = True -maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre -maybeSingletonCCS (PushCC cc NoCCS) = Just cc -maybeSingletonCCS _ = Nothing +ccFromThisModule :: CostCentre -> Module -> Bool +ccFromThisModule cc m = cc_mod cc == m -pushCCisNop :: CostCentre -> CostCentreStack -> Bool --- (pushCCisNop cc ccs) = True => pushing cc on ccs is a no-op --- It's safe to return False, but the optimiser can remove --- redundant pushes if this function returns True. -pushCCisNop cc (PushCC cc' _) = cc == cc' -pushCCisNop _ _ = False -\end{code} -Building cost centres +----------------------------------------------------------------------------- +-- Building cost centres -\begin{code} mkUserCC :: FastString -> Module -> CostCentre mkUserCC cc_name mod = NormalCC { cc_name = cc_name, cc_mod = mod, - cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-} + cc_is_caf = NotCafCC {-might be changed-} } mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre mkAutoCC id mod is_caf = NormalCC { cc_name = str, cc_mod = mod, - cc_is_dupd = OriginalCC, cc_is_caf = is_caf + cc_is_caf = is_caf } where name = getName id @@ -249,153 +138,126 @@ mkAutoCC id mod is_caf ftext (occNameFS (getOccName id)) <> char '_' <> pprUnique (getUnique name) mkAllCafsCC :: Module -> CostCentre -mkAllCafsCC m = AllCafsCC { cc_mod = m } +mkAllCafsCC m = AllCafsCC { cc_mod = m } +----------------------------------------------------------------------------- +-- Cost Centre Stacks +-- | A Cost Centre Stack is something that can be attached to a closure. +-- This is either: +-- +-- * the current cost centre stack (CCCS) +-- * a pre-defined cost centre stack (there are several +-- pre-defined CCSs, see below). -mkSingletonCCS :: CostCentre -> CostCentreStack -mkSingletonCCS cc = pushCCOnCCS cc NoCCS +data CostCentreStack + = NoCCS -pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack -pushCCOnCCS = PushCC + | CurrentCCS -- Pinned on a let(rec)-bound + -- thunk/function/constructor, this says that the + -- cost centre to be attached to the object, when it + -- is allocated, is whatever is in the + -- current-cost-centre-stack register. -dupifyCC :: CostCentre -> CostCentre -dupifyCC cc = cc {cc_is_dupd = DupdCC} + | DontCareCCS -- We need a CCS to stick in static closures + -- (for data), but we *don't* expect them to + -- accumulate any costs. But we still need + -- the placeholder. This CCS is it. -isCafCC, isDupdCC :: CostCentre -> Bool + | SingletonCCS CostCentre -isCafCC (AllCafsCC {}) = True -isCafCC (NormalCC {cc_is_caf = CafCC}) = True -isCafCC _ = False + deriving (Eq, Ord) -- needed for Ord on CLabel -isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True -isDupdCC _ = False -isSccCountCostCentre :: CostCentre -> Bool - -- Is this a cost-centre which records scc counts +-- synonym for triple which describes the cost centre info in the generated +-- code for a module. +type CollectedCCs + = ( [CostCentre] -- local cost-centres that need to be decl'd + , [CostCentre] -- "extern" cost-centres + , [CostCentreStack] -- pre-defined "singleton" cost centre stacks + ) -#if DEBUG -isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre" -#endif -isSccCountCostCentre cc | isCafCC cc = False - | isDupdCC cc = False - | otherwise = True -sccAbleCostCentre :: CostCentre -> Bool - -- Is this a cost-centre which can be sccd ? +noCCS, currentCCS, dontCareCCS :: CostCentreStack -#if DEBUG -sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre" -#endif -sccAbleCostCentre cc | isCafCC cc = False - | otherwise = True +noCCS = NoCCS +currentCCS = CurrentCCS +dontCareCCS = DontCareCCS -ccFromThisModule :: CostCentre -> Module -> Bool -ccFromThisModule cc m = cc_mod cc == m -\end{code} +----------------------------------------------------------------------------- +-- Predicates on Cost-Centre Stacks -\begin{code} -instance Eq CostCentre where - c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } +noCCSAttached :: CostCentreStack -> Bool +noCCSAttached NoCCS = True +noCCSAttached _ = False -instance Ord CostCentre where - compare = cmpCostCentre +noCCAttached :: CostCentre -> Bool +noCCAttached NoCostCentre = True +noCCAttached _ = False -cmpCostCentre :: CostCentre -> CostCentre -> Ordering +isCurrentCCS :: CostCentreStack -> Bool +isCurrentCCS CurrentCCS = True +isCurrentCCS _ = False -cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2 +isCafCCS :: CostCentreStack -> Bool +isCafCCS (SingletonCCS cc) = isCafCC cc +isCafCCS _ = False -cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1}) - (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2}) - -- first key is module name, then we use "kinds" (which include - -- names) and finally the caf flag - = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2) +maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre +maybeSingletonCCS (SingletonCCS cc) = Just cc +maybeSingletonCCS _ = Nothing -cmpCostCentre other_1 other_2 - = let - !tag1 = tag_CC other_1 - !tag2 = tag_CC other_2 - in - if tag1 <# tag2 then LT else GT - where - tag_CC (NormalCC {}) = _ILIT(1) - tag_CC (AllCafsCC {}) = _ILIT(2) +mkSingletonCCS :: CostCentre -> CostCentreStack +mkSingletonCCS cc = SingletonCCS cc --- TODO: swap order of IsCafCC, add deriving Ord -cmp_caf :: IsCafCC -> IsCafCC -> Ordering -cmp_caf NotCafCC CafCC = LT -cmp_caf NotCafCC NotCafCC = EQ -cmp_caf CafCC CafCC = EQ -cmp_caf CafCC NotCafCC = GT - -decomposeCCS :: CostCentreStack -> ([CostCentre],CostCentreStack) -decomposeCCS (PushCC cc ccs) = (cc:more, ccs') - where (more,ccs') = decomposeCCS ccs -decomposeCCS ccs = ([],ccs) -\end{code} ----------------------------------------------------------------------------- -Printing Cost Centre Stacks. - -The outputable instance for CostCentreStack prints the CCS as a C -expression. +-- Printing Cost Centre Stacks. -NOTE: Not all cost centres are suitable for using in a static -initializer. In particular, the PushCC forms where the tail is CCCS -may only be used in inline C code because they expand to a -non-constant C expression. +-- The outputable instance for CostCentreStack prints the CCS as a C +-- expression. -\begin{code} instance Outputable CostCentreStack where ppr NoCCS = ptext (sLit "NO_CCS") ppr CurrentCCS = ptext (sLit "CCCS") - ppr OverheadCCS = ptext (sLit "CCS_OVERHEAD") - ppr DontCareCCS = ptext (sLit "CCS_DONT_CARE") - ppr SubsumedCCS = ptext (sLit "CCS_SUBSUMED") - ppr (PushCC cc NoCCS) = ppr cc <> ptext (sLit "_ccs") - ppr (PushCC cc ccs) = ptext (sLit "PushCostCentre") <> - parens (ppr ccs <> comma <> - parens(ptext (sLit "void *")) <> ppr cc) -\end{code} - ------------------------------------------------------------------------------ -Printing Cost Centres. - -There are several different ways in which we might want to print a -cost centre: + ppr DontCareCCS = ptext (sLit "CCS_DONT_CARE") + ppr (SingletonCCS cc) = ppr cc <> ptext (sLit "_ccs") - - the name of the cost centre, for profiling output (a C string) - - the label, i.e. C label for cost centre in .hc file. - - the debugging name, for output in -ddump things - - the interface name, for printing in _scc_ exprs in iface files. -The last 3 are derived from costCentreStr below. The first is given -by costCentreName. +----------------------------------------------------------------------------- +-- Printing Cost Centres +-- +-- There are several different ways in which we might want to print a +-- cost centre: +-- +-- - the name of the cost centre, for profiling output (a C string) +-- - the label, i.e. C label for cost centre in .hc file. +-- - the debugging name, for output in -ddump things +-- - the interface name, for printing in _scc_ exprs in iface files. +-- +-- The last 3 are derived from costCentreStr below. The first is given +-- by costCentreName. -\begin{code} instance Outputable CostCentre where ppr cc = getPprStyle $ \ sty -> if codeStyle sty then ppCostCentreLbl cc else text (costCentreUserName cc) --- Printing in an interface file or in Core generally +-- Printing in Core pprCostCentreCore :: CostCentre -> SDoc +pprCostCentreCore NoCostCentre + = text "__no_cc" pprCostCentreCore (AllCafsCC {cc_mod = m}) = text "__sccC" <+> braces (ppr m) pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, - cc_is_caf = caf, cc_is_dupd = dup}) + cc_is_caf = caf}) = text "__scc" <+> braces (hsep [ ftext (zEncodeFS n), ppr m, - pp_dup dup, - pp_caf caf + pp_caf caf ]) -pp_dup :: IsDupdCC -> SDoc -pp_dup DupdCC = char '!' -pp_dup _ = empty - pp_caf :: IsCafCC -> SDoc pp_caf CafCC = text "__C" pp_caf _ = empty @@ -415,4 +277,5 @@ costCentreUserName (NoCostCentre) = "NO_CC" costCentreUserName (AllCafsCC {}) = "CAF" costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf}) = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ unpackFS name + \end{code} diff --git a/compiler/profiling/SCCfinal.lhs b/compiler/profiling/SCCfinal.lhs index f09b291db7..96a21eb056 100644 --- a/compiler/profiling/SCCfinal.lhs +++ b/compiler/profiling/SCCfinal.lhs @@ -1,27 +1,23 @@ % % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % -\section[SCCfinal]{Modify and collect code generation for final STG program} - -This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg. - - - Traverses the STG program collecting the cost centres. These are required - to declare the cost centres at the start of code generation. - - Note: because of cross-module unfolding, some of these cost centres may be - from other modules. But will still have to give them "extern" - declarations. - - - Puts on CAF cost-centres if the user has asked for individual CAF - cost-centres. - - - Ditto for individual DICT cost-centres. - - - Boxes top-level inherited functions passed as arguments. +\begin{code} +----------------------------------------------------------------------------- +-- Modify and collect code generation for final STG program - - "Distributes" given cost-centres to all as-yet-unmarked RHSs. +{- + This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg. + + - Traverses the STG program collecting the cost centres. These are required + to declare the cost centres at the start of code generation. + + Note: because of cross-module unfolding, some of these cost centres may be + from other modules. + + - Puts on CAF cost-centres if the user has asked for individual CAF + cost-centres. +-} -\begin{code} module SCCfinal ( stgMassageForProfiling ) where #include "HsVersions.h" @@ -32,17 +28,12 @@ import CostCentre -- lots of things import Id import Name import Module -import UniqSupply ( splitUniqSupply, UniqSupply ) -#ifdef PROF_DO_BOXING -import UniqSupply ( uniqFromSupply ) -#endif -import VarSet +import UniqSupply ( UniqSupply ) import ListSetOps ( removeDups ) import Outputable import DynFlags -\end{code} -\begin{code} + stgMassageForProfiling :: DynFlags -> Module -- module name @@ -50,16 +41,15 @@ stgMassageForProfiling -> [StgBinding] -- input -> (CollectedCCs, [StgBinding]) -stgMassageForProfiling dflags mod_name us stg_binds +stgMassageForProfiling dflags mod_name _us stg_binds = let ((local_ccs, extern_ccs, cc_stacks), stg_binds2) - = initMM mod_name us (do_top_bindings stg_binds) + = initMM mod_name (do_top_bindings stg_binds) (fixed_ccs, fixed_cc_stacks) = if dopt Opt_AutoSccsOnIndividualCafs dflags then ([],[]) -- don't need "all CAFs" CC - -- (for Prelude, we use PreludeCC) else ([all_cafs_cc], [all_cafs_ccs]) local_ccs_no_dups = fst (removeDups cmpCostCentre local_ccs) @@ -80,17 +70,14 @@ stgMassageForProfiling dflags mod_name us stg_binds do_top_bindings (StgNonRec b rhs : bs) = do rhs' <- do_top_rhs b rhs - addTopLevelIshId b $ do - bs' <- do_top_bindings bs - return (StgNonRec b rhs' : bs') - - do_top_bindings (StgRec pairs : bs) - = addTopLevelIshIds binders $ do - pairs2 <- mapM do_pair pairs - bs' <- do_top_bindings bs - return (StgRec pairs2 : bs') + bs' <- do_top_bindings bs + return (StgNonRec b rhs' : bs') + + do_top_bindings (StgRec pairs : bs) = do + pairs2 <- mapM do_pair pairs + bs' <- do_top_bindings bs + return (StgRec pairs2 : bs') where - binders = map fst pairs do_pair (b, rhs) = do rhs2 <- do_top_rhs b rhs return (b, rhs2) @@ -98,27 +85,17 @@ stgMassageForProfiling dflags mod_name us stg_binds ---------- do_top_rhs :: Id -> StgRhs -> MassageM StgRhs - do_top_rhs _ (StgRhsClosure _ _ _ _ _ [] (StgSCC cc (StgConApp con args))) - | not (isSccCountCostCentre cc) && not (isDllConApp dflags con args) + do_top_rhs _ (StgRhsClosure _ _ _ _ _ [] + (StgSCC _cc False{-not tick-} _push (StgConApp con args))) + | not (isDllConApp dflags con args) -- Trivial _scc_ around nothing but static data -- Eliminate _scc_ ... and turn into StgRhsCon -- isDllConApp checks for LitLit args too = return (StgRhsCon dontCareCCS con args) -{- Can't do this one with cost-centre stacks: --SDM - do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr)) - | (noCCSAttached no_cc || currentOrSubsumedCCS no_cc) - && not (isSccCountCostCentre cc) - -- Top level CAF without a cost centre attached - -- Attach and collect cc of trivial _scc_ in body - = do collectCC cc - expr' <- set_prevailing_cc cc (do_expr expr) - return (StgRhsClosure cc bi fv u [] expr') --} - - do_top_rhs binder (StgRhsClosure no_cc bi fv u srt [] body) - | noCCSAttached no_cc || currentOrSubsumedCCS no_cc = do + do_top_rhs binder (StgRhsClosure _ bi fv u srt [] body) + = do -- Top level CAF without a cost centre attached -- Attach CAF cc (collect if individual CAF ccs) caf_ccs <- if dopt Opt_AutoSccsOnIndividualCafs dflags @@ -135,22 +112,12 @@ stgMassageForProfiling dflags mod_name us stg_binds return ccs else return all_cafs_ccs - body' <- set_prevailing_cc caf_ccs (do_expr body) + body' <- do_expr body return (StgRhsClosure caf_ccs bi fv u srt [] body') - do_top_rhs _ (StgRhsClosure cc _ _ _ _ [] _) - -- Top level CAF with cost centre attached - -- Should this be a CAF cc ??? Does this ever occur ??? - = pprPanic "SCCfinal: CAF with cc:" (ppr cc) - - do_top_rhs _ (StgRhsClosure no_ccs bi fv u srt args body) - -- Top level function, probably subsumed - | noCCSAttached no_ccs - = do body' <- set_lambda_cc (do_expr body) - return (StgRhsClosure subsumedCCS bi fv u srt args body') - - | otherwise - = pprPanic "SCCfinal: CAF with cc:" (ppr no_ccs) + do_top_rhs _ (StgRhsClosure _no_ccs bi fv u srt args body) + = do body' <- do_expr body + return (StgRhsClosure dontCareCCS bi fv u srt args body') do_top_rhs _ (StgRhsCon _ con args) -- Top-level (static) data is not counted in heap @@ -164,18 +131,18 @@ stgMassageForProfiling dflags mod_name us stg_binds do_expr (StgLit l) = return (StgLit l) do_expr (StgApp fn args) - = boxHigherOrderArgs (StgApp fn) args + = return (StgApp fn args) do_expr (StgConApp con args) - = boxHigherOrderArgs (\args -> StgConApp con args) args + = return (StgConApp con args) do_expr (StgOpApp con args res_ty) - = boxHigherOrderArgs (\args -> StgOpApp con args res_ty) args + = return (StgOpApp con args res_ty) - do_expr (StgSCC cc expr) = do -- Ha, we found a cost centre! + do_expr (StgSCC cc tick push expr) = do -- Ha, we found a cost centre! collectCC cc expr' <- do_expr expr - return (StgSCC cc expr') + return (StgSCC cc tick push expr') do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do expr' <- do_expr expr @@ -204,17 +171,14 @@ stgMassageForProfiling dflags mod_name us stg_binds do_let (StgNonRec b rhs) e = do rhs' <- do_rhs rhs - addTopLevelIshId b $ do - e' <- do_expr e - return (StgNonRec b rhs',e') - - do_let (StgRec pairs) e - = addTopLevelIshIds binders $ do - pairs' <- mapM do_pair pairs - e' <- do_expr e - return (StgRec pairs', e') + e' <- do_expr e + return (StgNonRec b rhs',e') + + do_let (StgRec pairs) e = do + pairs' <- mapM do_pair pairs + e' <- do_expr e + return (StgRec pairs', e') where - binders = map fst pairs do_pair (b, rhs) = do rhs2 <- do_rhs rhs return (b, rhs2) @@ -224,171 +188,62 @@ stgMassageForProfiling dflags mod_name us stg_binds -- We play much the same game as we did in do_top_rhs above; -- but we don't have to worry about cafs etc. -{- - do_rhs (StgRhsClosure closure_cc bi fv u [] (StgSCC ty cc (StgCon (DataCon con) args _))) - | not (isSccCountCostCentre cc) + -- throw away the SCC if we don't have to count entries. This + -- is a little bit wrong, because we're attributing the + -- allocation of the constructor to the wrong place (XXX) + -- We should really attach (PushCC cc CurrentCCS) to the rhs, + -- but need to reinstate PushCC for that. + do_rhs (StgRhsClosure _closure_cc _bi _fv _u _srt [] + (StgSCC cc False{-not tick-} _push (StgConApp con args))) = do collectCC cc - return (StgRhsCon cc con args) --} + return (StgRhsCon currentCCS con args) do_rhs (StgRhsClosure _ bi fv u srt args expr) = do - (expr', ccs) <- slurpSCCs currentCCS expr - expr'' <- do_expr expr' - return (StgRhsClosure ccs bi fv u srt args expr'') - where - slurpSCCs ccs (StgSCC cc e) - = do collectCC cc - slurpSCCs (cc `pushCCOnCCS` ccs) e - slurpSCCs ccs e - = return (e, ccs) + expr' <- do_expr expr + return (StgRhsClosure currentCCS bi fv u srt args expr') do_rhs (StgRhsCon _ con args) = return (StgRhsCon currentCCS con args) -\end{code} - -%************************************************************************ -%* * -\subsection{Boxing higher-order args} -%* * -%************************************************************************ - -Boxing is *turned off* at the moment, until we can figure out how to -do it properly in general. - -\begin{code} -boxHigherOrderArgs - :: ([StgArg] -> StgExpr) - -- An application lacking its arguments - -> [StgArg] -- arguments which we might box - -> MassageM StgExpr - -#ifndef PROF_DO_BOXING -boxHigherOrderArgs almost_expr args - = return (almost_expr args) -#else -boxHigherOrderArgs almost_expr args = do - ids <- getTopLevelIshIds - (let_bindings, new_args) <- mapAccumLM (do_arg ids) [] args - return (foldr (mk_stg_let currentCCS) (almost_expr new_args) let_bindings) - where - --------------- - - do_arg ids bindings arg@(StgVarArg old_var) - | (not (isLocalVar old_var) || elemVarSet old_var ids) - && isFunTy (dropForAlls var_type) - = do -- make a trivial let-binding for the top-level function - uniq <- getUniqueMM - let - new_var = mkSysLocal (fsLit "sf") uniq var_type - return ( (new_var, old_var) : bindings, StgVarArg new_var ) - where - var_type = idType old_var - - do_arg ids bindings arg = return (bindings, arg) - - --------------- - mk_stg_let :: CostCentreStack -> (Id, Id) -> StgExpr -> StgExpr - mk_stg_let cc (new_var, old_var) body - = let - rhs_body = StgApp old_var [{-args-}] - rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant NoSRT{-eeek!!!-} [{-args-}] rhs_body - in - StgLet (StgNonRec new_var rhs_closure) body - where - bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs" -#endif -\end{code} -%************************************************************************ -%* * -\subsection{Boring monad stuff for this} -%* * -%************************************************************************ +-- ----------------------------------------------------------------------------- +-- Boring monad stuff for this -\begin{code} newtype MassageM result = MassageM { unMassageM :: Module -- module name - -> CostCentreStack -- prevailing CostCentre - -- if none, subsumedCosts at top-level - -- currentCostCentre at nested levels - -> UniqSupply - -> VarSet -- toplevel-ish Ids for boxing -> CollectedCCs -> (CollectedCCs, result) } instance Monad MassageM where - return x = MassageM (\_ _ _ _ ccs -> (ccs, x)) + return x = MassageM (\_ ccs -> (ccs, x)) (>>=) = thenMM (>>) = thenMM_ -- the initMM function also returns the final CollectedCCs initMM :: Module -- module name, which we may consult - -> UniqSupply -> MassageM a -> (CollectedCCs, a) -initMM mod_name init_us (MassageM m) = m mod_name noCCS init_us emptyVarSet ([],[],[]) +initMM mod_name (MassageM m) = m mod_name ([],[],[]) thenMM :: MassageM a -> (a -> MassageM b) -> MassageM b thenMM_ :: MassageM a -> (MassageM b) -> MassageM b -thenMM expr cont = MassageM $ \mod scope_cc us ids ccs -> - case splitUniqSupply us of { (s1, s2) -> - case unMassageM expr mod scope_cc s1 ids ccs of { (ccs2, result) -> - unMassageM (cont result) mod scope_cc s2 ids ccs2 }} - -thenMM_ expr cont = MassageM $ \mod scope_cc us ids ccs -> - case splitUniqSupply us of { (s1, s2) -> - case unMassageM expr mod scope_cc s1 ids ccs of { (ccs2, _) -> - unMassageM cont mod scope_cc s2 ids ccs2 }} - -#ifdef PROF_DO_BOXING -getUniqueMM :: MassageM Unique -getUniqueMM = MassageM \mod scope_cc us ids ccs -> (ccs, uniqFromSupply us) -#endif - -addTopLevelIshId :: Id -> MassageM a -> MassageM a -addTopLevelIshId id scope - = MassageM $ \mod scope_cc us ids ccs -> - if isCurrentCCS scope_cc then unMassageM scope mod scope_cc us ids ccs - else unMassageM scope mod scope_cc us (extendVarSet ids id) ccs - -addTopLevelIshIds :: [Id] -> MassageM a -> MassageM a -addTopLevelIshIds [] cont = cont -addTopLevelIshIds (id:ids) cont - = addTopLevelIshId id (addTopLevelIshIds ids cont) - -#ifdef PROF_DO_BOXING -getTopLevelIshIds :: MassageM VarSet -getTopLevelIshIds = MassageM $ \_mod _scope_cc _us ids ccs -> (ccs, ids) -#endif -\end{code} +thenMM expr cont = MassageM $ \mod ccs -> + case unMassageM expr mod ccs of { (ccs2, result) -> + unMassageM (cont result) mod ccs2 } -The prevailing CCS is used to tell whether we're in a top-levelish -position, where top-levelish is defined as "not inside a lambda". -Prevailing CCs used to be used for something much more complicated, -I'm sure --SDM +thenMM_ expr cont = MassageM $ \mod ccs -> + case unMassageM expr mod ccs of { (ccs2, _) -> + unMassageM cont mod ccs2 } -\begin{code} -set_lambda_cc :: MassageM a -> MassageM a -set_lambda_cc action - = MassageM $ \mod _scope_cc us ids ccs - -> unMassageM action mod currentCCS us ids ccs - -set_prevailing_cc :: CostCentreStack -> MassageM a -> MassageM a -set_prevailing_cc cc_to_set_to action - = MassageM $ \mod _scope_cc us ids ccs - -> unMassageM action mod cc_to_set_to us ids ccs -\end{code} -\begin{code} collectCC :: CostCentre -> MassageM () collectCC cc - = MassageM $ \mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss) + = MassageM $ \mod_name (local_ccs, extern_ccs, ccss) -> ASSERT(not (noCCAttached cc)) if (cc `ccFromThisModule` mod_name) then ((cc : local_ccs, extern_ccs, ccss), ()) @@ -401,13 +256,13 @@ collectCC cc -- test prof001,prof002. collectNewCC :: CostCentre -> MassageM () collectNewCC cc - = MassageM $ \_mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss) + = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss) -> ((cc : local_ccs, extern_ccs, ccss), ()) collectCCS :: CostCentreStack -> MassageM () collectCCS ccs - = MassageM $ \_mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss) + = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss) -> ASSERT(not (noCCSAttached ccs)) ((local_ccs, extern_ccs, ccs : ccss), ()) \end{code} |