%
-% (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 <PreludeSomething> _). 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
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}
projects / ghc-hetmet.git / blobdiff