2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CostCentre]{The @CostCentre@ data type}
8 -- The above warning supression flag is a temporary kludge.
9 -- While working on this module you are encouraged to remove it and fix
10 -- any warnings in the module. See
11 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
15 CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..),
16 -- All abstract except to friend: ParseIface.y
20 noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
21 noCostCentre, noCCAttached,
22 noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS,
23 isDerivedFromCurrentCCS, maybeSingletonCCS,
26 mkUserCC, mkAutoCC, mkAllCafsCC,
27 mkSingletonCCS, dupifyCC, pushCCOnCCS,
36 cmpCostCentre -- used for removing dups in a list
39 #include "HsVersions.h"
43 import Module ( Module )
47 import Util ( thenCmp )
50 A Cost Centre Stack is something that can be attached to a closure.
53 - the current cost centre stack (CCCS)
54 - a pre-defined cost centre stack (there are several
55 pre-defined CCSs, see below).
61 | CurrentCCS -- Pinned on a let(rec)-bound
62 -- thunk/function/constructor, this says that the
63 -- cost centre to be attached to the object, when it
64 -- is allocated, is whatever is in the
65 -- current-cost-centre-stack register.
67 | SubsumedCCS -- Cost centre stack for top-level subsumed functions
68 -- (CAFs get an AllCafsCC).
69 -- Its execution costs get subsumed into the caller.
70 -- This guy is *only* ever pinned on static closures,
71 -- and is *never* the cost centre for an SCC construct.
73 | OverheadCCS -- We charge costs due to the profiling-system
74 -- doing its work to "overhead".
76 -- Objects whose CCS is "Overhead"
77 -- have their *allocation* charged to "overhead",
78 -- but have the current CCS put into the object
81 -- For example, if we transform "f g" to "let
82 -- g' = g in f g'" (so that something about
83 -- profiling works better...), then we charge
84 -- the *allocation* of g' to OverheadCCS, but
85 -- we put the cost-centre of the call to f
86 -- (i.e., current CCS) into the g' object. When
87 -- g' is entered, the CCS of the call
90 | DontCareCCS -- We need a CCS to stick in static closures
91 -- (for data), but we *don't* expect them to
92 -- accumulate any costs. But we still need
93 -- the placeholder. This CCS is it.
95 | PushCC CostCentre CostCentreStack
96 -- These are used during code generation as the CCSs
97 -- attached to closures. A PushCC never appears as
98 -- the argument to an _scc_.
100 -- The tail (2nd argument) is either NoCCS, indicating
101 -- a staticly allocated CCS, or CurrentCCS indicating
102 -- a dynamically created CCS. We only support
103 -- statically allocated *singleton* CCSs at the
104 -- moment, for the purposes of initialising the CCS
107 deriving (Eq, Ord) -- needed for Ord on CLabel
110 A Cost Centre is the argument of an _scc_ expression.
114 = NoCostCentre -- Having this constructor avoids having
115 -- to use "Maybe CostCentre" all the time.
118 cc_name :: CcName, -- Name of the cost centre itself
119 cc_mod :: Module, -- Name of module defining this CC.
120 cc_is_dupd :: IsDupdCC, -- see below
121 cc_is_caf :: IsCafCC -- see below
125 cc_mod :: Module -- Name of module defining this CC.
128 type CcName = FastString
131 = OriginalCC -- This says how the CC is *used*. Saying that
132 | DupdCC -- it is DupdCC doesn't make it a different
133 -- CC, just that it a sub-expression which has
134 -- been moved ("dupd") into a different scope.
136 -- The point about a dupd SCC is that we don't
137 -- count entries to it, because it's not the
140 -- In the papers, it's called "SCCsub",
141 -- i.e. SCCsub CC == SCC DupdCC,
142 -- but we are trying to avoid confusion between
143 -- "subd" and "subsumed". So we call the former
146 data IsCafCC = CafCC | NotCafCC
148 -- synonym for triple which describes the cost centre info in the generated
149 -- code for a module.
151 = ( [CostCentre] -- local cost-centres that need to be decl'd
152 , [CostCentre] -- "extern" cost-centres
153 , [CostCentreStack] -- pre-defined "singleton" cost centre stacks
157 WILL: Would there be any merit to recording ``I am now using a
158 cost-centre from another module''? I don't know if this would help a
159 user; it might be interesting to us to know how much computation is
160 being moved across module boundaries.
162 SIMON: Maybe later...
167 subsumedCCS = SubsumedCCS
168 currentCCS = CurrentCCS
169 overheadCCS = OverheadCCS
170 dontCareCCS = DontCareCCS
172 noCostCentre = NoCostCentre
175 Predicates on Cost-Centre Stacks
178 noCCSAttached NoCCS = True
179 noCCSAttached _ = False
181 noCCAttached NoCostCentre = True
182 noCCAttached _ = False
184 isCurrentCCS CurrentCCS = True
185 isCurrentCCS _ = False
187 isSubsumedCCS SubsumedCCS = True
188 isSubsumedCCS _ = False
190 isCafCCS (PushCC cc NoCCS) = isCafCC cc
193 isDerivedFromCurrentCCS CurrentCCS = True
194 isDerivedFromCurrentCCS (PushCC _ ccs) = isDerivedFromCurrentCCS ccs
195 isDerivedFromCurrentCCS _ = False
197 currentOrSubsumedCCS SubsumedCCS = True
198 currentOrSubsumedCCS CurrentCCS = True
199 currentOrSubsumedCCS _ = False
201 maybeSingletonCCS (PushCC cc NoCCS) = Just cc
202 maybeSingletonCCS _ = Nothing
205 Building cost centres
208 mkUserCC :: FastString -> Module -> CostCentre
210 = NormalCC { cc_name = cc_name, cc_mod = mod,
211 cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
214 mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
215 mkAutoCC id mod is_caf
216 = NormalCC { cc_name = str, cc_mod = mod,
217 cc_is_dupd = OriginalCC, cc_is_caf = is_caf
221 -- beware: we might be making an auto CC for a compiler-generated
222 -- thing (like a CAF when -caf-all is on), so include the uniq.
223 -- See bug #249, tests prof001, prof002
224 str | isSystemName name = mkFastString (showSDoc (ppr name))
225 | otherwise = occNameFS (getOccName id)
227 mkAllCafsCC m = AllCafsCC { cc_mod = m }
231 mkSingletonCCS :: CostCentre -> CostCentreStack
232 mkSingletonCCS cc = pushCCOnCCS cc NoCCS
234 pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
237 dupifyCC cc = cc {cc_is_dupd = DupdCC}
239 isCafCC, isDupdCC :: CostCentre -> Bool
241 isCafCC (AllCafsCC {}) = True
242 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
245 isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True
248 isSccCountCostCentre :: CostCentre -> Bool
249 -- Is this a cost-centre which records scc counts
252 isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre"
254 isSccCountCostCentre cc | isCafCC cc = False
255 | isDupdCC cc = False
258 sccAbleCostCentre :: CostCentre -> Bool
259 -- Is this a cost-centre which can be sccd ?
262 sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre"
264 sccAbleCostCentre cc | isCafCC cc = False
267 ccFromThisModule :: CostCentre -> Module -> Bool
268 ccFromThisModule cc m = cc_mod cc == m
272 instance Eq CostCentre where
273 c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
275 instance Ord CostCentre where
276 compare = cmpCostCentre
278 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
280 cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2
282 cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1})
283 (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2})
284 -- first key is module name, then we use "kinds" (which include
285 -- names) and finally the caf flag
286 = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
288 cmpCostCentre other_1 other_2
290 tag1 = tag_CC other_1
291 tag2 = tag_CC other_2
293 if tag1 <# tag2 then LT else GT
295 tag_CC (NormalCC {}) = (_ILIT 1 :: FastInt)
296 tag_CC (AllCafsCC {}) = _ILIT 2
298 cmp_caf NotCafCC CafCC = LT
299 cmp_caf NotCafCC NotCafCC = EQ
300 cmp_caf CafCC CafCC = EQ
301 cmp_caf CafCC NotCafCC = GT
303 decomposeCCS :: CostCentreStack -> ([CostCentre],CostCentreStack)
304 decomposeCCS (PushCC cc ccs) = (cc:more, ccs')
305 where (more,ccs') = decomposeCCS ccs
306 decomposeCCS ccs = ([],ccs)
309 -----------------------------------------------------------------------------
310 Printing Cost Centre Stacks.
312 The outputable instance for CostCentreStack prints the CCS as a C
315 NOTE: Not all cost centres are suitable for using in a static
316 initializer. In particular, the PushCC forms where the tail is CCCS
317 may only be used in inline C code because they expand to a
318 non-constant C expression.
321 instance Outputable CostCentreStack where
322 ppr NoCCS = ptext SLIT("NO_CCS")
323 ppr CurrentCCS = ptext SLIT("CCCS")
324 ppr OverheadCCS = ptext SLIT("CCS_OVERHEAD")
325 ppr DontCareCCS = ptext SLIT("CCS_DONT_CARE")
326 ppr SubsumedCCS = ptext SLIT("CCS_SUBSUMED")
327 ppr (PushCC cc NoCCS) = ppr cc <> ptext SLIT("_ccs")
328 ppr (PushCC cc ccs) = ptext SLIT("PushCostCentre") <>
329 parens (ppr ccs <> comma <>
330 parens(ptext SLIT("void *")) <> ppr cc)
333 -----------------------------------------------------------------------------
334 Printing Cost Centres.
336 There are several different ways in which we might want to print a
339 - the name of the cost centre, for profiling output (a C string)
340 - the label, i.e. C label for cost centre in .hc file.
341 - the debugging name, for output in -ddump things
342 - the interface name, for printing in _scc_ exprs in iface files.
344 The last 3 are derived from costCentreStr below. The first is given
348 instance Outputable CostCentre where
349 ppr cc = getPprStyle $ \ sty ->
351 then ppCostCentreLbl cc
352 else text (costCentreUserName cc)
354 -- Printing in an interface file or in Core generally
355 pprCostCentreCore (AllCafsCC {cc_mod = m})
356 = text "__sccC" <+> braces (ppr m)
357 pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
358 cc_is_caf = caf, cc_is_dupd = dup})
359 = text "__scc" <+> braces (hsep [
366 pp_dup DupdCC = char '!'
369 pp_caf CafCC = text "__C"
372 -- Printing as a C label
373 ppCostCentreLbl (NoCostCentre) = text "NONE_cc"
374 ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
375 ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf})
376 = ppr m <> char '_' <> ftext (zEncodeFS n) <>
377 text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
379 -- This is the name to go in the user-displayed string,
380 -- recorded in the cost centre declaration
381 costCentreUserName (NoCostCentre) = "NO_CC"
382 costCentreUserName (AllCafsCC {}) = "CAF"
383 costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf})
384 = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ unpackFS name