X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprofiling%2FCostCentre.lhs;h=46fd3c362b21a816ef34b136cce37b66e2e5305b;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=b814f89f1d00c850e7453e964efe32c202dd3052;hpb=8d2eb272d516cc9a992a0d6ccb7799289fa63276;p=ghc-hetmet.git diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index b814f89..46fd3c3 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -1,129 +1,152 @@ % -% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996 +% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998 % \section[CostCentre]{The @CostCentre@ data type} \begin{code} module CostCentre ( - CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..), - noCostCentre, subsumedCosts, - useCurrentCostCentre, - noCostCentreAttached, costsAreSubsumed, isCurrentCostCentre, - currentOrSubsumedCosts, - preludeCafsCostCentre, preludeDictsCostCentre, - overheadCostCentre, dontCareCostCentre, - - mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC, - cafifyCC, dupifyCC, - isCafCC, isDictCC, isDupdCC, + CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..), + -- All abstract except to friend: ParseIface.y + + CostCentreStack, + CollectedCCs, + noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS, + noCostCentre, noCCAttached, + noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS, + isDerivedFromCurrentCCS, maybeSingletonCCS, + decomposeCCS, + + mkUserCC, mkAutoCC, mkAllCafsCC, + mkSingletonCCS, dupifyCC, pushCCOnCCS, + isCafCCS, isCafCC, isSccCountCostCentre, sccAbleCostCentre, ccFromThisModule, - ccMentionsId, - uppCostCentre, uppCostCentreDecl, showCostCentre, -- printing + pprCostCentreCore, + costCentreUserName, cmpCostCentre -- used for removing dups in a list ) where #include "HsVersions.h" -import Id ( externallyVisibleId, GenId, Id ) -import CStrings ( identToC, stringToC ) -import Name ( OccName, getOccString, moduleString ) +import Var ( Id ) +import Name ( UserFS, EncodedFS, encodeFS, decode, + getOccName, occNameFS + ) +import Module ( Module, ModuleName, moduleName ) import Outputable -import Util ( panic, panic#, assertPanic, thenCmp ) - +import FastTypes +import FastString +import Util ( thenCmp ) \end{code} -\begin{code} -data CostCentre - = NoCostCentre -- Having this constructor avoids having - -- to use "Maybe CostCentre" all the time. +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). - | NormalCC CcKind -- CcKind will include a cost-centre name - FAST_STRING -- Name of module defining this CC. - FAST_STRING -- "Group" that this CC is in. - IsDupdCC -- see below - IsCafCC -- see below +\begin{code} +data CostCentreStack + = NoCCS - | CurrentCC -- 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 register. - -- This guy is *never* the cost centre for an SCC construct, - -- and is only used for *local* (non-top-level) definitions. + | 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. - | SubsumedCosts -- Cost centre for top-level subsumed functions + | 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. - | AllCafsCC FAST_STRING -- Ditto for CAFs. - FAST_STRING -- We record module and group names. - -- Again, one "big" CAF cc per module, where all - -- CAF costs are attributed unless the user asked for - -- per-individual-CAF cost attribution. - - | AllDictsCC FAST_STRING -- Ditto for dictionaries. - FAST_STRING -- We record module and group names. - -- Again, one "big" DICT cc per module, where all - -- DICT costs are attributed unless the user asked for - -- per-individual-DICT cost attribution. - IsDupdCC -- see below - - | OverheadCC -- We charge costs due to the profiling-system + | OverheadCCS -- We charge costs due to the profiling-system -- doing its work to "overhead". -- - -- Objects whose cost-centre is "Overhead" + -- Objects whose CCS is "Overhead" -- have their *allocation* charged to "overhead", - -- but have the current CC put into the object + -- 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 OverheadCC, but + -- the *allocation* of g' to OverheadCCS, but -- we put the cost-centre of the call to f - -- (i.e., current CC) into the g' object. When - -- g' is entered, the cost-centre of the call + -- (i.e., current CCS) into the g' object. When + -- g' is entered, the CCS of the call -- to f will be set. - | PreludeCafsCC -- In compiling the prelude, we do sometimes - | PreludeDictsCC -- need a CC to blame; i.e., when there's a CAF, - -- or other costs that really shouldn't be - -- subsumed/blamed-on-the-caller. These costs - -- should be *small*. We treat PreludeCafsCC - -- as if it were shorthand for - -- (AllCafsCC _). Analogously - -- for PreludeDictsCC... - IsDupdCC -- see below/above - - | DontCareCC -- We need a cost-centre to stick in static closures + | 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 CC is it. + -- 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} + +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. + + | NormalCC { + cc_name :: CcName, -- Name of the cost centre itself + cc_mod :: ModuleName, -- Name of module defining this CC. + cc_is_dupd :: IsDupdCC, -- see below + cc_is_caf :: IsCafCC -- see below + } + + | AllCafsCC { + cc_mod :: ModuleName -- Name of module defining this CC. + } -data CcKind - = UserCC FAST_STRING -- Supplied by user: String is the cc name - | AutoCC Id -- CC -auto-magically inserted for that Id - | DictCC Id +type CcName = EncodedFS data IsDupdCC - = AnOriginalCC -- This says how the CC is *used*. Saying that - | ADupdCC -- it is ADupdCC doesn't make it a different + = 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 ADupdCC, + -- i.e. SCCsub CC == SCC DupdCC, -- but we are trying to avoid confusion between -- "subd" and "subsumed". So we call the former -- "dupd". -data IsCafCC - = IsCafCC - | IsNotCafCC +data IsCafCC = CafCC | NotCafCC + +-- 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} WILL: Would there be any merit to recording ``I am now using a @@ -134,96 +157,90 @@ being moved across module boundaries. SIMON: Maybe later... \begin{code} -noCostCentre = NoCostCentre -subsumedCosts = SubsumedCosts -useCurrentCostCentre = CurrentCC -overheadCostCentre = OverheadCC -preludeCafsCostCentre = PreludeCafsCC -dontCareCostCentre = DontCareCC -preludeDictsCostCentre is_dupd - = PreludeDictsCC (if is_dupd then ADupdCC else AnOriginalCC) -noCostCentreAttached NoCostCentre = True -noCostCentreAttached _ = False +noCCS = NoCCS +subsumedCCS = SubsumedCCS +currentCCS = CurrentCCS +overheadCCS = OverheadCCS +dontCareCCS = DontCareCCS -isCurrentCostCentre CurrentCC = True -isCurrentCostCentre _ = False +noCostCentre = NoCostCentre +\end{code} -costsAreSubsumed SubsumedCosts = True -costsAreSubsumed _ = False +Predicates on Cost-Centre Stacks -currentOrSubsumedCosts SubsumedCosts = True -currentOrSubsumedCosts CurrentCC = True -currentOrSubsumedCosts _ = False +\begin{code} +noCCSAttached NoCCS = True +noCCSAttached _ = False -mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre +noCCAttached NoCostCentre = True +noCCAttached _ = False -mkUserCC cc_name module_name group_name - = NormalCC (UserCC cc_name) module_name group_name - AnOriginalCC IsNotCafCC{-might be changed-} +isCurrentCCS CurrentCCS = True +isCurrentCCS _ = False -mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre +isSubsumedCCS SubsumedCCS = True +isSubsumedCCS _ = False -mkDictCC id module_name group_name is_caf - = NormalCC (DictCC id) module_name group_name - AnOriginalCC is_caf +isCafCCS (PushCC cc NoCCS) = isCafCC cc +isCafCCS _ = False -mkAutoCC id module_name group_name is_caf - = NormalCC (AutoCC id) module_name group_name - AnOriginalCC is_caf +isDerivedFromCurrentCCS CurrentCCS = True +isDerivedFromCurrentCCS (PushCC _ ccs) = isDerivedFromCurrentCCS ccs +isDerivedFromCurrentCCS _ = False -mkAllCafsCC m g = AllCafsCC m g -mkAllDictsCC m g is_dupd - = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC) +currentOrSubsumedCCS SubsumedCCS = True +currentOrSubsumedCCS CurrentCCS = True +currentOrSubsumedCCS _ = False -cafifyCC, dupifyCC :: CostCentre -> CostCentre +maybeSingletonCCS (PushCC cc NoCCS) = Just cc +maybeSingletonCCS _ = Nothing +\end{code} -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 - where - not_a_calf_already IsCafCC = False - not_a_calf_already _ = True -cafifyCC cc = panic ("cafifyCC"++(showCostCentre False cc)) +Building cost centres + +\begin{code} +mkUserCC :: UserFS -> Module -> CostCentre +mkUserCC cc_name mod + = NormalCC { cc_name = encodeFS cc_name, cc_mod = moduleName mod, + cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-} + } + +mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre +mkAutoCC id mod is_caf + = NormalCC { cc_name = occNameFS (getOccName id), cc_mod = moduleName mod, + cc_is_dupd = OriginalCC, cc_is_caf = is_caf + } -dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC -dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC -dupifyCC (NormalCC kind m g is_dupd is_caf) - = NormalCC kind m g ADupdCC is_caf -dupifyCC cc = panic ("dupifyCC"++(showCostCentre False cc)) +mkAllCafsCC m = AllCafsCC { cc_mod = moduleName m } -isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool -isCafCC (AllCafsCC _ _) = True -isCafCC PreludeCafsCC = True -isCafCC (NormalCC _ _ _ _ IsCafCC) = True -isCafCC _ = False -isDictCC (AllDictsCC _ _ _) = True -isDictCC (PreludeDictsCC _) = True -isDictCC (NormalCC (DictCC _) _ _ _ _) = True -isDictCC _ = False +mkSingletonCCS :: CostCentre -> CostCentreStack +mkSingletonCCS cc = pushCCOnCCS cc NoCCS -isDupdCC (AllDictsCC _ _ ADupdCC) = True -isDupdCC (PreludeDictsCC ADupdCC) = True -isDupdCC (NormalCC _ _ _ ADupdCC _) = True -isDupdCC _ = False +pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack +pushCCOnCCS = PushCC + +dupifyCC cc = cc {cc_is_dupd = DupdCC} + +isCafCC, isDupdCC :: CostCentre -> Bool + +isCafCC (AllCafsCC {}) = True +isCafCC (NormalCC {cc_is_caf = CafCC}) = True +isCafCC _ = False + +isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True +isDupdCC _ = False isSccCountCostCentre :: CostCentre -> Bool -- Is this a cost-centre which records scc counts #if DEBUG isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre" -isSccCountCostCentre SubsumedCosts = panic "isSccCount:SubsumedCosts" -isSccCountCostCentre CurrentCC = panic "isSccCount:CurrentCC" -isSccCountCostCentre DontCareCC = panic "isSccCount:DontCareCC" #endif -isSccCountCostCentre OverheadCC = False isSccCountCostCentre cc | isCafCC cc = False | isDupdCC cc = False - | isDictCC cc = True | otherwise = True sccAbleCostCentre :: CostCentre -> Bool @@ -231,284 +248,127 @@ sccAbleCostCentre :: CostCentre -> Bool #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 - -ccFromThisModule (NormalCC _ m _ _ _) mod_name = m == mod_name -ccFromThisModule (AllCafsCC m _) mod_name = m == mod_name -ccFromThisModule (AllDictsCC m _ _) mod_name = m == mod_name -ccFromThisModule PreludeCafsCC _ = False -ccFromThisModule (PreludeDictsCC _) _ = False -ccFromThisModule OverheadCC _ = False -ccFromThisModule DontCareCC _ = False - -- shouldn't ask about any others! +ccFromThisModule :: CostCentre -> Module -> Bool +ccFromThisModule cc m = cc_mod cc == moduleName m \end{code} \begin{code} -ccMentionsId :: CostCentre -> Maybe Id +instance Eq CostCentre where + c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } -ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id -ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id -ccMentionsId other = Nothing -\end{code} +instance Ord CostCentre where + compare = cmpCostCentre -\begin{code} cmpCostCentre :: CostCentre -> CostCentre -> Ordering -cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = m1 `compare` m2 -cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = m1 `compare` m2 -cmpCostCentre PreludeCafsCC PreludeCafsCC = EQ -cmpCostCentre (PreludeDictsCC _) (PreludeDictsCC _) = EQ -cmpCostCentre OverheadCC OverheadCC = EQ -cmpCostCentre DontCareCC DontCareCC = EQ +cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2 -cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2) +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` (k1 `cmp_kind` k2) `thenCmp` (c1 `cmp_caf` c2) + = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2) cmpCostCentre other_1 other_2 = let tag1 = tag_CC other_1 tag2 = tag_CC other_2 in - if tag1 _LT_ tag2 then LT else GT - where - tag_CC (NormalCC _ _ _ _ _) = (ILIT(1) :: FAST_INT) - tag_CC (AllCafsCC _ _) = ILIT(2) - tag_CC (AllDictsCC _ _ _) = ILIT(3) - tag_CC PreludeCafsCC = ILIT(4) - tag_CC (PreludeDictsCC _) = ILIT(5) - tag_CC OverheadCC = ILIT(6) - tag_CC DontCareCC = ILIT(7) - - -- some BUG avoidance here... - tag_CC NoCostCentre = panic# "tag_CC:NoCostCentre" - tag_CC SubsumedCosts = panic# "tag_CC:SubsumedCosts" - tag_CC CurrentCC = panic# "tag_CC:SubsumedCosts" - - -cmp_kind (UserCC n1) (UserCC n2) = n1 `compare` n2 -cmp_kind (AutoCC i1) (AutoCC i2) = i1 `compare` i2 -cmp_kind (DictCC i1) (DictCC i2) = i1 `compare` i2 -cmp_kind other_1 other_2 - = let - tag1 = tag_CcKind other_1 - tag2 = tag_CcKind other_2 - in - if tag1 _LT_ tag2 then LT else GT - where - 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} -showCostCentre :: Bool -> CostCentre -> String -uppCostCentre :: Bool -> CostCentre -> SDoc -uppCostCentreDecl :: Bool -> CostCentre -> SDoc - -{- PprUnfolding is gone now -showCostCentre PprUnfolding print_as_string cc - = ASSERT(not print_as_string) -- we never "print as string w/ Unfolding" - ASSERT(not (noCostCentreAttached cc)) - ASSERT(not (currentOrSubsumedCosts cc)) - uppShow 80 (upp_cc_uf cc) --} - -showCostCentre print_as_string cc - = showSDoc (uppCostCentre print_as_string cc) - -uppCostCentre print_as_string NoCostCentre - | print_as_string = text "\"NO_CC\"" - | otherwise = ptext SLIT("NO_CC") - -uppCostCentre print_as_string SubsumedCosts - | print_as_string = text "\"SUBSUMED\"" - | otherwise = ptext SLIT("CC_SUBSUMED") - -uppCostCentre print_as_string CurrentCC - | print_as_string = text "\"CURRENT_CC\"" - | otherwise = ptext SLIT("CCC") - -uppCostCentre print_as_string OverheadCC - | print_as_string = text "\"OVERHEAD\"" - | otherwise = ptext SLIT("CC_OVERHEAD") - -uppCostCentre print_as_string cc - = getPprStyle $ \ sty -> - let - prefix_CC = ptext SLIT("CC_") - basic_thing = do_cc sty cc - basic_thing_string = stringToC basic_thing - in - if print_as_string then - hcat [char '"', text basic_thing_string, char '"'] - - else if (friendly_sty sty) then - text basic_thing - else - hcat [prefix_CC, identToC (_PK_ basic_thing)] + if tag1 <# tag2 then LT else GT where - friendly_sty sty = userStyle sty || debugStyle sty -- i.e. probably for human consumption - - do_cc sty DontCareCC = "DONT_CARE" - do_cc sty (AllCafsCC m _) = if print_as_string - then "CAFs_in_..." - else "CAFs." ++ _UNPK_ m - do_cc sty (AllDictsCC m _ d) = do_dupd sty d ( - if print_as_string - then "DICTs_in_..." - else "DICTs." ++ _UNPK_ m) - do_cc sty PreludeCafsCC = if print_as_string - then "CAFs_in_..." - else "CAFs" - do_cc sty (PreludeDictsCC d) = do_dupd sty d ( - if print_as_string - then "DICTs_in_..." - else "DICTs") - - do_cc sty (NormalCC kind mod_name grp_name is_dupd is_caf) - = let - basic_kind = do_kind kind - module_kind = do_caf is_caf (moduleString mod_name ++ '/': - basic_kind) - grp_str = if (_NULL_ grp_name) then mod_name else grp_name - full_kind = do_caf is_caf - (moduleString mod_name ++ - ('/' : _UNPK_ grp_str) ++ - ('/' : basic_kind)) - in - if (friendly_sty sty) then - do_dupd sty is_dupd full_kind - else if codeStyle sty && print_as_string then - {- - drop the module name when printing - out SCC label in CC declaration - -} - basic_kind - else - module_kind - where - do_caf IsCafCC ls = "CAF:" ++ ls - do_caf _ ls = ls - - do_kind (UserCC name) = _UNPK_ name - do_kind (AutoCC id) = do_id id ++ (if (friendly_sty sty) then "/AUTO" else "") - do_kind (DictCC id) = do_id id ++ (if (friendly_sty sty) then "/DICT" else "") - - {- - do_id is only applied in a (not print_as_string) context for local ids, - hence using the occurrence name is enough. - -} - do_id :: Id -> String - do_id id = getOccString id - - --------------- - do_dupd sty ADupdCC str = if (friendly_sty sty) then str ++ "/DUPD" else str - do_dupd _ _ str = str + tag_CC (NormalCC {}) = (_ILIT 1 :: FastInt) + tag_CC (AllCafsCC {}) = _ILIT 2 + +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 unfoldings is sufficiently weird that we do it separately. -This should only apply to CostCentres that can be ``set to'' (cf -@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. -\begin{code} -{- UNUSED -upp_cc_uf (PreludeDictsCC d) - = hsep [ptext SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d] -upp_cc_uf (AllDictsCC m g d) - = hsep [ptext SLIT("_ALL_DICTS_CC_"), - char '"',ptext m,char '"', - char '"',ptext g,char '"', - upp_dupd d] - -upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf) - = ASSERT(sccAbleCostCentre cc) - hsep [pp_kind cc_kind, - char '"', ptext m, char '"', - char '"', ptext g, char '"', - upp_dupd is_dupd, pp_caf is_caf] - where - pp_kind (UserCC name) = hcat [ptext SLIT("_USER_CC_ "), char '"', ptext name, char '"'] - pp_kind (AutoCC id) = (<>) (ptext SLIT("_AUTO_CC_ ")) (show_id id) - pp_kind (DictCC id) = (<>) (ptext SLIT("_DICT_CC_ ")) (show_id id) - - show_id id = pprIdInUnfolding {-no_in_scopes-} id - - pp_caf IsCafCC = ptext SLIT("_CAF_CC_") - pp_caf IsNotCafCC = ptext SLIT("_N_") - -#ifdef DEBUG -upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre True other)) -#endif +----------------------------------------------------------------------------- +Printing Cost Centre Stacks. -pprIdInUnfolding = panic "Whoops" +The outputable instance for CostCentreStack prints the CCS as a C +expression. -upp_dupd AnOriginalCC = ptext SLIT("_N_") -upp_dupd ADupdCC = ptext SLIT("_D_") --} -\end{code} +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. \begin{code} -uppCostCentreDecl is_local cc -#ifdef DEBUG - | noCostCentreAttached cc || currentOrSubsumedCosts cc - = panic "uppCostCentreDecl: no cost centre!" - | otherwise -#endif - = if is_local then - hcat [ - ptext SLIT("CC_DECLARE"),char '(', - upp_ident, comma, - uppCostCentre True {-as String!-} cc, comma, - pp_str mod_name, comma, - pp_str grp_name, comma, - text is_subsumed, comma, - if externally_visible {- || all_toplev_ids_visible -} - -- all_toplev stuff removed SLPJ Sept 97; - -- not sure this is right. - then empty - else ptext SLIT("static"), - text ");"] - else - hcat [ ptext SLIT("CC_EXTERN"),char '(', upp_ident, text ");" ] - where - upp_ident = uppCostCentre False{-as identifier!-} cc - - pp_str s = doubleQuotes (ptext s) +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} - (mod_name, grp_name, is_subsumed, externally_visible) - = case cc of - AllCafsCC m g -> (m, g, cc_IS_CAF, True) +----------------------------------------------------------------------------- +Printing Cost Centres. - AllDictsCC m g _ -> (m, g, cc_IS_DICT, True) +There are several different ways in which we might want to print a +cost centre: - NormalCC (DictCC i) m g is_dupd is_caf - -> (m, g, cc_IS_DICT, externallyVisibleId i) + - 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. - NormalCC x m g is_dupd is_caf - -> (m, g, do_caf is_caf, - case x of { UserCC _ -> True; AutoCC i -> externallyVisibleId i}) - where - cc_IS_CAF = "CC_IS_CAF" - cc_IS_DICT = "CC_IS_DICT" - cc_IS_BORING = "CC_IS_BORING" +The last 3 are derived from costCentreStr below. The first is given +by costCentreName. - do_caf IsCafCC = cc_IS_CAF - do_caf IsNotCafCC = cc_IS_BORING +\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 +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}) + = text "__scc" <+> braces (hsep [ + ftext n, + ppr m, + pp_dup dup, + pp_caf caf + ]) + +pp_dup DupdCC = char '!' +pp_dup other = empty + +pp_caf CafCC = text "__C" +pp_caf other = empty + + +-- Printing as a C label +ppCostCentreLbl (NoCostCentre) = text "NONE_cc" +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" +ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf}) + = ppr m <> ftext n <> + text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc" + +-- This is the name to go in the user-displayed string, +-- recorded in the cost centre declaration +costCentreUserName (NoCostCentre) = "NO_CC" +costCentreUserName (AllCafsCC {}) = "CAF" +costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf}) + = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (unpackFS name) \end{code}