2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CostCentre]{The @CostCentre@ data type}
8 CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..), IsDictCC(..),
9 -- All abstract except to friend: ParseIface.y
12 noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
13 noCostCentre, noCCAttached,
14 noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS,
16 mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC,
17 mkSingletonCCS, cafifyCC, dupifyCC,
18 isCafCC, isDictCC, isDupdCC, isEmptyCC, isCafCCS,
23 pprCostCentreDecl, pprCostCentreStackDecl, pprCostCentreCore,
25 cmpCostCentre -- used for removing dups in a list
28 #include "HsVersions.h"
31 import Name ( UserFS, EncodedFS, encodeFS, decode,
32 Module, getOccName, occNameFS, pprModule, moduleUserString
35 import Util ( thenCmp )
38 A Cost Centre Stack is something that can be attached to a closure.
41 - the current cost centre stack (CCCS)
42 - a pre-defined cost centre stack (there are several
43 pre-defined CCSs, see below).
49 | CurrentCCS -- Pinned on a let(rec)-bound
50 -- thunk/function/constructor, this says that the
51 -- cost centre to be attached to the object, when it
52 -- is allocated, is whatever is in the
53 -- current-cost-centre-stack register.
55 | SubsumedCCS -- Cost centre stack for top-level subsumed functions
56 -- (CAFs get an AllCafsCC).
57 -- Its execution costs get subsumed into the caller.
58 -- This guy is *only* ever pinned on static closures,
59 -- and is *never* the cost centre for an SCC construct.
61 | OverheadCCS -- We charge costs due to the profiling-system
62 -- doing its work to "overhead".
64 -- Objects whose CCS is "Overhead"
65 -- have their *allocation* charged to "overhead",
66 -- but have the current CCS put into the object
69 -- For example, if we transform "f g" to "let
70 -- g' = g in f g'" (so that something about
71 -- profiling works better...), then we charge
72 -- the *allocation* of g' to OverheadCCS, but
73 -- we put the cost-centre of the call to f
74 -- (i.e., current CCS) into the g' object. When
75 -- g' is entered, the CCS of the call
78 | DontCareCCS -- We need a CCS to stick in static closures
79 -- (for data), but we *don't* expect them to
80 -- accumulate any costs. But we still need
81 -- the placeholder. This CCS is it.
83 | SingletonCCS CostCentre
84 -- This is primarily for CAF cost centres, which
85 -- are attached to top-level thunks right at the
86 -- end of STG processing, before code generation.
87 -- Hence, a CAF cost centre never appears as the
88 -- argument of an _scc_.
89 -- Also, we generate these singleton CCSs statically
90 -- as part of code generation.
92 deriving (Eq, Ord) -- needed for Ord on CLabel
95 A Cost Centre is the argument of an _scc_ expression.
98 type Group = FAST_STRING -- "Group" that this CC is in; eg directory
101 = NoCostCentre -- Having this constructor avoids having
102 -- to use "Maybe CostCentre" all the time.
105 cc_name :: CcName, -- Name of the cost centre itself
106 cc_mod :: Module, -- Name of module defining this CC.
107 cc_grp :: Group, -- "Group" that this CC is in.
108 cc_is_dict :: IsDictCC, -- see below
109 cc_is_dupd :: IsDupdCC, -- see below
110 cc_is_caf :: IsCafCC -- see below
114 cc_mod :: Module, -- Name of module defining this CC.
115 cc_grp :: Group -- "Group" that this CC is in
116 -- Again, one "big" CAF cc per module, where all
117 -- CAF costs are attributed unless the user asked for
118 -- per-individual-CAF cost attribution.
122 cc_mod :: Module, -- Name of module defining this CC.
123 cc_grp :: Group, -- "Group" that this CC is in.
124 -- Again, one "big" DICT cc per module, where all
125 -- DICT costs are attributed unless the user asked for
126 -- per-individual-DICT cost attribution.
127 cc_is_dupd :: IsDupdCC
130 type CcName = EncodedFS
132 data IsDictCC = DictCC | VanillaCC
135 = OriginalCC -- This says how the CC is *used*. Saying that
136 | DupdCC -- it is DupdCC doesn't make it a different
137 -- CC, just that it a sub-expression which has
138 -- been moved ("dupd") into a different scope.
140 -- The point about a dupd SCC is that we don't
141 -- count entries to it, because it's not the
144 -- In the papers, it's called "SCCsub",
145 -- i.e. SCCsub CC == SCC DupdCC,
146 -- but we are trying to avoid confusion between
147 -- "subd" and "subsumed". So we call the former
150 data IsCafCC = CafCC | NotCafCC
153 WILL: Would there be any merit to recording ``I am now using a
154 cost-centre from another module''? I don't know if this would help a
155 user; it might be interesting to us to know how much computation is
156 being moved across module boundaries.
158 SIMON: Maybe later...
163 subsumedCCS = SubsumedCCS
164 currentCCS = CurrentCCS
165 overheadCCS = OverheadCCS
166 dontCareCCS = DontCareCCS
168 noCostCentre = NoCostCentre
171 Predicates on Cost-Centre Stacks
174 noCCSAttached NoCCS = True
175 noCCSAttached _ = False
177 noCCAttached NoCostCentre = True
178 noCCAttached _ = False
180 isCurrentCCS CurrentCCS = True
181 isCurrentCCS _ = False
183 isSubsumedCCS SubsumedCCS = True
184 isSubsumedCCS _ = False
186 isCafCCS (SingletonCCS cc) = isCafCC cc
189 isDictCCS (SingletonCCS cc) = isDictCC cc
192 currentOrSubsumedCCS SubsumedCCS = True
193 currentOrSubsumedCCS CurrentCCS = True
194 currentOrSubsumedCCS _ = False
197 Building cost centres
200 mkUserCC :: UserFS -> Module -> Group -> CostCentre
202 mkUserCC cc_name module_name group_name
203 = NormalCC { cc_name = encodeFS cc_name,
204 cc_mod = module_name, cc_grp = group_name,
205 cc_is_dict = VanillaCC, cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
208 mkDictCC, mkAutoCC :: Id -> Module -> Group -> IsCafCC -> CostCentre
210 mkDictCC id module_name group_name is_caf
211 = NormalCC { cc_name = occNameFS (getOccName id),
212 cc_mod = module_name, cc_grp = group_name,
213 cc_is_dict = DictCC, cc_is_dupd = OriginalCC, cc_is_caf = is_caf
216 mkAutoCC id module_name group_name is_caf
217 = NormalCC { cc_name = occNameFS (getOccName id),
218 cc_mod = module_name, cc_grp = group_name,
219 cc_is_dict = VanillaCC, cc_is_dupd = OriginalCC, cc_is_caf = is_caf
222 mkAllCafsCC m g = AllCafsCC { cc_mod = m, cc_grp = g }
223 mkAllDictsCC m g is_dupd = AllDictsCC { cc_mod = m, cc_grp = g,
224 cc_is_dupd = if is_dupd then DupdCC else OriginalCC }
226 mkSingletonCCS :: CostCentre -> CostCentreStack
227 mkSingletonCCS cc = SingletonCCS cc
229 cafifyCC, dupifyCC :: CostCentre -> CostCentre
231 cafifyCC cc@(AllDictsCC {}) = cc
232 cafifyCC cc@(NormalCC {cc_is_caf = is_caf})
233 = ASSERT(not_a_caf_already is_caf)
234 cc {cc_is_caf = CafCC}
236 not_a_caf_already CafCC = False
237 not_a_caf_already _ = True
238 cafifyCC cc = pprPanic "cafifyCC" (ppr cc)
240 dupifyCC cc = cc {cc_is_dupd = DupdCC}
242 isEmptyCC, isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
244 isEmptyCC (NoCostCentre) = True
247 isCafCC (AllCafsCC {}) = True
248 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
251 isDictCC (AllDictsCC {}) = True
252 isDictCC (NormalCC {cc_is_dict = DictCC}) = True
255 isDupdCC (AllDictsCC {cc_is_dupd = DupdCC}) = True
256 isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True
259 isSccCountCostCentre :: CostCentre -> Bool
260 -- Is this a cost-centre which records scc counts
263 isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre"
265 isSccCountCostCentre cc | isCafCC cc = False
266 | isDupdCC cc = False
270 sccAbleCostCentre :: CostCentre -> Bool
271 -- Is this a cost-centre which can be sccd ?
274 sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre"
276 sccAbleCostCentre cc | isCafCC cc = False
279 ccFromThisModule :: CostCentre -> Module -> Bool
280 ccFromThisModule cc m = cc_mod cc == m
284 instance Eq CostCentre where
285 c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
287 instance Ord CostCentre where
288 compare = cmpCostCentre
290 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
292 cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2
293 cmpCostCentre (AllDictsCC {cc_mod = m1}) (AllDictsCC {cc_mod = m2}) = m1 `compare` m2
295 cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1})
296 (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2})
297 -- first key is module name, then we use "kinds" (which include
298 -- names) and finally the caf flag
299 = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
301 cmpCostCentre other_1 other_2
303 tag1 = tag_CC other_1
304 tag2 = tag_CC other_2
306 if tag1 _LT_ tag2 then LT else GT
308 tag_CC (NormalCC {}) = (ILIT(1) :: FAST_INT)
309 tag_CC (AllCafsCC {}) = ILIT(2)
310 tag_CC (AllDictsCC {}) = ILIT(3)
312 cmp_caf NotCafCC CafCC = LT
313 cmp_caf NotCafCC NotCafCC = EQ
314 cmp_caf CafCC CafCC = EQ
315 cmp_caf CafCC NotCafCC = GT
318 -----------------------------------------------------------------------------
319 Printing Cost Centre Stacks.
321 There are two ways to print a CCS:
323 - for debugging output (i.e. -ddump-whatever),
327 instance Outputable CostCentreStack where
328 ppr ccs = case ccs of
329 NoCCS -> ptext SLIT("NO_CCS")
330 CurrentCCS -> ptext SLIT("CCCS")
331 OverheadCCS -> ptext SLIT("CCS_OVERHEAD")
332 DontCareCCS -> ptext SLIT("CCS_DONTZuCARE")
333 SubsumedCCS -> ptext SLIT("CCS_SUBSUMED")
334 SingletonCCS cc -> ptext SLIT("CCS_") <> ppr cc
336 pprCostCentreStackDecl :: CostCentreStack -> SDoc
337 pprCostCentreStackDecl ccs@(SingletonCCS cc)
339 is_subsumed = ccSubsumed cc
341 hcat [ ptext SLIT("CCS_DECLARE"), char '(',
342 ppr ccs, comma, -- better be codeStyle
343 ppCostCentreLbl cc, comma,
344 ptext is_subsumed, comma,
345 empty, -- Now always externally visible
349 pprCostCentreStackDecl ccs
350 = pprPanic "pprCostCentreStackDecl: " (ppr ccs)
353 -----------------------------------------------------------------------------
354 Printing Cost Centres.
356 There are several different ways in which we might want to print a
359 - the name of the cost centre, for profiling output (a C string)
360 - the label, i.e. C label for cost centre in .hc file.
361 - the debugging name, for output in -ddump things
362 - the interface name, for printing in _scc_ exprs in iface files.
364 The last 3 are derived from costCentreStr below. The first is given
368 instance Outputable CostCentre where
369 ppr cc = getPprStyle $ \ sty ->
371 then ppCostCentreLbl cc
372 else text (costCentreUserName cc)
374 -- Printing in an interface file or in Core generally
375 pprCostCentreCore (AllCafsCC {cc_mod = m, cc_grp = g})
376 = text "__sccC" <+> braces (pprModule m <+> doubleQuotes (ptext g))
377 pprCostCentreCore (AllDictsCC {cc_mod = m, cc_grp = g, cc_is_dupd = dup})
378 = text "__sccD" <+> braces (pprModule m <+> doubleQuotes (ptext g) <+> pp_dup dup)
379 pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, cc_grp = g,
380 cc_is_dict = dic, cc_is_caf = caf, cc_is_dupd = dup})
381 = text "__scc" <+> braces (hsep [
384 doubleQuotes (ptext g),
390 pp_dict DictCC = text "__A"
391 pp_dict other = empty
393 pp_dup DupdCC = char '!'
396 pp_caf CafCC = text "__C"
400 -- Printing as a C label
401 ppCostCentreLbl (NoCostCentre) = text "CC_NONE"
402 ppCostCentreLbl (AllCafsCC {cc_mod = m}) = text "CC_CAFs_" <> pprModule m
403 ppCostCentreLbl (AllDictsCC {cc_mod = m}) = text "CC_DICTs_" <> pprModule m
404 ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m}) = text "CC_" <> pprModule m <> ptext n
406 -- This is the name to go in the user-displayed string,
407 -- recorded in the cost centre declaration
408 costCentreUserName (NoCostCentre) = "NO_CC"
409 costCentreUserName (AllCafsCC {}) = "CAFs_in_..."
410 costCentreUserName (AllDictsCC {}) = "DICTs_in_..."
411 costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf})
412 = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (_UNPK_ name)
415 Cost Centre Declarations
419 pprCostCentreDecl is_local (NoCostCentre)
420 = panic "pprCostCentreDecl: no cost centre!"
422 pprCostCentreDecl is_local cc
425 ptext SLIT("CC_DECLARE"),char '(',
427 doubleQuotes (text (costCentreUserName cc)), comma,
428 doubleQuotes (text (moduleUserString mod_name)), comma,
429 doubleQuotes (ptext grp_name), comma,
430 ptext is_subsumed, comma,
431 empty, -- Now always externally visible
434 hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ]
436 cc_ident = ppCostCentreLbl cc
439 is_subsumed = ccSubsumed cc
441 ccSubsumed :: CostCentre -> FAST_STRING -- subsumed value
442 ccSubsumed cc | isCafCC cc = SLIT("CC_IS_CAF")
443 | isDictCC cc = SLIT("CC_IS_DICT")
444 | otherwise = SLIT("CC_IS_BORING")