2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CostCentre]{The @CostCentre@ data type}
8 CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..),
9 -- All abstract except to friend: ParseIface.y
13 noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
14 noCostCentre, noCCAttached,
15 noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS,
16 isDerivedFromCurrentCCS,
18 mkUserCC, mkAutoCC, mkAllCafsCC,
19 mkSingletonCCS, cafifyCC, dupifyCC, pushCCOnCCS,
20 isCafCC, isDupdCC, isEmptyCC, isCafCCS,
25 pprCostCentreDecl, pprCostCentreStackDecl, pprCostCentreCore,
27 cmpCostCentre -- used for removing dups in a list
30 #include "HsVersions.h"
33 import Name ( UserFS, EncodedFS, encodeFS, decode,
36 import Module ( Module, ModuleName, moduleName,
40 import CStrings ( pprStringInCStyle )
42 import Util ( thenCmp )
45 A Cost Centre Stack is something that can be attached to a closure.
48 - the current cost centre stack (CCCS)
49 - a pre-defined cost centre stack (there are several
50 pre-defined CCSs, see below).
56 | CurrentCCS -- Pinned on a let(rec)-bound
57 -- thunk/function/constructor, this says that the
58 -- cost centre to be attached to the object, when it
59 -- is allocated, is whatever is in the
60 -- current-cost-centre-stack register.
62 | SubsumedCCS -- Cost centre stack for top-level subsumed functions
63 -- (CAFs get an AllCafsCC).
64 -- Its execution costs get subsumed into the caller.
65 -- This guy is *only* ever pinned on static closures,
66 -- and is *never* the cost centre for an SCC construct.
68 | OverheadCCS -- We charge costs due to the profiling-system
69 -- doing its work to "overhead".
71 -- Objects whose CCS is "Overhead"
72 -- have their *allocation* charged to "overhead",
73 -- but have the current CCS put into the object
76 -- For example, if we transform "f g" to "let
77 -- g' = g in f g'" (so that something about
78 -- profiling works better...), then we charge
79 -- the *allocation* of g' to OverheadCCS, but
80 -- we put the cost-centre of the call to f
81 -- (i.e., current CCS) into the g' object. When
82 -- g' is entered, the CCS of the call
85 | DontCareCCS -- We need a CCS to stick in static closures
86 -- (for data), but we *don't* expect them to
87 -- accumulate any costs. But we still need
88 -- the placeholder. This CCS is it.
90 | PushCC CostCentre CostCentreStack
91 -- These are used during code generation as the CCSs
92 -- attached to closures. A PushCC never appears as
93 -- the argument to an _scc_.
95 -- The tail (2nd argument) is either NoCCS, indicating
96 -- a staticly allocated CCS, or CurrentCCS indicating
97 -- a dynamically created CCS. We only support
98 -- statically allocated *singleton* CCSs at the
99 -- moment, for the purposes of initialising the CCS
102 deriving (Eq, Ord) -- needed for Ord on CLabel
105 A Cost Centre is the argument of an _scc_ expression.
109 = NoCostCentre -- Having this constructor avoids having
110 -- to use "Maybe CostCentre" all the time.
113 cc_name :: CcName, -- Name of the cost centre itself
114 cc_mod :: ModuleName, -- Name of module defining this CC.
115 cc_is_dupd :: IsDupdCC, -- see below
116 cc_is_caf :: IsCafCC -- see below
120 cc_mod :: ModuleName -- Name of module defining this CC.
123 type CcName = EncodedFS
126 = OriginalCC -- This says how the CC is *used*. Saying that
127 | DupdCC -- it is DupdCC doesn't make it a different
128 -- CC, just that it a sub-expression which has
129 -- been moved ("dupd") into a different scope.
131 -- The point about a dupd SCC is that we don't
132 -- count entries to it, because it's not the
135 -- In the papers, it's called "SCCsub",
136 -- i.e. SCCsub CC == SCC DupdCC,
137 -- but we are trying to avoid confusion between
138 -- "subd" and "subsumed". So we call the former
141 data IsCafCC = CafCC | NotCafCC
143 -- synonym for triple which describes the cost centre info in the generated
144 -- code for a module.
146 = ( [CostCentre] -- local cost-centres that need to be decl'd
147 , [CostCentre] -- "extern" cost-centres
148 , [CostCentreStack] -- pre-defined "singleton" cost centre stacks
152 WILL: Would there be any merit to recording ``I am now using a
153 cost-centre from another module''? I don't know if this would help a
154 user; it might be interesting to us to know how much computation is
155 being moved across module boundaries.
157 SIMON: Maybe later...
162 subsumedCCS = SubsumedCCS
163 currentCCS = CurrentCCS
164 overheadCCS = OverheadCCS
165 dontCareCCS = DontCareCCS
167 noCostCentre = NoCostCentre
170 Predicates on Cost-Centre Stacks
173 noCCSAttached NoCCS = True
174 noCCSAttached _ = False
176 noCCAttached NoCostCentre = True
177 noCCAttached _ = False
179 isCurrentCCS CurrentCCS = True
180 isCurrentCCS _ = False
182 isSubsumedCCS SubsumedCCS = True
183 isSubsumedCCS _ = False
185 isCafCCS (PushCC cc NoCCS) = isCafCC cc
188 isDerivedFromCurrentCCS CurrentCCS = True
189 isDerivedFromCurrentCCS (PushCC _ ccs) = isDerivedFromCurrentCCS ccs
190 isDerivedFromCurrentCCS _ = False
192 currentOrSubsumedCCS SubsumedCCS = True
193 currentOrSubsumedCCS CurrentCCS = True
194 currentOrSubsumedCCS _ = False
197 Building cost centres
200 mkUserCC :: UserFS -> Module -> CostCentre
202 = NormalCC { cc_name = encodeFS cc_name, cc_mod = moduleName mod,
203 cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
206 mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
207 mkAutoCC id mod is_caf
208 = NormalCC { cc_name = occNameFS (getOccName id), cc_mod = moduleName mod,
209 cc_is_dupd = OriginalCC, cc_is_caf = is_caf
212 mkAllCafsCC m = AllCafsCC { cc_mod = moduleName m }
216 mkSingletonCCS :: CostCentre -> CostCentreStack
217 mkSingletonCCS cc = pushCCOnCCS cc NoCCS
219 pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
222 cafifyCC, dupifyCC :: CostCentre -> CostCentre
223 cafifyCC cc@(NormalCC {cc_is_caf = is_caf})
224 = ASSERT(not_a_caf_already is_caf)
225 cc {cc_is_caf = CafCC}
227 not_a_caf_already CafCC = False
228 not_a_caf_already _ = True
229 cafifyCC cc = pprPanic "cafifyCC" (ppr cc)
231 dupifyCC cc = cc {cc_is_dupd = DupdCC}
233 isEmptyCC, isCafCC, isDupdCC :: CostCentre -> Bool
235 isEmptyCC (NoCostCentre) = True
238 isCafCC (AllCafsCC {}) = True
239 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
242 isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True
245 isSccCountCostCentre :: CostCentre -> Bool
246 -- Is this a cost-centre which records scc counts
249 isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre"
251 isSccCountCostCentre cc | isCafCC cc = False
252 | isDupdCC cc = False
255 sccAbleCostCentre :: CostCentre -> Bool
256 -- Is this a cost-centre which can be sccd ?
259 sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre"
261 sccAbleCostCentre cc | isCafCC cc = False
264 ccFromThisModule :: CostCentre -> Module -> Bool
265 ccFromThisModule cc m = cc_mod cc == moduleName m
269 instance Eq CostCentre where
270 c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
272 instance Ord CostCentre where
273 compare = cmpCostCentre
275 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
277 cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2
279 cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1})
280 (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2})
281 -- first key is module name, then we use "kinds" (which include
282 -- names) and finally the caf flag
283 = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
285 cmpCostCentre other_1 other_2
287 tag1 = tag_CC other_1
288 tag2 = tag_CC other_2
290 if tag1 <# tag2 then LT else GT
292 tag_CC (NormalCC {}) = (_ILIT 1 :: FastInt)
293 tag_CC (AllCafsCC {}) = _ILIT 2
295 cmp_caf NotCafCC CafCC = LT
296 cmp_caf NotCafCC NotCafCC = EQ
297 cmp_caf CafCC CafCC = EQ
298 cmp_caf CafCC NotCafCC = GT
301 -----------------------------------------------------------------------------
302 Printing Cost Centre Stacks.
304 The outputable instance for CostCentreStack prints the CCS as a C
307 NOTE: Not all cost centres are suitable for using in a static
308 initializer. In particular, the PushCC forms where the tail is CCCS
309 may only be used in inline C code because they expand to a
310 non-constant C expression.
313 instance Outputable CostCentreStack where
314 ppr NoCCS = ptext SLIT("NO_CCS")
315 ppr CurrentCCS = ptext SLIT("CCCS")
316 ppr OverheadCCS = ptext SLIT("CCS_OVERHEAD")
317 ppr DontCareCCS = ptext SLIT("CCS_DONT_CARE")
318 ppr SubsumedCCS = ptext SLIT("CCS_SUBSUMED")
319 ppr (PushCC cc NoCCS) = ppr cc <> ptext SLIT("_ccs")
320 ppr (PushCC cc ccs) = ptext SLIT("PushCostCentre") <>
321 parens (ppr ccs <> comma <> ppr cc)
323 -- print the static declaration for a singleton CCS.
324 pprCostCentreStackDecl :: CostCentreStack -> SDoc
325 pprCostCentreStackDecl ccs@(PushCC cc NoCCS)
326 = hcat [ ptext SLIT("CCS_DECLARE"), char '(',
327 ppr ccs, comma, -- better be codeStyle
328 ppCostCentreLbl cc, comma,
329 empty, -- Now always externally visible
333 pprCostCentreStackDecl ccs
334 = pprPanic "pprCostCentreStackDecl: " (ppr ccs)
337 -----------------------------------------------------------------------------
338 Printing Cost Centres.
340 There are several different ways in which we might want to print a
343 - the name of the cost centre, for profiling output (a C string)
344 - the label, i.e. C label for cost centre in .hc file.
345 - the debugging name, for output in -ddump things
346 - the interface name, for printing in _scc_ exprs in iface files.
348 The last 3 are derived from costCentreStr below. The first is given
352 instance Outputable CostCentre where
353 ppr cc = getPprStyle $ \ sty ->
355 then ppCostCentreLbl cc
356 else text (costCentreUserName cc)
358 -- Printing in an interface file or in Core generally
359 pprCostCentreCore (AllCafsCC {cc_mod = m})
360 = text "__sccC" <+> braces (ppr m)
361 pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
362 cc_is_caf = caf, cc_is_dupd = dup})
363 = text "__scc" <+> braces (hsep [
370 pp_dup DupdCC = char '!'
373 pp_caf CafCC = text "__C"
377 -- Printing as a C label
378 ppCostCentreLbl (NoCostCentre) = text "NONE_cc"
379 ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
380 ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf})
381 = ppr m <> ptext n <>
382 text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
384 -- This is the name to go in the user-displayed string,
385 -- recorded in the cost centre declaration
386 costCentreUserName (NoCostCentre) = "NO_CC"
387 costCentreUserName (AllCafsCC {}) = "CAF"
388 costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf})
389 = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (_UNPK_ name)
392 Cost Centre Declarations
396 pprCostCentreDecl is_local (NoCostCentre)
397 = panic "pprCostCentreDecl: no cost centre!"
399 pprCostCentreDecl is_local cc
402 ptext SLIT("CC_DECLARE"),char '(',
404 pprStringInCStyle (costCentreUserName cc), comma,
405 pprStringInCStyle (moduleNameUserString mod_name), comma,
406 ptext is_subsumed, comma,
407 empty, -- Now always externally visible
410 hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ]
412 cc_ident = ppCostCentreLbl cc
414 is_subsumed = ccSubsumed cc
416 ccSubsumed :: CostCentre -> FAST_STRING -- subsumed value
417 ccSubsumed cc | isCafCC cc = SLIT("CC_IS_CAF")
418 | otherwise = SLIT("CC_IS_BORING")