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