Renamer now preserves location for IEThingWith list items
[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 Binary
24 import Var
25 import Name
26 import Module
27 import Unique
28 import Outputable
29 import SrcLoc
30 import FastString
31 import Util
32
33 import Data.Data
34
35 -----------------------------------------------------------------------------
36 -- Cost Centres
37
38 -- | A Cost Centre is a single @{-# SCC #-}@ annotation.
39
40 data CostCentre
41 = NormalCC {
42 cc_key :: {-# UNPACK #-} !Int,
43 -- ^ Two cost centres may have the same name and
44 -- module but different SrcSpans, so we need a way to
45 -- distinguish them easily and give them different
46 -- object-code labels. So every CostCentre has a
47 -- Unique that is distinct from every other
48 -- CostCentre in the same module.
49 --
50 -- XXX: should really be using Unique here, but we
51 -- need to derive Data below and there's no Data
52 -- instance for Unique.
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 cc_is_caf :: IsCafCC -- see below
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 data IsCafCC = NotCafCC | CafCC
68 deriving (Eq, Ord, Data)
69
70
71 instance Eq CostCentre where
72 c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
73
74 instance Ord CostCentre where
75 compare = cmpCostCentre
76
77 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
78
79 cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2})
80 = m1 `compare` m2
81
82 cmpCostCentre NormalCC {cc_key = n1, cc_mod = m1}
83 NormalCC {cc_key = n2, cc_mod = m2}
84 -- first key is module name, then the integer key
85 = (m1 `compare` m2) `thenCmp` (n1 `compare` n2)
86
87 cmpCostCentre other_1 other_2
88 = let
89 tag1 = tag_CC other_1
90 tag2 = tag_CC other_2
91 in
92 if tag1 < tag2 then LT else GT
93 where
94 tag_CC :: CostCentre -> Int
95 tag_CC (NormalCC {}) = 0
96 tag_CC (AllCafsCC {}) = 1
97
98
99 -----------------------------------------------------------------------------
100 -- Predicates on CostCentre
101
102 isCafCC :: CostCentre -> Bool
103 isCafCC (AllCafsCC {}) = True
104 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
105 isCafCC _ = False
106
107 -- | Is this a cost-centre which records scc counts
108 isSccCountCC :: CostCentre -> Bool
109 isSccCountCC cc | isCafCC cc = False
110 | otherwise = True
111
112 -- | Is this a cost-centre which can be sccd ?
113 sccAbleCC :: CostCentre -> Bool
114 sccAbleCC cc | isCafCC cc = False
115 | otherwise = True
116
117 ccFromThisModule :: CostCentre -> Module -> Bool
118 ccFromThisModule cc m = cc_mod cc == m
119
120
121 -----------------------------------------------------------------------------
122 -- Building cost centres
123
124 mkUserCC :: FastString -> Module -> SrcSpan -> Unique -> CostCentre
125 mkUserCC cc_name mod loc key
126 = NormalCC { cc_key = getKey key, cc_name = cc_name, cc_mod = mod, cc_loc = loc,
127 cc_is_caf = NotCafCC {-might be changed-}
128 }
129
130 mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
131 mkAutoCC id mod is_caf
132 = NormalCC { cc_key = getKey (getUnique id),
133 cc_name = str, cc_mod = mod,
134 cc_loc = nameSrcSpan (getName id),
135 cc_is_caf = is_caf
136 }
137 where
138 name = getName id
139 -- beware: only external names are guaranteed to have unique
140 -- Occnames. If the name is not external, we must append its
141 -- Unique.
142 -- See bug #249, tests prof001, prof002, also #2411
143 str | isExternalName name = occNameFS (getOccName id)
144 | otherwise = occNameFS (getOccName id)
145 `appendFS`
146 mkFastString ('_' : show (getUnique name))
147 mkAllCafsCC :: Module -> SrcSpan -> CostCentre
148 mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }
149
150 -----------------------------------------------------------------------------
151 -- Cost Centre Stacks
152
153 -- | A Cost Centre Stack is something that can be attached to a closure.
154 -- This is either:
155 --
156 -- * the current cost centre stack (CCCS)
157 -- * a pre-defined cost centre stack (there are several
158 -- pre-defined CCSs, see below).
159
160 data CostCentreStack
161 = NoCCS
162
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 , [CostCentre] -- "extern" cost-centres
184 , [CostCentreStack] -- pre-defined "singleton" cost centre stacks
185 )
186
187
188 noCCS, currentCCS, dontCareCCS :: CostCentreStack
189
190 noCCS = NoCCS
191 currentCCS = CurrentCCS
192 dontCareCCS = DontCareCCS
193
194 -----------------------------------------------------------------------------
195 -- Predicates on Cost-Centre Stacks
196
197 noCCSAttached :: CostCentreStack -> Bool
198 noCCSAttached NoCCS = True
199 noCCSAttached _ = False
200
201 isCurrentCCS :: CostCentreStack -> Bool
202 isCurrentCCS CurrentCCS = True
203 isCurrentCCS _ = False
204
205 isCafCCS :: CostCentreStack -> Bool
206 isCafCCS (SingletonCCS cc) = isCafCC cc
207 isCafCCS _ = False
208
209 maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
210 maybeSingletonCCS (SingletonCCS cc) = Just cc
211 maybeSingletonCCS _ = Nothing
212
213 mkSingletonCCS :: CostCentre -> CostCentreStack
214 mkSingletonCCS cc = SingletonCCS cc
215
216
217 -----------------------------------------------------------------------------
218 -- Printing Cost Centre Stacks.
219
220 -- The outputable instance for CostCentreStack prints the CCS as a C
221 -- expression.
222
223 instance Outputable CostCentreStack where
224 ppr NoCCS = text "NO_CCS"
225 ppr CurrentCCS = text "CCCS"
226 ppr DontCareCCS = text "CCS_DONT_CARE"
227 ppr (SingletonCCS cc) = ppr cc <> text "_ccs"
228
229
230 -----------------------------------------------------------------------------
231 -- Printing Cost Centres
232 --
233 -- There are several different ways in which we might want to print a
234 -- cost centre:
235 --
236 -- - the name of the cost centre, for profiling output (a C string)
237 -- - the label, i.e. C label for cost centre in .hc file.
238 -- - the debugging name, for output in -ddump things
239 -- - the interface name, for printing in _scc_ exprs in iface files.
240 --
241 -- The last 3 are derived from costCentreStr below. The first is given
242 -- by costCentreName.
243
244 instance Outputable CostCentre where
245 ppr cc = getPprStyle $ \ sty ->
246 if codeStyle sty
247 then ppCostCentreLbl cc
248 else text (costCentreUserName cc)
249
250 -- Printing in Core
251 pprCostCentreCore :: CostCentre -> SDoc
252 pprCostCentreCore (AllCafsCC {cc_mod = m})
253 = text "__sccC" <+> braces (ppr m)
254 pprCostCentreCore (NormalCC {cc_key = key, cc_name = n, cc_mod = m, cc_loc = loc,
255 cc_is_caf = caf})
256 = text "__scc" <+> braces (hsep [
257 ppr m <> char '.' <> ftext n,
258 whenPprDebug (ppr key),
259 pp_caf caf,
260 whenPprDebug (ppr loc)
261 ])
262
263 pp_caf :: IsCafCC -> SDoc
264 pp_caf CafCC = text "__C"
265 pp_caf _ = empty
266
267 -- Printing as a C label
268 ppCostCentreLbl :: CostCentre -> SDoc
269 ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
270 ppCostCentreLbl (NormalCC {cc_key = k, cc_name = n, cc_mod = m,
271 cc_is_caf = is_caf})
272 = ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
273 case is_caf of { CafCC -> text "CAF"; _ -> ppr (mkUniqueGrimily k)} <> text "_cc"
274
275 -- This is the name to go in the user-displayed string,
276 -- recorded in the cost centre declaration
277 costCentreUserName :: CostCentre -> String
278 costCentreUserName = unpackFS . costCentreUserNameFS
279
280 costCentreUserNameFS :: CostCentre -> FastString
281 costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF"
282 costCentreUserNameFS (NormalCC {cc_name = name, cc_is_caf = is_caf})
283 = case is_caf of
284 CafCC -> mkFastString "CAF:" `appendFS` name
285 _ -> name
286
287 costCentreSrcSpan :: CostCentre -> SrcSpan
288 costCentreSrcSpan = cc_loc
289
290 instance Binary IsCafCC where
291 put_ bh CafCC = do
292 putByte bh 0
293 put_ bh NotCafCC = do
294 putByte bh 1
295 get bh = do
296 h <- getByte bh
297 case h of
298 0 -> do return CafCC
299 _ -> do return NotCafCC
300
301 instance Binary CostCentre where
302 put_ bh (NormalCC aa ab ac _ad ae) = do
303 putByte bh 0
304 put_ bh aa
305 put_ bh ab
306 put_ bh ac
307 put_ bh ae
308 put_ bh (AllCafsCC ae _af) = do
309 putByte bh 1
310 put_ bh ae
311 get bh = do
312 h <- getByte bh
313 case h of
314 0 -> do aa <- get bh
315 ab <- get bh
316 ac <- get bh
317 ae <- get bh
318 return (NormalCC aa ab ac noSrcSpan ae)
319 _ -> do ae <- get bh
320 return (AllCafsCC ae noSrcSpan)
321
322 -- We ignore the SrcSpans in CostCentres when we serialise them,
323 -- and set the SrcSpans to noSrcSpan when deserialising. This is
324 -- ok, because we only need the SrcSpan when declaring the
325 -- CostCentre in the original module, it is not used by importing
326 -- modules.