never executed always true always false
1 {-# LANGUAGE DeriveDataTypeable #-}
2 module GHC.Types.CostCentre (
3 CostCentre(..), CcName, CCFlavour(..),
4 -- All abstract except to friend: ParseIface.y
5
6 CostCentreStack,
7 CollectedCCs, emptyCollectedCCs, collectCC,
8 currentCCS, dontCareCCS,
9 isCurrentCCS,
10 maybeSingletonCCS,
11
12 mkUserCC, mkAutoCC, mkAllCafsCC,
13 mkSingletonCCS,
14 isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule,
15
16 pprCostCentreCore,
17 costCentreUserName, costCentreUserNameFS,
18 costCentreSrcSpan,
19
20 cmpCostCentre -- used for removing dups in a list
21 ) where
22
23 import GHC.Prelude
24
25 import GHC.Utils.Binary
26 import GHC.Types.Var
27 import GHC.Types.Name
28 import GHC.Unit.Module
29 import GHC.Types.Unique
30 import GHC.Utils.Outputable
31 import GHC.Types.SrcLoc
32 import GHC.Data.FastString
33 import GHC.Types.CostCentre.State
34
35 import Data.Data
36
37 -----------------------------------------------------------------------------
38 -- Cost Centres
39
40 -- | A Cost Centre is a single @{-# SCC #-}@ annotation.
41
42 data CostCentre
43 = NormalCC {
44 cc_flavour :: CCFlavour,
45 -- ^ Two cost centres may have the same name and
46 -- module but different SrcSpans, so we need a way to
47 -- distinguish them easily and give them different
48 -- object-code labels. So every CostCentre has an
49 -- associated flavour that indicates how it was
50 -- generated, and flavours that allow multiple instances
51 -- of the same name and module have a deterministic 0-based
52 -- index.
53 cc_name :: CcName, -- ^ Name of the cost centre itself
54 cc_mod :: Module, -- ^ Name of module defining this CC.
55 cc_loc :: SrcSpan
56 }
57
58 | AllCafsCC {
59 cc_mod :: Module, -- Name of module defining this CC.
60 cc_loc :: SrcSpan
61 }
62 deriving Data
63
64 type CcName = FastString
65
66 -- | The flavour of a cost centre.
67 --
68 -- Index fields represent 0-based indices giving source-code ordering of
69 -- centres with the same module, name, and flavour.
70 data CCFlavour = CafCC -- ^ Auto-generated top-level thunk
71 | ExprCC !CostCentreIndex -- ^ Explicitly annotated expression
72 | DeclCC !CostCentreIndex -- ^ Explicitly annotated declaration
73 | HpcCC !CostCentreIndex -- ^ Generated by HPC for coverage
74 deriving (Eq, Ord, Data)
75
76 -- | Extract the index from a flavour
77 flavourIndex :: CCFlavour -> Int
78 flavourIndex CafCC = 0
79 flavourIndex (ExprCC x) = unCostCentreIndex x
80 flavourIndex (DeclCC x) = unCostCentreIndex x
81 flavourIndex (HpcCC x) = unCostCentreIndex x
82
83 instance Eq CostCentre where
84 c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
85
86 instance Ord CostCentre where
87 compare = cmpCostCentre
88
89 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
90
91 cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2})
92 = m1 `compare` m2
93
94 cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1}
95 NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2}
96 -- first key is module name, then centre name, then flavour
97 = mconcat
98 [ m1 `compare` m2
99 , n1 `lexicalCompareFS` n2 -- compare lexically to avoid non-determinism
100 , f1 `compare` f2
101 ]
102
103 cmpCostCentre other_1 other_2
104 = let
105 tag1 = tag_CC other_1
106 tag2 = tag_CC other_2
107 in
108 if tag1 < tag2 then LT else GT
109 where
110 tag_CC :: CostCentre -> Int
111 tag_CC (NormalCC {}) = 0
112 tag_CC (AllCafsCC {}) = 1
113
114
115 -----------------------------------------------------------------------------
116 -- Predicates on CostCentre
117
118 isCafCC :: CostCentre -> Bool
119 isCafCC (AllCafsCC {}) = True
120 isCafCC (NormalCC {cc_flavour = CafCC}) = True
121 isCafCC _ = False
122
123 -- | Is this a cost-centre which records scc counts
124 isSccCountCC :: CostCentre -> Bool
125 isSccCountCC cc | isCafCC cc = False
126 | otherwise = True
127
128 -- | Is this a cost-centre which can be sccd ?
129 sccAbleCC :: CostCentre -> Bool
130 sccAbleCC cc | isCafCC cc = False
131 | otherwise = True
132
133 ccFromThisModule :: CostCentre -> Module -> Bool
134 ccFromThisModule cc m = cc_mod cc == m
135
136
137 -----------------------------------------------------------------------------
138 -- Building cost centres
139
140 mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
141 mkUserCC cc_name mod loc flavour
142 = NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc,
143 cc_flavour = flavour
144 }
145
146 mkAutoCC :: Id -> Module -> CostCentre
147 mkAutoCC id mod
148 = NormalCC { cc_name = str, cc_mod = mod,
149 cc_loc = nameSrcSpan (getName id),
150 cc_flavour = CafCC
151 }
152 where
153 name = getName id
154 -- beware: only external names are guaranteed to have unique
155 -- Occnames. If the name is not external, we must append its
156 -- Unique.
157 -- See bug #249, tests prof001, prof002, also #2411
158 str | isExternalName name = occNameFS (getOccName id)
159 | otherwise = occNameFS (getOccName id)
160 `appendFS`
161 mkFastString ('_' : show (getUnique name))
162 mkAllCafsCC :: Module -> SrcSpan -> CostCentre
163 mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }
164
165 -----------------------------------------------------------------------------
166 -- Cost Centre Stacks
167
168 -- | A Cost Centre Stack is something that can be attached to a closure.
169 -- This is either:
170 --
171 -- * the current cost centre stack (CCCS)
172 -- * a pre-defined cost centre stack (there are several
173 -- pre-defined CCSs, see below).
174
175 data CostCentreStack
176 = CurrentCCS -- Pinned on a let(rec)-bound
177 -- thunk/function/constructor, this says that the
178 -- cost centre to be attached to the object, when it
179 -- is allocated, is whatever is in the
180 -- current-cost-centre-stack register.
181
182 | DontCareCCS -- We need a CCS to stick in static closures
183 -- (for data), but we *don't* expect them to
184 -- accumulate any costs. But we still need
185 -- the placeholder. This CCS is it.
186
187 | SingletonCCS CostCentre
188
189 deriving (Eq, Ord) -- needed for Ord on CLabel
190
191
192 -- synonym for triple which describes the cost centre info in the generated
193 -- code for a module.
194 type CollectedCCs
195 = ( [CostCentre] -- local cost-centres that need to be decl'd
196 , [CostCentreStack] -- pre-defined "singleton" cost centre stacks
197 )
198
199 emptyCollectedCCs :: CollectedCCs
200 emptyCollectedCCs = ([], [])
201
202 collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
203 collectCC cc ccs (c, cs) = (cc : c, ccs : cs)
204
205 currentCCS, dontCareCCS :: CostCentreStack
206
207 currentCCS = CurrentCCS
208 dontCareCCS = DontCareCCS
209
210 -----------------------------------------------------------------------------
211 -- Predicates on Cost-Centre Stacks
212
213 isCurrentCCS :: CostCentreStack -> Bool
214 isCurrentCCS CurrentCCS = True
215 isCurrentCCS _ = False
216
217 isCafCCS :: CostCentreStack -> Bool
218 isCafCCS (SingletonCCS cc) = isCafCC cc
219 isCafCCS _ = False
220
221 maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
222 maybeSingletonCCS (SingletonCCS cc) = Just cc
223 maybeSingletonCCS _ = Nothing
224
225 mkSingletonCCS :: CostCentre -> CostCentreStack
226 mkSingletonCCS cc = SingletonCCS cc
227
228
229 -----------------------------------------------------------------------------
230 -- Printing Cost Centre Stacks.
231
232 -- The outputable instance for CostCentreStack prints the CCS as a C
233 -- expression.
234
235 instance Outputable CostCentreStack where
236 ppr CurrentCCS = text "CCCS"
237 ppr DontCareCCS = text "CCS_DONT_CARE"
238 ppr (SingletonCCS cc) = ppr cc <> text "_ccs"
239
240
241 -----------------------------------------------------------------------------
242 -- Printing Cost Centres
243 --
244 -- There are several different ways in which we might want to print a
245 -- cost centre:
246 --
247 -- - the name of the cost centre, for profiling output (a C string)
248 -- - the label, i.e. C label for cost centre in .hc file.
249 -- - the debugging name, for output in -ddump things
250 -- - the interface name, for printing in _scc_ exprs in iface files.
251 --
252 -- The last 3 are derived from costCentreStr below. The first is given
253 -- by costCentreName.
254
255 instance Outputable CostCentre where
256 ppr cc = getPprStyle $ \ sty ->
257 if codeStyle sty
258 then ppCostCentreLbl cc
259 else text (costCentreUserName cc)
260
261 -- Printing in Core
262 pprCostCentreCore :: CostCentre -> SDoc
263 pprCostCentreCore (AllCafsCC {cc_mod = m})
264 = text "__sccC" <+> braces (ppr m)
265 pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n,
266 cc_mod = m, cc_loc = loc})
267 = text "__scc" <+> braces (hsep [
268 ppr m <> char '.' <> ftext n,
269 pprFlavourCore flavour,
270 whenPprDebug (ppr loc)
271 ])
272
273 -- ^ Print a flavour in Core
274 pprFlavourCore :: CCFlavour -> SDoc
275 pprFlavourCore CafCC = text "__C"
276 pprFlavourCore f = pprIdxCore $ flavourIndex f
277
278 -- ^ Print a flavour's index in Core
279 pprIdxCore :: Int -> SDoc
280 pprIdxCore 0 = empty
281 pprIdxCore idx = whenPprDebug $ ppr idx
282
283 -- Printing as a C label
284 ppCostCentreLbl :: CostCentre -> SDoc
285 ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
286 ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})
287 = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
288 ppFlavourLblComponent f <> text "_cc"
289
290 -- ^ Print the flavour component of a C label
291 ppFlavourLblComponent :: CCFlavour -> SDoc
292 ppFlavourLblComponent CafCC = text "CAF"
293 ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i
294 ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i
295 ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i
296
297 -- ^ Print the flavour index component of a C label
298 ppIdxLblComponent :: CostCentreIndex -> SDoc
299 ppIdxLblComponent n =
300 case unCostCentreIndex n of
301 0 -> empty
302 n -> ppr n
303
304 -- This is the name to go in the user-displayed string,
305 -- recorded in the cost centre declaration
306 costCentreUserName :: CostCentre -> String
307 costCentreUserName = unpackFS . costCentreUserNameFS
308
309 costCentreUserNameFS :: CostCentre -> FastString
310 costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF"
311 costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf})
312 = case is_caf of
313 CafCC -> mkFastString "CAF:" `appendFS` name
314 _ -> name
315
316 costCentreSrcSpan :: CostCentre -> SrcSpan
317 costCentreSrcSpan = cc_loc
318
319 instance Binary CCFlavour where
320 put_ bh CafCC =
321 putByte bh 0
322 put_ bh (ExprCC i) = do
323 putByte bh 1
324 put_ bh i
325 put_ bh (DeclCC i) = do
326 putByte bh 2
327 put_ bh i
328 put_ bh (HpcCC i) = do
329 putByte bh 3
330 put_ bh i
331 get bh = do
332 h <- getByte bh
333 case h of
334 0 -> return CafCC
335 1 -> ExprCC <$> get bh
336 2 -> DeclCC <$> get bh
337 _ -> HpcCC <$> get bh
338
339 instance Binary CostCentre where
340 put_ bh (NormalCC aa ab ac _ad) = do
341 putByte bh 0
342 put_ bh aa
343 put_ bh ab
344 put_ bh ac
345 put_ bh (AllCafsCC ae _af) = do
346 putByte bh 1
347 put_ bh ae
348 get bh = do
349 h <- getByte bh
350 case h of
351 0 -> do aa <- get bh
352 ab <- get bh
353 ac <- get bh
354 return (NormalCC aa ab ac noSrcSpan)
355 _ -> do ae <- get bh
356 return (AllCafsCC ae noSrcSpan)
357
358 -- We ignore the SrcSpans in CostCentres when we serialise them,
359 -- and set the SrcSpans to noSrcSpan when deserialising. This is
360 -- ok, because we only need the SrcSpan when declaring the
361 -- CostCentre in the original module, it is not used by importing
362 -- modules.