X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprofiling%2FCostCentre.lhs;h=3ee46a88dbdfc549cde2d6362375514b1ccfb534;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=4253749fe694b9397c900eb8f31ca2047b88f3a4;hpb=7b0181919416d8f04324575b7e17031ca692f5b0;p=ghc-hetmet.git diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 4253749..3ee46a8 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -1,136 +1,150 @@ % -% (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} -#include "HsVersions.h" - module CostCentre ( - CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..), - noCostCentre, subsumedCosts, - useCurrentCostCentre, - noCostCentreAttached, costsAreSubsumed, - currentOrSubsumedCosts, - preludeCafsCostCentre, preludeDictsCostCentre, - overheadCostCentre, dontCareCostCentre, - - mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC, - cafifyCC, unCafifyCC, dupifyCC, - isCafCC, isDictCC, isDupdCC, - setToAbleCostCentre, + 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 -import Ubiq{-uitous-} - -import Id ( externallyVisibleId, GenId, Id(..) ) -import CStrings ( identToC, stringToC ) -import Maybes ( Maybe(..) ) -import Name ( showRdr, getOccName, RdrName ) -import Pretty ( ppShow, prettyToUn ) -import PprStyle ( PprStyle(..) ) -import UniqSet -import Unpretty -import Util +#include "HsVersions.h" -showId = panic "Whoops" -pprIdInUnfolding = panic "Whoops" +import Var ( Id ) +import Name ( getOccName, occNameFS ) +import Module ( Module, moduleFS ) +import Outputable +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. -data CcKind - = UserCC FAST_STRING -- Supplied by user: String is the cc name - | AutoCC Id -- CC -auto-magically inserted for that Id - | DictCC Id + | 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 + } + + | AllCafsCC { + cc_mod :: Module -- Name of module defining this CC. + } + +type CcName = FastString 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 @@ -141,364 +155,219 @@ 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 - -costsAreSubsumed SubsumedCosts = True -costsAreSubsumed _ = False - -currentOrSubsumedCosts SubsumedCosts = True -currentOrSubsumedCosts CurrentCC = True -currentOrSubsumedCosts _ = False - -mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre -mkUserCC cc_name module_name group_name - = NormalCC (UserCC cc_name) module_name group_name - AnOriginalCC IsNotCafCC{-might be changed-} +noCCS = NoCCS +subsumedCCS = SubsumedCCS +currentCCS = CurrentCCS +overheadCCS = OverheadCCS +dontCareCCS = DontCareCCS -mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre +noCostCentre = NoCostCentre +\end{code} -mkDictCC id module_name group_name is_caf - = NormalCC (DictCC id) module_name group_name - AnOriginalCC is_caf +Predicates on Cost-Centre Stacks -mkAutoCC id module_name group_name is_caf - = NormalCC (AutoCC id) module_name group_name - AnOriginalCC is_caf +\begin{code} +noCCSAttached NoCCS = True +noCCSAttached _ = False -mkAllCafsCC m g = AllCafsCC m g -mkAllDictsCC m g is_dupd - = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC) +noCCAttached NoCostCentre = True +noCCAttached _ = False -cafifyCC, unCafifyCC, dupifyCC :: CostCentre -> CostCentre +isCurrentCCS CurrentCCS = True +isCurrentCCS _ = False -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 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) - = NormalCC kind m g ADupdCC is_caf -dupifyCC cc = panic ("dupifyCC"++(showCostCentre PprDebug False cc)) - -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 - -isDupdCC (AllDictsCC _ _ ADupdCC) = True -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... +isSubsumedCCS SubsumedCCS = True +isSubsumedCCS _ = False -#if DEBUG -setToAbleCostCentre NoCostCentre = panic "setToAbleCC:NoCostCentre" -setToAbleCostCentre SubsumedCosts = panic "setToAbleCC:SubsumedCosts" -setToAbleCostCentre CurrentCC = panic "setToAbleCC:CurrentCC" -setToAbleCostCentre DontCareCC = panic "setToAbleCC:DontCareCC" -#endif +isCafCCS (PushCC cc NoCCS) = isCafCC cc +isCafCCS _ = False -setToAbleCostCentre OverheadCC = False -- see comments in type defn -setToAbleCostCentre other = not (isCafCC other || isDictCC other) +isDerivedFromCurrentCCS CurrentCCS = True +isDerivedFromCurrentCCS (PushCC _ ccs) = isDerivedFromCurrentCCS ccs +isDerivedFromCurrentCCS _ = False -ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool +currentOrSubsumedCCS SubsumedCCS = True +currentOrSubsumedCCS CurrentCCS = True +currentOrSubsumedCCS _ = False -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! +maybeSingletonCCS (PushCC cc NoCCS) = Just cc +maybeSingletonCCS _ = Nothing \end{code} +Building cost centres + \begin{code} -ccMentionsId :: CostCentre -> Maybe Id +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-} + } -ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id -ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id -ccMentionsId other = Nothing -\end{code} +mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre +mkAutoCC id mod is_caf + = NormalCC { cc_name = occNameFS (getOccName id), cc_mod = mod, + cc_is_dupd = OriginalCC, cc_is_caf = is_caf + } -\begin{code} -cmpCostCentre :: CostCentre -> CostCentre -> TAG_ +mkAllCafsCC m = AllCafsCC { cc_mod = m } -cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = _CMP_STRING_ m1 m2 -cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = _CMP_STRING_ m1 m2 -cmpCostCentre PreludeCafsCC PreludeCafsCC = EQ_ -cmpCostCentre (PreludeDictsCC _) (PreludeDictsCC _) = EQ_ -cmpCostCentre OverheadCC OverheadCC = EQ_ -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) - = case (_CMP_STRING_ m1 m2) of - LT_ -> LT_ - EQ_ -> cmp_kind k1 k2 - GT__ -> GT_ -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) = _CMP_STRING_ n1 n2 -cmp_kind (AutoCC i1) (AutoCC i2) = cmp i1 i2 -cmp_kind (DictCC i1) (DictCC i2) = cmp i1 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) -\end{code} +mkSingletonCCS :: CostCentre -> CostCentreStack +mkSingletonCCS cc = pushCCOnCCS cc NoCCS -\begin{code} -showCostCentre :: PprStyle -> Bool -> CostCentre -> String -uppCostCentre :: PprStyle -> Bool -> CostCentre -> Unpretty -uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty +pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack +pushCCOnCCS = PushCC -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) +dupifyCC cc = cc {cc_is_dupd = DupdCC} -showCostCentre sty print_as_string cc - = uppShow 80 (uppCostCentre sty print_as_string cc) +isCafCC, isDupdCC :: CostCentre -> Bool -uppCostCentre sty print_as_string NoCostCentre - | friendly_style sty = uppNil - | print_as_string = uppStr "\"NO_CC\"" - | otherwise = uppPStr SLIT("NO_CC") +isCafCC (AllCafsCC {}) = True +isCafCC (NormalCC {cc_is_caf = CafCC}) = True +isCafCC _ = False -uppCostCentre sty print_as_string SubsumedCosts - | print_as_string = uppStr "\"SUBSUMED\"" - | otherwise = uppPStr SLIT("CC_SUBSUMED") +isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True +isDupdCC _ = False -uppCostCentre sty print_as_string CurrentCC - | print_as_string = uppStr "\"CURRENT_CC\"" - | otherwise = uppPStr SLIT("CCC") +isSccCountCostCentre :: CostCentre -> Bool + -- Is this a cost-centre which records scc counts -uppCostCentre sty print_as_string OverheadCC - | print_as_string = uppStr "\"OVERHEAD\"" - | otherwise = uppPStr SLIT("CC_OVERHEAD") +#if DEBUG +isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre" +#endif +isSccCountCostCentre cc | isCafCC cc = False + | isDupdCC cc = False + | otherwise = True -uppCostCentre sty print_as_string cc - = let - prefix_CC = uppPStr SLIT("CC_") +sccAbleCostCentre :: CostCentre -> Bool + -- Is this a cost-centre which can be sccd ? - basic_thing -- (basic_thing, suffix_CAF) - = do_cc cc +#if DEBUG +sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre" +#endif +sccAbleCostCentre cc | isCafCC cc = False + | otherwise = True - basic_thing_string - = if friendly_sty then basic_thing else stringToC basic_thing - in - if print_as_string then - uppBesides [uppChar '"', uppStr basic_thing_string, uppChar '"'] - - else if friendly_sty then - uppStr basic_thing - else - uppBesides [prefix_CC, - prettyToUn (identToC (_PK_ basic_thing))] - 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" - do_cc (AllCafsCC m _) = if print_as_string - then "CAFs_in_..." - else "CAFs." ++ _UNPK_ m - do_cc (AllDictsCC m _ d) = do_dupd d ( - if print_as_string - then "DICTs_in_..." - else "DICTs." ++ _UNPK_ m) - do_cc PreludeCafsCC = if print_as_string - then "CAFs_in_..." - else "CAFs" - do_cc (PreludeDictsCC d) = do_dupd d ( - if print_as_string - then "DICTs_in_..." - else "DICTs") - - 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 - in - if friendly_sty then - do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name) ++ is_a_calf) - else - basic_kind - where - 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 "") - - do_id :: Id -> String - do_id id - = if print_as_string - 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 - -friendly_style sty -- i.e., probably for human consumption - = case sty of - PprForUser -> True - PprDebug -> True - PprShowAll -> True - _ -> False +ccFromThisModule :: CostCentre -> Module -> Bool +ccFromThisModule cc m = cc_mod cc == m \end{code} -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 -`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} -upp_cc_uf (PreludeDictsCC d) - = uppCat [uppPStr SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d] -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) - uppCat [pp_kind cc_kind, uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), - upp_dupd is_dupd, pp_caf is_caf] - where - pp_kind (UserCC name) = uppBeside (uppPStr SLIT("_USER_CC_ ")) (uppStr (show (_UNPK_ name))) - pp_kind (AutoCC id) = uppBeside (uppPStr SLIT("_AUTO_CC_ ")) (show_id id) - pp_kind (DictCC id) = uppBeside (uppPStr SLIT("_DICT_CC_ ")) (show_id id) +instance Eq CostCentre where + c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False } - show_id id = prettyToUn (pprIdInUnfolding no_in_scopes id) - where - no_in_scopes = emptyUniqSet +instance Ord CostCentre where + compare = cmpCostCentre - pp_caf IsCafCC = uppPStr SLIT("_CAF_CC_") - pp_caf IsNotCafCC = uppPStr SLIT("_N_") +cmpCostCentre :: CostCentre -> CostCentre -> Ordering -#ifdef DEBUG -upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other)) -#endif +cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2 -upp_dupd AnOriginalCC = uppPStr SLIT("_N_") -upp_dupd ADupdCC = uppPStr SLIT("_DUPD_CC_") -\end{code} +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) -\begin{code} -uppCostCentreDecl sty is_local cc -#ifdef DEBUG - | noCostCentreAttached cc || currentOrSubsumedCosts cc - = panic "uppCostCentreDecl: no cost centre!" - | otherwise -#endif - = if is_local then - uppBesides [ - uppStr "CC_DECLARE(", - upp_ident, uppComma, - uppCostCentre sty True {-as String!-} cc, uppComma, - pp_str mod_name, uppComma, - pp_str grp_name, uppComma, - uppStr is_subsumed, uppComma, - if externally_visible then uppNil else uppPStr SLIT("static"), - uppStr ");"] - else - uppBesides [ uppStr "CC_EXTERN(", upp_ident, uppStr ");" ] +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 - upp_ident = uppCostCentre sty False{-as identifier!-} cc + 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} - pp_str s = uppBeside (uppPStr (_CONS_ '"' s)) (uppChar '"') - pp_char c = uppBeside (uppPStr (_CONS_ '\'' c)) (uppChar '\'') +----------------------------------------------------------------------------- +Printing Cost Centre Stacks. - (mod_name, grp_name, is_subsumed, externally_visible) - = case cc of - AllCafsCC m g -> (m, g, cc_IS_CAF, True) +The outputable instance for CostCentreStack prints the CCS as a C +expression. - AllDictsCC m g _ -> (m, g, cc_IS_DICT, True) +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. - NormalCC (DictCC i) m g is_dupd is_caf - -> (m, g, cc_IS_DICT, externallyVisibleId i) +\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} - 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_SUBSUMED = "CC_IS_SUBSUMED" - cc_IS_BORING = "CC_IS_BORING" +----------------------------------------------------------------------------- +Printing Cost Centres. - do_caf IsCafCC = cc_IS_CAF - do_caf IsNotCafCC = cc_IS_BORING +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 +pprCostCentreCore (AllCafsCC {cc_mod = m}) + = text "__sccC" <+> braces (ppr_mod m) +pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, + cc_is_caf = caf, cc_is_dupd = dup}) + = text "__scc" <+> braces (hsep [ + ftext (zEncodeFS n), + ppr_mod m, + pp_dup dup, + pp_caf caf + ]) + +pp_dup DupdCC = char '!' +pp_dup other = empty + +pp_caf CafCC = text "__C" +pp_caf other = empty + +ppr_mod m = ftext (zEncodeFS (moduleFS m)) + +-- 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_mod m <> ftext (zEncodeFS 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:"; _ -> "" } ++ unpackFS name \end{code}