Collect CCs in CorePrep, including CCs in unfoldings
[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, 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
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 = CurrentCCS -- Pinned on a let(rec)-bound
164 -- thunk/function/constructor, this says that the
165 -- cost centre to be attached to the object, when it
166 -- is allocated, is whatever is in the
167 -- current-cost-centre-stack register.
168
169 | DontCareCCS -- We need a CCS to stick in static closures
170 -- (for data), but we *don't* expect them to
171 -- accumulate any costs. But we still need
172 -- the placeholder. This CCS is it.
173
174 | SingletonCCS CostCentre
175
176 deriving (Eq, Ord) -- needed for Ord on CLabel
177
178
179 -- synonym for triple which describes the cost centre info in the generated
180 -- code for a module.
181 type CollectedCCs
182 = ( [CostCentre] -- local cost-centres that need to be decl'd
183 , [CostCentreStack] -- pre-defined "singleton" cost centre stacks
184 )
185
186 emptyCollectedCCs :: CollectedCCs
187 emptyCollectedCCs = ([], [])
188
189 collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
190 collectCC cc ccs (c, cs) = (cc : c, ccs : cs)
191
192 currentCCS, dontCareCCS :: CostCentreStack
193
194 currentCCS = CurrentCCS
195 dontCareCCS = DontCareCCS
196
197 -----------------------------------------------------------------------------
198 -- Predicates on Cost-Centre Stacks
199
200 isCurrentCCS :: CostCentreStack -> Bool
201 isCurrentCCS CurrentCCS = True
202 isCurrentCCS _ = False
203
204 isCafCCS :: CostCentreStack -> Bool
205 isCafCCS (SingletonCCS cc) = isCafCC cc
206 isCafCCS _ = False
207
208 maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
209 maybeSingletonCCS (SingletonCCS cc) = Just cc
210 maybeSingletonCCS _ = Nothing
211
212 mkSingletonCCS :: CostCentre -> CostCentreStack
213 mkSingletonCCS cc = SingletonCCS cc
214
215
216 -----------------------------------------------------------------------------
217 -- Printing Cost Centre Stacks.
218
219 -- The outputable instance for CostCentreStack prints the CCS as a C
220 -- expression.
221
222 instance Outputable CostCentreStack where
223 ppr CurrentCCS = text "CCCS"
224 ppr DontCareCCS = text "CCS_DONT_CARE"
225 ppr (SingletonCCS cc) = ppr cc <> text "_ccs"
226
227
228 -----------------------------------------------------------------------------
229 -- Printing Cost Centres
230 --
231 -- There are several different ways in which we might want to print a
232 -- cost centre:
233 --
234 -- - the name of the cost centre, for profiling output (a C string)
235 -- - the label, i.e. C label for cost centre in .hc file.
236 -- - the debugging name, for output in -ddump things
237 -- - the interface name, for printing in _scc_ exprs in iface files.
238 --
239 -- The last 3 are derived from costCentreStr below. The first is given
240 -- by costCentreName.
241
242 instance Outputable CostCentre where
243 ppr cc = getPprStyle $ \ sty ->
244 if codeStyle sty
245 then ppCostCentreLbl cc
246 else text (costCentreUserName cc)
247
248 -- Printing in Core
249 pprCostCentreCore :: CostCentre -> SDoc
250 pprCostCentreCore (AllCafsCC {cc_mod = m})
251 = text "__sccC" <+> braces (ppr m)
252 pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc,
253 cc_is_caf = caf})
254 = text "__scc" <+> braces (hsep [
255 ppr m <> char '.' <> ftext n,
256 whenPprDebug (ppr key),
257 pp_caf caf,
258 whenPprDebug (ppr loc)
259 ])
260
261 pp_caf :: IsCafCC -> SDoc
262 pp_caf CafCC = text "__C"
263 pp_caf _ = empty
264
265 -- Printing as a C label
266 ppCostCentreLbl :: CostCentre -> SDoc
267 ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
268 ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m,
269 cc_is_caf = is_caf})
270 = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
271 case is_caf of { CafCC -> text "CAF"; _ -> ppr (mkUniqueGrimily k)} <> text "_cc"
272
273 -- This is the name to go in the user-displayed string,
274 -- recorded in the cost centre declaration
275 costCentreUserName :: CostCentre -> String
276 costCentreUserName = unpackFS . costCentreUserNameFS
277
278 costCentreUserNameFS :: CostCentre -> FastString
279 costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF"
280 costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
281 = case is_caf of
282 CafCC -> mkFastString "CAF:" `appendFS` name
283 _ -> name
284
285 costCentreSrcSpan :: CostCentre -> SrcSpan
286 costCentreSrcSpan = cc_loc
287
288 instance Binary IsCafCC where
289 put_ bh CafCC = do
290 putByte bh 0
291 put_ bh NotCafCC = do
292 putByte bh 1
293 get bh = do
294 h <- getByte bh
295 case h of
296 0 -> do return CafCC
297 _ -> do return NotCafCC
298
299 instance Binary CostCentre where
300 put_ bh (NormalCC aa ab ac _ad ae) = do
301 putByte bh 0
302 put_ bh aa
303 put_ bh ab
304 put_ bh ac
305 put_ bh ae
306 put_ bh (AllCafsCC ae _af) = do
307 putByte bh 1
308 put_ bh ae
309 get bh = do
310 h <- getByte bh
311 case h of
312 0 -> do aa <- get bh
313 ab <- get bh
314 ac <- get bh
315 ae <- get bh
316 return (NormalCC aa ab ac noSrcSpan ae)
317 _ -> do ae <- get bh
318 return (AllCafsCC ae noSrcSpan)
319
320 -- We ignore the SrcSpans in CostCentres when we serialise them,
321 -- and set the SrcSpans to noSrcSpan when deserialising. This is
322 -- ok, because we only need the SrcSpan when declaring the
323 -- CostCentre in the original module, it is not used by importing
324 -- modules.