diff options
Diffstat (limited to 'compiler/profiling/CostCentre.lhs')
| -rw-r--r-- | compiler/profiling/CostCentre.lhs | 407 |
1 files changed, 135 insertions, 272 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} |