2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
4 \section[CostCentre]{The @CostCentre@ data type}
7 {-# OPTIONS -fno-warn-incomplete-patterns #-}
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
13 {-# LANGUAGE DeriveDataTypeable #-}
16 CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..),
17 -- All abstract except to friend: ParseIface.y
21 noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
22 noCostCentre, noCCAttached,
23 noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS,
24 isDerivedFromCurrentCCS, maybeSingletonCCS,
25 decomposeCCS, pushCCisNop,
27 mkUserCC, mkAutoCC, mkAllCafsCC,
28 mkSingletonCCS, dupifyCC, pushCCOnCCS,
37 cmpCostCentre -- used for removing dups in a list
42 import Module ( Module )
47 import Util ( thenCmp )
52 A Cost Centre Stack is something that can be attached to a closure.
55 - the current cost centre stack (CCCS)
56 - a pre-defined cost centre stack (there are several
57 pre-defined CCSs, see below).
63 | CurrentCCS -- Pinned on a let(rec)-bound
64 -- thunk/function/constructor, this says that the
65 -- cost centre to be attached to the object, when it
66 -- is allocated, is whatever is in the
67 -- current-cost-centre-stack register.
69 | SubsumedCCS -- Cost centre stack for top-level subsumed functions
70 -- (CAFs get an AllCafsCC).
71 -- Its execution costs get subsumed into the caller.
72 -- This guy is *only* ever pinned on static closures,
73 -- and is *never* the cost centre for an SCC construct.
75 | OverheadCCS -- We charge costs due to the profiling-system
76 -- doing its work to "overhead".
78 -- Objects whose CCS is "Overhead"
79 -- have their *allocation* charged to "overhead",
80 -- but have the current CCS put into the object
83 -- For example, if we transform "f g" to "let
84 -- g' = g in f g'" (so that something about
85 -- profiling works better...), then we charge
86 -- the *allocation* of g' to OverheadCCS, but
87 -- we put the cost-centre of the call to f
88 -- (i.e., current CCS) into the g' object. When
89 -- g' is entered, the CCS of the call
92 | DontCareCCS -- We need a CCS to stick in static closures
93 -- (for data), but we *don't* expect them to
94 -- accumulate any costs. But we still need
95 -- the placeholder. This CCS is it.
97 | PushCC CostCentre CostCentreStack
98 -- These are used during code generation as the CCSs
99 -- attached to closures. A PushCC never appears as
100 -- the argument to an _scc_.
102 -- The tail (2nd argument) is either NoCCS, indicating
103 -- a staticly allocated CCS, or CurrentCCS indicating
104 -- a dynamically created CCS. We only support
105 -- statically allocated *singleton* CCSs at the
106 -- moment, for the purposes of initialising the CCS
109 deriving (Eq, Ord) -- needed for Ord on CLabel
112 A Cost Centre is the argument of an _scc_ expression.
116 = NoCostCentre -- Having this constructor avoids having
117 -- to use "Maybe CostCentre" all the time.
120 cc_name :: CcName, -- Name of the cost centre itself
121 cc_mod :: Module, -- Name of module defining this CC.
122 cc_is_dupd :: IsDupdCC, -- see below
123 cc_is_caf :: IsCafCC -- see below
127 cc_mod :: Module -- Name of module defining this CC.
129 deriving (Data, Typeable)
131 type CcName = FastString
134 = OriginalCC -- This says how the CC is *used*. Saying that
135 | DupdCC -- it is DupdCC doesn't make it a different
136 -- CC, just that it a sub-expression which has
137 -- been moved ("dupd") into a different scope.
139 -- The point about a dupd SCC is that we don't
140 -- count entries to it, because it's not the
143 -- In the papers, it's called "SCCsub",
144 -- i.e. SCCsub CC == SCC DupdCC,
145 -- but we are trying to avoid confusion between
146 -- "subd" and "subsumed". So we call the former
148 deriving (Data, Typeable)
150 data IsCafCC = CafCC | NotCafCC
151 deriving (Data, Typeable)
153 -- synonym for triple which describes the cost centre info in the generated
154 -- code for a module.
156 = ( [CostCentre] -- local cost-centres that need to be decl'd
157 , [CostCentre] -- "extern" cost-centres
158 , [CostCentreStack] -- pre-defined "singleton" cost centre stacks
162 WILL: Would there be any merit to recording ``I am now using a
163 cost-centre from another module''? I don't know if this would help a
164 user; it might be interesting to us to know how much computation is
165 being moved across module boundaries.
167 SIMON: Maybe later...
170 noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS :: CostCentreStack
173 subsumedCCS = SubsumedCCS
174 currentCCS = CurrentCCS
175 overheadCCS = OverheadCCS
176 dontCareCCS = DontCareCCS
178 noCostCentre :: CostCentre
179 noCostCentre = NoCostCentre
182 Predicates on Cost-Centre Stacks
185 noCCSAttached :: CostCentreStack -> Bool
186 noCCSAttached NoCCS = True
187 noCCSAttached _ = False
189 noCCAttached :: CostCentre -> Bool
190 noCCAttached NoCostCentre = True
191 noCCAttached _ = False
193 isCurrentCCS :: CostCentreStack -> Bool
194 isCurrentCCS CurrentCCS = True
195 isCurrentCCS _ = False
197 isSubsumedCCS :: CostCentreStack -> Bool
198 isSubsumedCCS SubsumedCCS = True
199 isSubsumedCCS _ = False
201 isCafCCS :: CostCentreStack -> Bool
202 isCafCCS (PushCC cc NoCCS) = isCafCC cc
205 isDerivedFromCurrentCCS :: CostCentreStack -> Bool
206 isDerivedFromCurrentCCS CurrentCCS = True
207 isDerivedFromCurrentCCS (PushCC _ ccs) = isDerivedFromCurrentCCS ccs
208 isDerivedFromCurrentCCS _ = False
210 currentOrSubsumedCCS :: CostCentreStack -> Bool
211 currentOrSubsumedCCS SubsumedCCS = True
212 currentOrSubsumedCCS CurrentCCS = True
213 currentOrSubsumedCCS _ = False
215 maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
216 maybeSingletonCCS (PushCC cc NoCCS) = Just cc
217 maybeSingletonCCS _ = Nothing
219 pushCCisNop :: CostCentre -> CostCentreStack -> Bool
220 -- (pushCCisNop cc ccs) = True => pushing cc on ccs is a no-op
221 -- It's safe to return False, but the optimiser can remove
222 -- redundant pushes if this function returns True.
223 pushCCisNop cc (PushCC cc' _) = cc == cc'
224 pushCCisNop _ _ = False
227 Building cost centres
230 mkUserCC :: FastString -> Module -> CostCentre
232 = NormalCC { cc_name = cc_name, cc_mod = mod,
233 cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
236 mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
237 mkAutoCC id mod is_caf
238 = NormalCC { cc_name = str, cc_mod = mod,
239 cc_is_dupd = OriginalCC, cc_is_caf = is_caf
243 -- beware: only external names are guaranteed to have unique
244 -- Occnames. If the name is not external, we must append its
246 -- See bug #249, tests prof001, prof002, also #2411
247 str | isExternalName name = occNameFS (getOccName id)
248 | otherwise = mkFastString $ showSDoc $
249 ftext (occNameFS (getOccName id))
250 <> char '_' <> pprUnique (getUnique name)
251 mkAllCafsCC :: Module -> CostCentre
252 mkAllCafsCC m = AllCafsCC { cc_mod = m }
256 mkSingletonCCS :: CostCentre -> CostCentreStack
257 mkSingletonCCS cc = pushCCOnCCS cc NoCCS
259 pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
262 dupifyCC :: CostCentre -> CostCentre
263 dupifyCC cc = cc {cc_is_dupd = DupdCC}
265 isCafCC, isDupdCC :: CostCentre -> Bool
267 isCafCC (AllCafsCC {}) = True
268 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
271 isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True
274 isSccCountCostCentre :: CostCentre -> Bool
275 -- Is this a cost-centre which records scc counts
278 isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre"
280 isSccCountCostCentre cc | isCafCC cc = False
281 | isDupdCC cc = False
284 sccAbleCostCentre :: CostCentre -> Bool
285 -- Is this a cost-centre which can be sccd ?
288 sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre"
290 sccAbleCostCentre cc | isCafCC cc = False
293 ccFromThisModule :: CostCentre -> Module -> Bool
294 ccFromThisModule cc m = cc_mod cc == m
298 instance Eq CostCentre where
299 c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
301 instance Ord CostCentre where
302 compare = cmpCostCentre
304 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
306 cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2
308 cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1})
309 (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2})
310 -- first key is module name, then we use "kinds" (which include
311 -- names) and finally the caf flag
312 = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
314 cmpCostCentre other_1 other_2
316 !tag1 = tag_CC other_1
317 !tag2 = tag_CC other_2
319 if tag1 <# tag2 then LT else GT
321 tag_CC (NormalCC {}) = _ILIT(1)
322 tag_CC (AllCafsCC {}) = _ILIT(2)
324 -- TODO: swap order of IsCafCC, add deriving Ord
325 cmp_caf :: IsCafCC -> IsCafCC -> Ordering
326 cmp_caf NotCafCC CafCC = LT
327 cmp_caf NotCafCC NotCafCC = EQ
328 cmp_caf CafCC CafCC = EQ
329 cmp_caf CafCC NotCafCC = GT
331 decomposeCCS :: CostCentreStack -> ([CostCentre],CostCentreStack)
332 decomposeCCS (PushCC cc ccs) = (cc:more, ccs')
333 where (more,ccs') = decomposeCCS ccs
334 decomposeCCS ccs = ([],ccs)
337 -----------------------------------------------------------------------------
338 Printing Cost Centre Stacks.
340 The outputable instance for CostCentreStack prints the CCS as a C
343 NOTE: Not all cost centres are suitable for using in a static
344 initializer. In particular, the PushCC forms where the tail is CCCS
345 may only be used in inline C code because they expand to a
346 non-constant C expression.
349 instance Outputable CostCentreStack where
350 ppr NoCCS = ptext (sLit "NO_CCS")
351 ppr CurrentCCS = ptext (sLit "CCCS")
352 ppr OverheadCCS = ptext (sLit "CCS_OVERHEAD")
353 ppr DontCareCCS = ptext (sLit "CCS_DONT_CARE")
354 ppr SubsumedCCS = ptext (sLit "CCS_SUBSUMED")
355 ppr (PushCC cc NoCCS) = ppr cc <> ptext (sLit "_ccs")
356 ppr (PushCC cc ccs) = ptext (sLit "PushCostCentre") <>
357 parens (ppr ccs <> comma <>
358 parens(ptext (sLit "void *")) <> ppr cc)
361 -----------------------------------------------------------------------------
362 Printing Cost Centres.
364 There are several different ways in which we might want to print a
367 - the name of the cost centre, for profiling output (a C string)
368 - the label, i.e. C label for cost centre in .hc file.
369 - the debugging name, for output in -ddump things
370 - the interface name, for printing in _scc_ exprs in iface files.
372 The last 3 are derived from costCentreStr below. The first is given
376 instance Outputable CostCentre where
377 ppr cc = getPprStyle $ \ sty ->
379 then ppCostCentreLbl cc
380 else text (costCentreUserName cc)
382 -- Printing in an interface file or in Core generally
383 pprCostCentreCore :: CostCentre -> SDoc
384 pprCostCentreCore (AllCafsCC {cc_mod = m})
385 = text "__sccC" <+> braces (ppr m)
386 pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
387 cc_is_caf = caf, cc_is_dupd = dup})
388 = text "__scc" <+> braces (hsep [
395 pp_dup :: IsDupdCC -> SDoc
396 pp_dup DupdCC = char '!'
399 pp_caf :: IsCafCC -> SDoc
400 pp_caf CafCC = text "__C"
403 -- Printing as a C label
404 ppCostCentreLbl :: CostCentre -> SDoc
405 ppCostCentreLbl (NoCostCentre) = text "NONE_cc"
406 ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
407 ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf})
408 = ppr m <> char '_' <> ftext (zEncodeFS n) <>
409 text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
411 -- This is the name to go in the user-displayed string,
412 -- recorded in the cost centre declaration
413 costCentreUserName :: CostCentre -> String
414 costCentreUserName (NoCostCentre) = "NO_CC"
415 costCentreUserName (AllCafsCC {}) = "CAF"
416 costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf})
417 = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ unpackFS name