\begin{code}
module CostCentre (
- CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..), IsDictCC(..),
+ 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, mkDictCC, mkAllCafsCC, mkAllDictsCC,
- mkSingletonCCS, cafifyCC, dupifyCC,
- isCafCC, isDictCC, isDupdCC, isEmptyCC, isCafCCS,
+ mkUserCC, mkAutoCC, mkAllCafsCC,
+ mkSingletonCCS, dupifyCC, pushCCOnCCS,
+ isCafCCS, isCafCC,
isSccCountCostCentre,
sccAbleCostCentre,
ccFromThisModule,
- pprCostCentreDecl, pprCostCentreStackDecl, pprCostCentreCore,
+ pprCostCentreCore,
+ costCentreUserName,
cmpCostCentre -- used for removing dups in a list
) where
#include "HsVersions.h"
import Var ( Id )
-import Name ( UserFS, EncodedFS, encodeFS, decode,
- Module, getOccName, occNameFS, pprModule, moduleUserString
- )
+import Name ( getOccName, occNameFS )
+import Module ( Module )
import Outputable
+import FastTypes
+import FastString
import Util ( thenCmp )
\end{code}
-- 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}
A Cost Centre is the argument of an _scc_ expression.
\begin{code}
-type Group = FAST_STRING -- "Group" that this CC is in; eg directory
-
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 :: Module, -- Name of module defining this CC.
- cc_grp :: Group, -- "Group" that this CC is in.
- cc_is_dict :: IsDictCC, -- see below
- cc_is_dupd :: IsDupdCC, -- see below
- cc_is_caf :: IsCafCC -- see below
+ 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.
- cc_grp :: Group -- "Group" that this CC is in
- -- Again, one "big" CAF cc per module, where all
- -- CAF costs are attributed unless the user asked for
- -- per-individual-CAF cost attribution.
- }
-
- | AllDictsCC {
- cc_mod :: Module, -- Name of module defining this CC.
- cc_grp :: Group, -- "Group" that this CC is in.
- -- Again, one "big" DICT cc per module, where all
- -- DICT costs are attributed unless the user asked for
- -- per-individual-DICT cost attribution.
- cc_is_dupd :: IsDupdCC
+ cc_mod :: Module -- Name of module defining this CC.
}
-type CcName = EncodedFS
-
-data IsDictCC = DictCC | VanillaCC
+type CcName = FastString
data IsDupdCC
= OriginalCC -- This says how the CC is *used*. Saying that
-- "dupd".
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
currentOrSubsumedCCS _ = False
+
+maybeSingletonCCS (PushCC cc NoCCS) = Just cc
+maybeSingletonCCS _ = Nothing
\end{code}
Building cost centres
\begin{code}
-mkUserCC :: UserFS -> Module -> Group -> CostCentre
-
-mkUserCC cc_name module_name group_name
- = NormalCC { cc_name = encodeFS cc_name,
- cc_mod = module_name, cc_grp = group_name,
- cc_is_dict = VanillaCC, cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
+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-}
}
-mkDictCC, mkAutoCC :: Id -> Module -> Group -> IsCafCC -> CostCentre
-
-mkDictCC id module_name group_name is_caf
- = NormalCC { cc_name = occNameFS (getOccName id),
- cc_mod = module_name, cc_grp = group_name,
- cc_is_dict = DictCC, cc_is_dupd = OriginalCC, cc_is_caf = is_caf
+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
}
-mkAutoCC id module_name group_name is_caf
- = NormalCC { cc_name = occNameFS (getOccName id),
- cc_mod = module_name, cc_grp = group_name,
- cc_is_dict = VanillaCC, cc_is_dupd = OriginalCC, cc_is_caf = is_caf
- }
+mkAllCafsCC m = AllCafsCC { cc_mod = m }
-mkAllCafsCC m g = AllCafsCC { cc_mod = m, cc_grp = g }
-mkAllDictsCC m g is_dupd = AllDictsCC { cc_mod = m, cc_grp = g,
- cc_is_dupd = if is_dupd then DupdCC else OriginalCC }
-mkSingletonCCS :: CostCentre -> CostCentreStack
-mkSingletonCCS cc = SingletonCCS cc
-cafifyCC, dupifyCC :: CostCentre -> CostCentre
+mkSingletonCCS :: CostCentre -> CostCentreStack
+mkSingletonCCS cc = pushCCOnCCS cc NoCCS
-cafifyCC cc@(AllDictsCC {}) = cc
-cafifyCC cc@(NormalCC {cc_is_caf = is_caf})
- = ASSERT(not_a_caf_already is_caf)
- cc {cc_is_caf = CafCC}
- where
- not_a_caf_already CafCC = False
- not_a_caf_already _ = True
-cafifyCC cc = pprPanic "cafifyCC" (ppr cc)
+pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
+pushCCOnCCS = PushCC
dupifyCC cc = cc {cc_is_dupd = DupdCC}
-isEmptyCC, isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
-
-isEmptyCC (NoCostCentre) = True
-isEmptyCC _ = False
+isCafCC, isDupdCC :: CostCentre -> Bool
isCafCC (AllCafsCC {}) = True
isCafCC (NormalCC {cc_is_caf = CafCC}) = True
isCafCC _ = False
-isDictCC (AllDictsCC {}) = True
-isDictCC (NormalCC {cc_is_dict = DictCC}) = True
-isDictCC _ = False
-
-isDupdCC (AllDictsCC {cc_is_dupd = DupdCC}) = True
isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True
isDupdCC _ = False
#endif
isSccCountCostCentre cc | isCafCC cc = False
| isDupdCC cc = False
- | isDictCC cc = True
| otherwise = True
sccAbleCostCentre :: CostCentre -> Bool
cmpCostCentre :: CostCentre -> CostCentre -> Ordering
cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2
-cmpCostCentre (AllDictsCC {cc_mod = m1}) (AllDictsCC {cc_mod = m2}) = m1 `compare` m2
cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1})
(NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2})
tag1 = tag_CC other_1
tag2 = tag_CC other_2
in
- if tag1 _LT_ tag2 then LT else GT
+ if tag1 <# 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 (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 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 -> ptext SLIT("CCS_") <> ppr cc
-
-pprCostCentreStackDecl :: CostCentreStack -> SDoc
-pprCostCentreStackDecl ccs@(SingletonCCS cc)
- = let
- is_subsumed = ccSubsumed cc
- in
- hcat [ ptext SLIT("CCS_DECLARE"), char '(',
- ppr ccs, comma, -- better be codeStyle
- ppCostCentreLbl cc, comma,
- ptext is_subsumed, comma,
- empty, -- Now always externally visible
- text ");"
- ]
-
-pprCostCentreStackDecl ccs
- = pprPanic "pprCostCentreStackDecl: " (ppr ccs)
+ 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}
-----------------------------------------------------------------------------
else text (costCentreUserName cc)
-- Printing in an interface file or in Core generally
-pprCostCentreCore (AllCafsCC {cc_mod = m, cc_grp = g})
- = text "__sccC" <+> braces (pprModule m <+> doubleQuotes (ptext g))
-pprCostCentreCore (AllDictsCC {cc_mod = m, cc_grp = g, cc_is_dupd = dup})
- = text "__sccD" <+> braces (pprModule m <+> doubleQuotes (ptext g) <+> pp_dup dup)
-pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, cc_grp = g,
- cc_is_dict = dic, cc_is_caf = caf, cc_is_dupd = dup})
+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 [
- ptext n,
- pprModule m,
- doubleQuotes (ptext g),
- pp_dict dic,
+ ftext n,
+ ppr m,
pp_dup dup,
pp_caf caf
])
-pp_dict DictCC = text "__A"
-pp_dict other = empty
-
pp_dup DupdCC = char '!'
pp_dup other = empty
-- Printing as a C label
-ppCostCentreLbl (NoCostCentre) = text "CC_NONE"
-ppCostCentreLbl (AllCafsCC {cc_mod = m}) = text "CC_CAFs_" <> pprModule m
-ppCostCentreLbl (AllDictsCC {cc_mod = m}) = text "CC_DICTs_" <> pprModule m
-ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m}) = text "CC_" <> pprModule m <> ptext n
+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 {}) = "CAFs_in_..."
-costCentreUserName (AllDictsCC {}) = "DICTs_in_..."
-costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf})
- = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (_UNPK_ name)
-\end{code}
-
-Cost Centre Declarations
-
-\begin{code}
-#ifdef DEBUG
-pprCostCentreDecl is_local (NoCostCentre)
- = panic "pprCostCentreDecl: no cost centre!"
-#endif
-pprCostCentreDecl is_local cc
- = if is_local then
- hcat [
- ptext SLIT("CC_DECLARE"),char '(',
- cc_ident, comma,
- text (costCentreUserName cc), comma,
- doubleQuotes (text (moduleUserString mod_name)), comma,
- doubleQuotes (ptext grp_name), comma,
- ptext is_subsumed, comma,
- empty, -- Now always externally visible
- text ");"]
- else
- hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ]
- where
- cc_ident = ppCostCentreLbl cc
- mod_name = cc_mod cc
- grp_name = cc_grp cc
- is_subsumed = ccSubsumed cc
-
-ccSubsumed :: CostCentre -> FAST_STRING -- subsumed value
-ccSubsumed cc | isCafCC cc = SLIT("CC_IS_CAF")
- | isDictCC cc = SLIT("CC_IS_DICT")
- | otherwise = SLIT("CC_IS_BORING")
+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