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
12 noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
13 noCostCentre, noCCAttached,
14 noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS,
16 mkUserCC, mkAutoCC, mkAllCafsCC,
17 mkSingletonCCS, cafifyCC, dupifyCC,
18 isCafCC, 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,
34 import Module ( Module, ModuleName, moduleName,
35 pprModuleName, moduleNameUserString
38 import Util ( thenCmp )
41 A Cost Centre Stack is something that can be attached to a closure.
44 - the current cost centre stack (CCCS)
45 - a pre-defined cost centre stack (there are several
46 pre-defined CCSs, see below).
52 | CurrentCCS -- Pinned on a let(rec)-bound
53 -- thunk/function/constructor, this says that the
54 -- cost centre to be attached to the object, when it
55 -- is allocated, is whatever is in the
56 -- current-cost-centre-stack register.
58 | SubsumedCCS -- Cost centre stack for top-level subsumed functions
59 -- (CAFs get an AllCafsCC).
60 -- Its execution costs get subsumed into the caller.
61 -- This guy is *only* ever pinned on static closures,
62 -- and is *never* the cost centre for an SCC construct.
64 | OverheadCCS -- We charge costs due to the profiling-system
65 -- doing its work to "overhead".
67 -- Objects whose CCS is "Overhead"
68 -- have their *allocation* charged to "overhead",
69 -- but have the current CCS put into the object
72 -- For example, if we transform "f g" to "let
73 -- g' = g in f g'" (so that something about
74 -- profiling works better...), then we charge
75 -- the *allocation* of g' to OverheadCCS, but
76 -- we put the cost-centre of the call to f
77 -- (i.e., current CCS) into the g' object. When
78 -- g' is entered, the CCS of the call
81 | DontCareCCS -- We need a CCS to stick in static closures
82 -- (for data), but we *don't* expect them to
83 -- accumulate any costs. But we still need
84 -- the placeholder. This CCS is it.
86 | SingletonCCS CostCentre
87 -- This is primarily for CAF cost centres, which
88 -- are attached to top-level thunks right at the
89 -- end of STG processing, before code generation.
90 -- Hence, a CAF cost centre never appears as the
91 -- argument of an _scc_.
92 -- Also, we generate these singleton CCSs statically
93 -- as part of code generation.
95 deriving (Eq, Ord) -- needed for Ord on CLabel
98 A Cost Centre is the argument of an _scc_ expression.
102 = NoCostCentre -- Having this constructor avoids having
103 -- to use "Maybe CostCentre" all the time.
106 cc_name :: CcName, -- Name of the cost centre itself
107 cc_mod :: ModuleName, -- Name of module defining this CC.
108 cc_is_dupd :: IsDupdCC, -- see below
109 cc_is_caf :: IsCafCC -- see below
113 cc_mod :: ModuleName -- Name of module defining this CC.
116 type CcName = EncodedFS
119 = OriginalCC -- This says how the CC is *used*. Saying that
120 | DupdCC -- it is DupdCC doesn't make it a different
121 -- CC, just that it a sub-expression which has
122 -- been moved ("dupd") into a different scope.
124 -- The point about a dupd SCC is that we don't
125 -- count entries to it, because it's not the
128 -- In the papers, it's called "SCCsub",
129 -- i.e. SCCsub CC == SCC DupdCC,
130 -- but we are trying to avoid confusion between
131 -- "subd" and "subsumed". So we call the former
134 data IsCafCC = CafCC | NotCafCC
137 WILL: Would there be any merit to recording ``I am now using a
138 cost-centre from another module''? I don't know if this would help a
139 user; it might be interesting to us to know how much computation is
140 being moved across module boundaries.
142 SIMON: Maybe later...
147 subsumedCCS = SubsumedCCS
148 currentCCS = CurrentCCS
149 overheadCCS = OverheadCCS
150 dontCareCCS = DontCareCCS
152 noCostCentre = NoCostCentre
155 Predicates on Cost-Centre Stacks
158 noCCSAttached NoCCS = True
159 noCCSAttached _ = False
161 noCCAttached NoCostCentre = True
162 noCCAttached _ = False
164 isCurrentCCS CurrentCCS = True
165 isCurrentCCS _ = False
167 isSubsumedCCS SubsumedCCS = True
168 isSubsumedCCS _ = False
170 isCafCCS (SingletonCCS cc) = isCafCC cc
173 currentOrSubsumedCCS SubsumedCCS = True
174 currentOrSubsumedCCS CurrentCCS = True
175 currentOrSubsumedCCS _ = False
178 Building cost centres
181 mkUserCC :: UserFS -> Module -> CostCentre
184 = NormalCC { cc_name = encodeFS cc_name, cc_mod = moduleName mod,
185 cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
188 mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
190 mkAutoCC id mod is_caf
191 = NormalCC { cc_name = occNameFS (getOccName id), cc_mod = moduleName mod,
192 cc_is_dupd = OriginalCC, cc_is_caf = is_caf
195 mkAllCafsCC m = AllCafsCC { cc_mod = moduleName m }
197 mkSingletonCCS :: CostCentre -> CostCentreStack
198 mkSingletonCCS cc = SingletonCCS cc
200 cafifyCC, dupifyCC :: CostCentre -> CostCentre
202 cafifyCC cc@(NormalCC {cc_is_caf = is_caf})
203 = ASSERT(not_a_caf_already is_caf)
204 cc {cc_is_caf = CafCC}
206 not_a_caf_already CafCC = False
207 not_a_caf_already _ = True
208 cafifyCC cc = pprPanic "cafifyCC" (ppr cc)
210 dupifyCC cc = cc {cc_is_dupd = DupdCC}
212 isEmptyCC, isCafCC, isDupdCC :: CostCentre -> Bool
214 isEmptyCC (NoCostCentre) = True
217 isCafCC (AllCafsCC {}) = True
218 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
221 isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True
224 isSccCountCostCentre :: CostCentre -> Bool
225 -- Is this a cost-centre which records scc counts
228 isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre"
230 isSccCountCostCentre cc | isCafCC cc = False
231 | isDupdCC cc = False
234 sccAbleCostCentre :: CostCentre -> Bool
235 -- Is this a cost-centre which can be sccd ?
238 sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre"
240 sccAbleCostCentre cc | isCafCC cc = False
243 ccFromThisModule :: CostCentre -> Module -> Bool
244 ccFromThisModule cc m = cc_mod cc == moduleName m
248 instance Eq CostCentre where
249 c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
251 instance Ord CostCentre where
252 compare = cmpCostCentre
254 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
256 cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2
258 cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1})
259 (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2})
260 -- first key is module name, then we use "kinds" (which include
261 -- names) and finally the caf flag
262 = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
264 cmpCostCentre other_1 other_2
266 tag1 = tag_CC other_1
267 tag2 = tag_CC other_2
269 if tag1 _LT_ tag2 then LT else GT
271 tag_CC (NormalCC {}) = (ILIT(1) :: FAST_INT)
272 tag_CC (AllCafsCC {}) = ILIT(2)
274 cmp_caf NotCafCC CafCC = LT
275 cmp_caf NotCafCC NotCafCC = EQ
276 cmp_caf CafCC CafCC = EQ
277 cmp_caf CafCC NotCafCC = GT
280 -----------------------------------------------------------------------------
281 Printing Cost Centre Stacks.
283 There are two ways to print a CCS:
285 - for debugging output (i.e. -ddump-whatever),
289 instance Outputable CostCentreStack where
290 ppr ccs = case ccs of
291 NoCCS -> ptext SLIT("NO_CCS")
292 CurrentCCS -> ptext SLIT("CCCS")
293 OverheadCCS -> ptext SLIT("CCS_OVERHEAD")
294 DontCareCCS -> ptext SLIT("CCS_DONTZuCARE")
295 SubsumedCCS -> ptext SLIT("CCS_SUBSUMED")
296 SingletonCCS cc -> ppr cc <> ptext SLIT("_ccs")
298 pprCostCentreStackDecl :: CostCentreStack -> SDoc
299 pprCostCentreStackDecl ccs@(SingletonCCS cc)
301 is_subsumed = ccSubsumed cc
303 hcat [ ptext SLIT("CCS_DECLARE"), char '(',
304 ppr ccs, comma, -- better be codeStyle
305 ppCostCentreLbl cc, comma,
306 ptext is_subsumed, comma,
307 empty, -- Now always externally visible
311 pprCostCentreStackDecl ccs
312 = pprPanic "pprCostCentreStackDecl: " (ppr ccs)
315 -----------------------------------------------------------------------------
316 Printing Cost Centres.
318 There are several different ways in which we might want to print a
321 - the name of the cost centre, for profiling output (a C string)
322 - the label, i.e. C label for cost centre in .hc file.
323 - the debugging name, for output in -ddump things
324 - the interface name, for printing in _scc_ exprs in iface files.
326 The last 3 are derived from costCentreStr below. The first is given
330 instance Outputable CostCentre where
331 ppr cc = getPprStyle $ \ sty ->
333 then ppCostCentreLbl cc
334 else text (costCentreUserName cc)
336 -- Printing in an interface file or in Core generally
337 pprCostCentreCore (AllCafsCC {cc_mod = m})
338 = text "__sccC" <+> braces (pprModuleName m)
339 pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
340 cc_is_caf = caf, cc_is_dupd = dup})
341 = text "__scc" <+> braces (hsep [
348 pp_dup DupdCC = char '!'
351 pp_caf CafCC = text "__C"
355 -- Printing as a C label
356 ppCostCentreLbl (NoCostCentre) = text "NONE_cc"
357 ppCostCentreLbl (AllCafsCC {cc_mod = m}) = pprModuleName m <> text "_CAFs_cc"
358 ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf})
359 = pprModuleName m <> ptext n <>
360 text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
362 -- This is the name to go in the user-displayed string,
363 -- recorded in the cost centre declaration
364 costCentreUserName (NoCostCentre) = "NO_CC"
365 costCentreUserName (AllCafsCC {}) = "CAFs_in_..."
366 costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf})
367 = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (_UNPK_ name)
370 Cost Centre Declarations
374 pprCostCentreDecl is_local (NoCostCentre)
375 = panic "pprCostCentreDecl: no cost centre!"
377 pprCostCentreDecl is_local cc
380 ptext SLIT("CC_DECLARE"),char '(',
382 doubleQuotes (text (costCentreUserName cc)), comma,
383 doubleQuotes (text (moduleNameUserString mod_name)), comma,
384 ptext is_subsumed, comma,
385 empty, -- Now always externally visible
388 hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ]
390 cc_ident = ppCostCentreLbl cc
392 is_subsumed = ccSubsumed cc
394 ccSubsumed :: CostCentre -> FAST_STRING -- subsumed value
395 ccSubsumed cc | isCafCC cc = SLIT("CC_IS_CAF")
396 | otherwise = SLIT("CC_IS_BORING")