\begin{code}
module CostCentre (
- CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..),
+ CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..),
+ -- All abstract except to friend: ParseIface.y
+
CostCentreStack,
+ CollectedCCs,
noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
- noCostCentre, noCCAttached,
+ noCostCentre,
noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS,
+ isDerivedFromCurrentCCS,
- mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC,
- mkSingletonCCS, cafifyCC, dupifyCC,
- isCafCC, isDictCC, isDupdCC, isEmptyCC, isCafCCS,
+ mkUserCC, mkAutoCC, mkAllCafsCC,
+ mkSingletonCCS, dupifyCC, pushCCOnCCS,
+ isCafCCS,
isSccCountCostCentre,
sccAbleCostCentre,
ccFromThisModule,
- ccMentionsId,
- pprCostCentreDecl, pprCostCentreStackDecl,
+ pprCostCentreDecl, pprCostCentreStackDecl, pprCostCentreCore,
cmpCostCentre -- used for removing dups in a list
) where
#include "HsVersions.h"
-import Var ( externallyVisibleId, GenId, Id )
-import CStrings ( identToC, stringToC )
-import Name ( getOccString )
+import Var ( Id )
+import Name ( UserFS, EncodedFS, encodeFS, decode,
+ getOccName, occNameFS
+ )
+import Module ( Module, ModuleName, moduleName,
+ moduleNameUserString
+ )
import Outputable
-import BasicTypes ( moduleString )
-import Util ( panic, assertPanic, thenCmp )
+import CStrings ( pprStringInCStyle )
+import FastTypes
+import FastString
+import Util ( thenCmp )
\end{code}
A Cost Centre Stack is something that can be attached to a closure.
-- accumulate any costs. But we still need
-- the placeholder. This CCS is it.
- | SingletonCCS CostCentre
- -- This is primarily for CAF cost centres, which
- -- are attached to top-level thunks right at the
- -- end of STG processing, before code generation.
- -- Hence, a CAF cost centre never appears as the
- -- argument of an _scc_.
- -- Also, we generate these singleton CCSs statically
- -- as part of code generation.
+ | 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}
= NoCostCentre -- Having this constructor avoids having
-- to use "Maybe CostCentre" all the time.
- | 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
-
- | 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
-
-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 :: 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.
+ }
+
+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.
--
-- "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
isSubsumedCCS SubsumedCCS = True
isSubsumedCCS _ = False
-isCafCCS (SingletonCCS cc) = isCafCC cc
+isCafCCS (PushCC cc NoCCS) = isCafCC cc
isCafCCS _ = False
-isDictCCS (SingletonCCS cc) = isDictCC cc
-isDictCCS _ = False
+isDerivedFromCurrentCCS CurrentCCS = True
+isDerivedFromCurrentCCS (PushCC _ ccs) = isDerivedFromCurrentCCS ccs
+isDerivedFromCurrentCCS _ = False
currentOrSubsumedCCS SubsumedCCS = True
currentOrSubsumedCCS CurrentCCS = True
Building cost centres
\begin{code}
-mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
+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-}
+ }
-mkUserCC cc_name module_name group_name
- = NormalCC (UserCC cc_name) module_name group_name
- AnOriginalCC IsNotCafCC{-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
+ }
-mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre
+mkAllCafsCC m = AllCafsCC { cc_mod = moduleName m }
-mkDictCC id module_name group_name is_caf
- = NormalCC (DictCC id) module_name group_name
- AnOriginalCC is_caf
-mkAutoCC id module_name group_name is_caf
- = NormalCC (AutoCC id) module_name group_name
- AnOriginalCC is_caf
-
-mkAllCafsCC m g = AllCafsCC m g
-mkAllDictsCC m g is_dupd
- = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC)
mkSingletonCCS :: CostCentre -> CostCentreStack
-mkSingletonCCS cc = SingletonCCS cc
-
-cafifyCC, dupifyCC :: CostCentre -> CostCentre
+mkSingletonCCS cc = pushCCOnCCS cc NoCCS
-cafifyCC cc@(AllDictsCC _ _ _) = cc -- ToDo ???
-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 = pprPanic "cafifyCC" (ppr cc)
+pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
+pushCCOnCCS = PushCC
-dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC
-dupifyCC (NormalCC kind m g is_dupd is_caf)
- = NormalCC kind m g ADupdCC is_caf
-dupifyCC cc = pprPanic "dupifyCC" (ppr cc)
+dupifyCC cc = cc {cc_is_dupd = DupdCC}
-isEmptyCC, isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
+isEmptyCC, isCafCC, isDupdCC :: CostCentre -> Bool
isEmptyCC (NoCostCentre) = True
isEmptyCC _ = False
-isCafCC (AllCafsCC _ _) = True
-isCafCC (NormalCC _ _ _ _ IsCafCC) = True
-isCafCC _ = False
+isCafCC (AllCafsCC {}) = True
+isCafCC (NormalCC {cc_is_caf = CafCC}) = True
+isCafCC _ = False
-isDictCC (AllDictsCC _ _ _) = True
-isDictCC (NormalCC (DictCC _) _ _ _ _) = True
-isDictCC _ = False
-
-isDupdCC (AllDictsCC _ _ ADupdCC) = True
-isDupdCC (NormalCC _ _ _ ADupdCC _) = True
-isDupdCC _ = False
+isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True
+isDupdCC _ = False
isSccCountCostCentre :: CostCentre -> Bool
-- Is this a cost-centre which records scc counts
#endif
isSccCountCostCentre cc | isCafCC cc = False
| isDupdCC cc = False
- | isDictCC cc = True
| otherwise = True
sccAbleCostCentre :: CostCentre -> Bool
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
-\end{code}
-
-\begin{code}
-ccMentionsId :: CostCentre -> Maybe Id
-
-ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id
-ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id
-ccMentionsId other = Nothing
+ccFromThisModule :: CostCentre -> Module -> Bool
+ccFromThisModule cc m = cc_mod cc == moduleName m
\end{code}
\begin{code}
cmpCostCentre :: CostCentre -> CostCentre -> Ordering
-cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = m1 `compare` m2
-cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = m1 `compare` m2
+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)
-
-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
+ if tag1 <# 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
+ 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
\end{code}
-----------------------------------------------------------------------------
Printing Cost Centre Stacks.
-There are two ways to print a CCS:
+The outputable instance for CostCentreStack prints the CCS as a C
+expression.
- - for debugging output (i.e. -ddump-whatever),
- - as a C label
+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}
instance Outputable CostCentreStack where
- ppr ccs = case ccs of
- NoCCS -> ptext SLIT("NO_CCS")
- CurrentCCS -> ptext SLIT("CCCS")
- OverheadCCS -> ptext SLIT("CCS_OVERHEAD")
- DontCareCCS -> ptext SLIT("CCS_DONTZuCARE")
- SubsumedCCS -> ptext SLIT("CCS_SUBSUMED")
- SingletonCCS cc ->
- getPprStyle $ \sty ->
- if (codeStyle sty)
- then ptext SLIT("CCS_") <>
- identToC (_PK_ (costCentreStr cc))
- else ptext SLIT("CCS.") <> text (costCentreStr cc)
-
+ 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 <> ppr cc)
+
+-- print the static declaration for a singleton CCS.
pprCostCentreStackDecl :: CostCentreStack -> SDoc
-
-pprCostCentreStackDecl ccs@(SingletonCCS cc)
- = let
- (mod_name, grp_name, is_subsumed, externally_visible) = get_cc_info cc
- in
- hcat [ ptext SLIT("CCS_DECLARE"), char '(',
+pprCostCentreStackDecl ccs@(PushCC cc NoCCS)
+ = hcat [ ptext SLIT("CCS_DECLARE"), char '(',
ppr ccs, comma, -- better be codeStyle
ppCostCentreLbl cc, comma,
- ptext is_subsumed, comma,
- if externally_visible
- then empty
- else ptext SLIT("static"),
+ empty, -- Now always externally visible
text ");"
]
instance Outputable CostCentre where
ppr cc = getPprStyle $ \ sty ->
if codeStyle sty
- then ppCostCentreLbl cc
- else
- if ifaceStyle sty
- then ppCostCentreIface cc
- else text (costCentreStr cc)
-
-ppCostCentreLbl cc = ptext SLIT("CC_") <> identToC (_PK_ (costCentreStr cc))
-ppCostCentreIface cc = doubleQuotes (text (costCentreStr cc))
-ppCostCentreName cc = doubleQuotes (text (stringToC (costCentreName cc)))
-
-costCentreStr (NoCostCentre) = "NO_CC"
-costCentreStr (AllCafsCC m _) = "CAFs." ++ _UNPK_ m
-costCentreStr (AllDictsCC m _ d) = "DICTs." ++ _UNPK_ m
-costCentreStr (NormalCC kind mod_name grp_name is_dupd is_caf)
- = case is_caf of { IsCafCC -> "CAF:"; _ -> "" }
- ++ moduleString mod_name
- ++ case kind of { UserCC name -> _UNPK_ name;
- AutoCC id -> getOccString id ++ "/AUTO";
- DictCC id -> getOccString id ++ "/DICT"
- }
- -- ToDo: group name
- ++ case is_dupd of { ADupdCC -> "/DUPD"; _ -> "" }
-
--- This is the name to go in the cost centre declaration
-costCentreName (NoCostCentre) = "NO_CC"
-costCentreName (AllCafsCC _ _) = "CAFs_in_..."
-costCentreName (AllDictsCC _ _ _) = "DICTs_in_..."
-costCentreName (NormalCC kind mod_name grp_name is_dupd is_caf)
- = case is_caf of { IsCafCC -> "CAF:"; _ -> "" }
- ++ case kind of { UserCC name -> _UNPK_ name;
- AutoCC id -> getOccString id;
- DictCC id -> getOccString id
- }
+ 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}
Cost Centre Declarations
= if is_local then
hcat [
ptext SLIT("CC_DECLARE"),char '(',
- cc_ident, comma,
- ppCostCentreName cc, comma,
- pp_str mod_name, comma,
- pp_str grp_name, comma,
- ptext is_subsumed, comma,
- if externally_visible
- then empty
- else ptext SLIT("static"),
+ cc_ident, comma,
+ pprStringInCStyle (costCentreUserName cc), comma,
+ pprStringInCStyle (moduleNameUserString mod_name), comma,
+ is_subsumed, comma,
+ empty, -- Now always externally visible
text ");"]
else
hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ]
where
- cc_ident = ppCostCentreLbl cc
-
- pp_str s = doubleQuotes (ptext s)
-
- (mod_name, grp_name, is_subsumed, externally_visible)
- = get_cc_info cc
-
-
-get_cc_info :: CostCentre ->
- (FAST_STRING, -- module name
- FAST_STRING, -- group name
- FAST_STRING, -- subsumed value
- Bool) -- externally visible
-
-get_cc_info cc
- = case cc of
- AllCafsCC m g -> (m, g, cc_IS_CAF, True)
-
- AllDictsCC m g _ -> (m, g, cc_IS_DICT, True)
-
- NormalCC (DictCC i) m g is_dupd is_caf
- -> (m, g, cc_IS_DICT, externallyVisibleId i)
-
- 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 = SLIT("CC_IS_CAF")
- cc_IS_DICT = SLIT("CC_IS_DICT")
- cc_IS_BORING = SLIT("CC_IS_BORING")
+ cc_ident = ppCostCentreLbl cc
+ mod_name = cc_mod cc
+ is_subsumed = ccSubsumed cc
- do_caf IsCafCC = cc_IS_CAF
- do_caf IsNotCafCC = cc_IS_BORING
+ccSubsumed :: CostCentre -> SDoc -- subsumed value
+ccSubsumed cc | isCafCC cc = ptext SLIT("CC_IS_CAF")
+ | otherwise = ptext SLIT("CC_IS_BORING")
\end{code}