f89654dc00114876da390bee87ed9792bfeabc62
[ghc.git] / compiler / profiling / CostCentre.hs
1 {-# LANGUAGE DeriveDataTypeable #-}
2 module CostCentre (
3 CostCentre(..), CcName, IsCafCC(..),
4 -- All abstract except to friend: ParseIface.y
5
6 CostCentreStack,
7 CollectedCCs,
8 noCCS, currentCCS, dontCareCCS,
9 noCCSAttached, 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
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_key :: {-# UNPACK #-} !Int,
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 a
49 -- Unique that is distinct from every other
50 -- CostCentre in the same module.
51 --
52 -- XXX: should really be using Unique here, but we
53 -- need to derive Data below and there's no Data
54 -- instance for Unique.
55 cc_name :: CcName, -- ^ Name of the cost centre itself
56 cc_mod :: Module, -- ^ Name of module defining this CC.
57 cc_loc :: SrcSpan,
58 cc_is_caf :: IsCafCC -- see below
59 }
60
61 | AllCafsCC {
62 cc_mod :: Module, -- Name of module defining this CC.
63 cc_loc :: SrcSpan
64 }
65 deriving Data
66
67 type CcName = FastString
68
69 data IsCafCC = NotCafCC | CafCC
70 deriving (Eq, Ord, Data)
71
72
73 instance Eq CostCentre where
74 c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
75
76 instance Ord CostCentre where
77 compare = cmpCostCentre
78
79 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
80
81 cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2})
82 = m1 `compare` m2
83
84 cmpCostCentre NormalCC {cc_key = n1, cc_mod = m1}
85 NormalCC {cc_key = n2, cc_mod = m2}
86 -- first key is module name, then the integer key
87 = (m1 `compare` m2) `thenCmp` (n1 `compare` n2)
88
89 cmpCostCentre other_1 other_2
90 = let
91 tag1 = tag_CC other_1
92 tag2 = tag_CC other_2
93 in
94 if tag1 < tag2 then LT else GT
95 where
96 tag_CC :: CostCentre -> Int
97 tag_CC (NormalCC {}) = 0
98 tag_CC (AllCafsCC {}) = 1
99
100
101 -----------------------------------------------------------------------------
102 -- Predicates on CostCentre
103
104 isCafCC :: CostCentre -> Bool
105 isCafCC (AllCafsCC {}) = True
106 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
107 isCafCC _ = False
108
109 -- | Is this a cost-centre which records scc counts
110 isSccCountCC :: CostCentre -> Bool
111 isSccCountCC cc | isCafCC cc = False
112 | otherwise = True
113
114 -- | Is this a cost-centre which can be sccd ?
115 sccAbleCC :: CostCentre -> Bool
116 sccAbleCC cc | isCafCC cc = False
117 | otherwise = True
118
119 ccFromThisModule :: CostCentre -> Module -> Bool
120 ccFromThisModule cc m = cc_mod cc == m
121
122
123 -----------------------------------------------------------------------------
124 -- Building cost centres
125
126 mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre
127 mkUserCC cc_name mod loc key
128 = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod = mod, cc_loc = loc,
129 cc_is_caf = NotCafCC {-might be changed-}
130 }
131
132 mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
133 mkAutoCC id mod is_caf
134 = NormalCC { cc_key = getKey (getUnique id),
135 cc_name = str, cc_mod = mod,
136 cc_loc = nameSrcSpan (getName id),
137 cc_is_caf = is_caf
138 }
139 where
140 name = getName id
141 -- beware: only external names are guaranteed to have unique
142 -- Occnames. If the name is not external, we must append its
143 -- Unique.
144 -- See bug #249, tests prof001, prof002, also #2411
145 str | isExternalName name = occNameFS (getOccName id)
146 | otherwise = occNameFS (getOccName id)
147 `appendFS`
148 mkFastString ('_' : show (getUnique name))
149 mkAllCafsCC :: Module -> SrcSpan -> CostCentre
150 mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }
151
152 -----------------------------------------------------------------------------
153 -- Cost Centre Stacks
154
155 -- | A Cost Centre Stack is something that can be attached to a closure.
156 -- This is either:
157 --
158 -- * the current cost centre stack (CCCS)
159 -- * a pre-defined cost centre stack (there are several
160 -- pre-defined CCSs, see below).
161
162 data CostCentreStack
163 = NoCCS
164
165 | CurrentCCS -- Pinned on a let(rec)-bound
166 -- thunk/function/constructor, this says that the
167 -- cost centre to be attached to the object, when it
168 -- is allocated, is whatever is in the
169 -- current-cost-centre-stack register.
170
171 | DontCareCCS -- We need a CCS to stick in static closures
172 -- (for data), but we *don't* expect them to
173 -- accumulate any costs. But we still need
174 -- the placeholder. This CCS is it.
175
176 | SingletonCCS CostCentre
177
178 deriving (Eq, Ord) -- needed for Ord on CLabel
179
180
181 -- synonym for triple which describes the cost centre info in the generated
182 -- code for a module.
183 type CollectedCCs
184 = ( [CostCentre] -- local cost-centres that need to be decl'd
185 , [CostCentreStack] -- pre-defined "singleton" cost centre stacks
186 )
187
188
189 noCCS, currentCCS, dontCareCCS :: CostCentreStack
190
191 noCCS = NoCCS
192 currentCCS = CurrentCCS
193 dontCareCCS = DontCareCCS
194
195 -----------------------------------------------------------------------------
196 -- Predicates on Cost-Centre Stacks
197
198 noCCSAttached :: CostCentreStack -> Bool
199 noCCSAttached NoCCS = True
200 noCCSAttached _ = False
201
202 isCurrentCCS :: CostCentreStack -> Bool
203 isCurrentCCS CurrentCCS = True
204 isCurrentCCS _ = False
205
206 isCafCCS :: CostCentreStack -> Bool
207 isCafCCS (SingletonCCS cc) = isCafCC cc
208 isCafCCS _ = False
209
210 maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
211 maybeSingletonCCS (SingletonCCS cc) = Just cc
212 maybeSingletonCCS _ = Nothing
213
214 mkSingletonCCS :: CostCentre -> CostCentreStack
215 mkSingletonCCS cc = SingletonCCS cc
216
217
218 -----------------------------------------------------------------------------
219 -- Printing Cost Centre Stacks.
220
221 -- The outputable instance for CostCentreStack prints the CCS as a C
222 -- expression.
223
224 instance Outputable CostCentreStack where
225 ppr NoCCS = text "NO_CCS"
226 ppr CurrentCCS = text "CCCS"
227 ppr DontCareCCS = text "CCS_DONT_CARE"
228 ppr (SingletonCCS cc) = ppr cc <> text "_ccs"
229
230
231 -----------------------------------------------------------------------------
232 -- Printing Cost Centres
233 --
234 -- There are several different ways in which we might want to print a
235 -- cost centre:
236 --
237 -- - the name of the cost centre, for profiling output (a C string)
238 -- - the label, i.e. C label for cost centre in .hc file.
239 -- - the debugging name, for output in -ddump things
240 -- - the interface name, for printing in _scc_ exprs in iface files.
241 --
242 -- The last 3 are derived from costCentreStr below. The first is given
243 -- by costCentreName.
244
245 instance Outputable CostCentre where
246 ppr cc = getPprStyle $ \ sty ->
247 if codeStyle sty
248 then ppCostCentreLbl cc
249 else text (costCentreUserName cc)
250
251 -- Printing in Core
252 pprCostCentreCore :: CostCentre -> SDoc
253 pprCostCentreCore (AllCafsCC {cc_mod = m})
254 = text "__sccC" <+> braces (ppr m)
255 pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc,
256 cc_is_caf = caf})
257 = text "__scc" <+> braces (hsep [
258 ppr m <> char '.' <> ftext n,
259 whenPprDebug (ppr key),
260 pp_caf caf,
261 whenPprDebug (ppr loc)
262 ])
263
264 pp_caf :: IsCafCC -> SDoc
265 pp_caf CafCC = text "__C"
266 pp_caf _ = empty
267
268 -- Printing as a C label
269 ppCostCentreLbl :: CostCentre -> SDoc
270 ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
271 ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m,
272 cc_is_caf = is_caf})
273 = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
274 case is_caf of { CafCC -> text "CAF"; _ -> ppr (mkUniqueGrimily k)} <> text "_cc"
275
276 -- This is the name to go in the user-displayed string,
277 -- recorded in the cost centre declaration
278 costCentreUserName :: CostCentre -> String
279 costCentreUserName = unpackFS . costCentreUserNameFS
280
281 costCentreUserNameFS :: CostCentre -> FastString
282 costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF"
283 costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
284 = case is_caf of
285 CafCC -> mkFastString "CAF:" `appendFS` name
286 _ -> name
287
288 costCentreSrcSpan :: CostCentre -> SrcSpan
289 costCentreSrcSpan = cc_loc
290
291 instance Binary IsCafCC where
292 put_ bh CafCC = do
293 putByte bh 0
294 put_ bh NotCafCC = do
295 putByte bh 1
296 get bh = do
297 h <- getByte bh
298 case h of
299 0 -> do return CafCC
300 _ -> do return NotCafCC
301
302 instance Binary CostCentre where
303 put_ bh (NormalCC aa ab ac _ad ae) = do
304 putByte bh 0
305 put_ bh aa
306 put_ bh ab
307 put_ bh ac
308 put_ bh ae
309 put_ bh (AllCafsCC ae _af) = do
310 putByte bh 1
311 put_ bh ae
312 get bh = do
313 h <- getByte bh
314 case h of
315 0 -> do aa <- get bh
316 ab <- get bh
317 ac <- get bh
318 ae <- get bh
319 return (NormalCC aa ab ac noSrcSpan ae)
320 _ -> do ae <- get bh
321 return (AllCafsCC ae noSrcSpan)
322
323 -- We ignore the SrcSpans in CostCentres when we serialise them,
324 -- and set the SrcSpans to noSrcSpan when deserialising. This is
325 -- ok, because we only need the SrcSpan when declaring the
326 -- CostCentre in the original module, it is not used by importing
327 -- modules.