629754fcb53863a7ecbd00e9f35bd67a19c94bd5
[ghc.git] / compiler / codeGen / CgTicky.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for ticky-ticky profiling
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module CgTicky (
10 emitTickyCounter,
11
12 tickyDynAlloc,
13 tickyAllocHeap,
14 tickyAllocPrim,
15 tickyAllocThunk,
16 tickyAllocPAP,
17
18 tickyPushUpdateFrame,
19 tickyUpdateFrameOmitted,
20
21 tickyEnterDynCon,
22 tickyEnterStaticCon,
23 tickyEnterViaNode,
24
25 tickyEnterFun,
26 tickyEnterThunk,
27
28 tickyUpdateBhCaf,
29 tickyBlackHole,
30 tickyUnboxedTupleReturn, tickyVectoredReturn,
31 tickyReturnOldCon, tickyReturnNewCon,
32
33 tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
34 tickyUnknownCall, tickySlowCallPat,
35
36 staticTickyHdr,
37 ) where
38
39 #include "../includes/DerivedConstants.h"
40 -- For REP_xxx constants, which are MachReps
41
42 import ClosureInfo
43 import CgUtils
44 import CgMonad
45 import SMRep
46
47 import OldCmm
48 import OldCmmUtils
49 import CLabel
50
51 import Name
52 import Id
53 import IdInfo
54 import BasicTypes
55 import FastString
56 import Constants
57 import Outputable
58 import Module
59
60 -- Turgid imports for showTypeCategory
61 import PrelNames
62 import TcType
63 import Type
64 import TyCon
65
66 import DynFlags
67
68 import Data.Maybe
69
70 -----------------------------------------------------------------------------
71 --
72 -- Ticky-ticky profiling
73 --
74 -----------------------------------------------------------------------------
75
76 staticTickyHdr :: [CmmLit]
77 -- krc: not using this right now --
78 -- in the new version of ticky-ticky, we
79 -- don't change the closure layout.
80 -- leave it defined, though, to avoid breaking
81 -- other things.
82 staticTickyHdr = []
83
84 emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
85 emitTickyCounter cl_info args on_stk
86 = ifTicky $
87 do { mod_name <- getModuleName
88 ; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
89 ; arg_descr_lit <- mkStringCLit arg_descr
90 ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter
91 -- krc: note that all the fields are I32 now; some were I16 before,
92 -- but the code generator wasn't handling that properly and it led to chaos,
93 -- panic and disorder.
94 [ mkIntCLit 0,
95 mkIntCLit (length args),-- Arity
96 mkIntCLit on_stk, -- Words passed on stack
97 fun_descr_lit,
98 arg_descr_lit,
99 zeroCLit, -- Entry count
100 zeroCLit, -- Allocs
101 zeroCLit -- Link
102 ] }
103 where
104 name = closureName cl_info
105 ticky_ctr_label = mkRednCountsLabel name NoCafRefs
106 arg_descr = map (showTypeCategory . idType) args
107 fun_descr mod_name = ppr_for_ticky_name mod_name name
108
109 -- When printing the name of a thing in a ticky file, we want to
110 -- give the module name even for *local* things. We print
111 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
112 ppr_for_ticky_name :: Module -> Name -> String
113 ppr_for_ticky_name mod_name name
114 | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
115 | otherwise = showSDocDebug (ppr name)
116
117 -- -----------------------------------------------------------------------------
118 -- Ticky stack frames
119
120 tickyPushUpdateFrame, tickyUpdateFrameOmitted :: Code
121 tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
122 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
123
124 -- -----------------------------------------------------------------------------
125 -- Ticky entries
126
127 tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon,
128 tickyEnterStaticThunk, tickyEnterViaNode :: Code
129 tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
130 tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr")
131 tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
132 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr")
133 tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
134
135 tickyEnterThunk :: ClosureInfo -> Code
136 tickyEnterThunk cl_info
137 | isStaticClosure cl_info = tickyEnterStaticThunk
138 | otherwise = tickyEnterDynThunk
139
140 tickyBlackHole :: Bool{-updatable-} -> Code
141 tickyBlackHole updatable
142 = ifTicky (bumpTickyCounter ctr)
143 where
144 ctr | updatable = fsLit "UPD_BH_SINGLE_ENTRY_ctr"
145 | otherwise = fsLit "UPD_BH_UPDATABLE_ctr"
146
147 tickyUpdateBhCaf :: ClosureInfo -> Code
148 tickyUpdateBhCaf cl_info
149 = ifTicky (bumpTickyCounter ctr)
150 where
151 ctr | closureUpdReqd cl_info = fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr"
152 | otherwise = fsLit "UPD_CAF_BH_UPDATABLE_ctr"
153
154 tickyEnterFun :: ClosureInfo -> Code
155 tickyEnterFun cl_info
156 = ifTicky $
157 do { bumpTickyCounter ctr
158 ; fun_ctr_lbl <- getTickyCtrLabel
159 ; registerTickyCtr fun_ctr_lbl
160 ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count)
161 }
162 where
163 ctr | isStaticClosure cl_info = fsLit "ENT_STATIC_FUN_DIRECT_ctr"
164 | otherwise = fsLit "ENT_DYN_FUN_DIRECT_ctr"
165
166 registerTickyCtr :: CLabel -> Code
167 -- Register a ticky counter
168 -- if ( ! f_ct.registeredp ) {
169 -- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */
170 -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */
171 -- f_ct.registeredp = 1 }
172 registerTickyCtr ctr_lbl
173 = emitIf test (stmtsC register_stmts)
174 where
175 -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
176 test = CmmMachOp (MO_Eq wordWidth)
177 [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
178 oFFSET_StgEntCounter_registeredp)) bWord,
179 CmmLit (mkIntCLit 0)]
180 register_stmts
181 = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
182 (CmmLoad ticky_entry_ctrs bWord)
183 , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
184 , CmmStore (CmmLit (cmmLabelOffB ctr_lbl
185 oFFSET_StgEntCounter_registeredp))
186 (CmmLit (mkIntCLit 1)) ]
187 ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
188
189 tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
190 tickyReturnOldCon arity
191 = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
192 ; bumpHistogram (fsLit "RET_OLD_hst") arity }
193 tickyReturnNewCon arity
194 = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
195 ; bumpHistogram (fsLit "RET_NEW_hst") arity }
196
197 tickyUnboxedTupleReturn :: Int -> Code
198 tickyUnboxedTupleReturn arity
199 = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
200 ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity }
201
202 tickyVectoredReturn :: Int -> Code
203 tickyVectoredReturn family_size
204 = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr")
205 ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size }
206
207 -- -----------------------------------------------------------------------------
208 -- Ticky calls
209
210 -- Ticks at a *call site*:
211 tickyKnownCallTooFewArgs, tickyKnownCallExact,
212 tickyKnownCallExtraArgs, tickyUnknownCall :: Code
213 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
214 tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
215 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
216 tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
217
218 -- Tick for the call pattern at slow call site (i.e. in addition to
219 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
220 tickySlowCallPat :: [CgRep] -> Code
221 tickySlowCallPat _args = return ()
222 {- LATER: (introduces recursive module dependency now).
223 case callPattern args of
224 (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
225 (str, False) -> bumpTickyCounter (sLit "TICK_SLOW_CALL_OTHER")
226
227 callPattern :: [CgRep] -> (String,Bool)
228 callPattern reps
229 | match == length reps = (chars, True)
230 | otherwise = (chars, False)
231 where (_,match) = findMatch reps
232 chars = map argChar reps
233
234 argChar VoidArg = 'v'
235 argChar PtrArg = 'p'
236 argChar NonPtrArg = 'n'
237 argChar LongArg = 'l'
238 argChar FloatArg = 'f'
239 argChar DoubleArg = 'd'
240 -}
241
242 -- -----------------------------------------------------------------------------
243 -- Ticky allocation
244
245 tickyDynAlloc :: ClosureInfo -> Code
246 -- Called when doing a dynamic heap allocation
247 tickyDynAlloc cl_info
248 = ifTicky $
249 case smRepClosureType (closureSMRep cl_info) of
250 Just Constr -> tick_alloc_con
251 Just ConstrNoCaf -> tick_alloc_con
252 Just Fun -> tick_alloc_fun
253 Just Thunk -> tick_alloc_thk
254 Just ThunkSelector -> tick_alloc_thk
255 -- black hole
256 Nothing -> return ()
257 where
258 -- will be needed when we fill in stubs
259 _cl_size = closureSize cl_info
260 _slop_size = slopSize cl_info
261
262 tick_alloc_thk
263 | closureUpdReqd cl_info = tick_alloc_up_thk
264 | otherwise = tick_alloc_se_thk
265
266 -- krc: changed from panic to return ()
267 -- just to get something working
268 tick_alloc_con = return ()
269 tick_alloc_fun = return ()
270 tick_alloc_up_thk = return ()
271 tick_alloc_se_thk = return ()
272
273
274 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code
275 tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
276
277 tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
278 tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
279
280 tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
281 tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
282
283 tickyAllocHeap :: VirtualHpOffset -> Code
284 -- Called when doing a heap check [TICK_ALLOC_HEAP]
285 tickyAllocHeap hp
286 = ifTicky $
287 do { ticky_ctr <- getTickyCtrLabel
288 ; stmtsC $
289 if hp == 0 then [] -- Inside the stmtC to avoid control
290 else [ -- dependency on the argument
291 -- Bump the allcoation count in the StgEntCounter
292 addToMem (typeWidth REP_StgEntCounter_allocs)
293 (CmmLit (cmmLabelOffB ticky_ctr
294 oFFSET_StgEntCounter_allocs)) hp,
295 -- Bump ALLOC_HEAP_ctr
296 addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1,
297 -- Bump ALLOC_HEAP_tot
298 addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] }
299
300 -- -----------------------------------------------------------------------------
301 -- Ticky utils
302
303 ifTicky :: Code -> Code
304 ifTicky code = do dflags <- getDynFlags
305 if doingTickyProfiling dflags then code
306 else nopC
307
308 addToMemLbl :: Width -> CLabel -> Int -> CmmStmt
309 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
310
311 -- All the ticky-ticky counters are declared "unsigned long" in C
312 bumpTickyCounter :: FastString -> Code
313 bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0)
314
315 bumpTickyCounter' :: CmmLit -> Code
316 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
317 bumpTickyCounter' lhs = stmtC (addToMemLong (CmmLit lhs) 1)
318
319 bumpHistogram :: FastString -> Int -> Code
320 bumpHistogram _lbl _n
321 -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLong))
322 = return () -- TEMP SPJ Apr 07
323
324 {-
325 bumpHistogramE :: LitString -> CmmExpr -> Code
326 bumpHistogramE lbl n
327 = do t <- newTemp cLong
328 stmtC (CmmAssign (CmmLocal t) n)
329 emitIf (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight]) $
330 stmtC (CmmAssign (CmmLocal t) eight)
331 stmtC (addToMemLong (cmmIndexExpr cLongWidth
332 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
333 (CmmReg (CmmLocal t)))
334 1)
335 where
336 eight = CmmLit (CmmInt 8 cLongWidth)
337 -}
338
339 ------------------------------------------------------------------
340 addToMemLong :: CmmExpr -> Int -> CmmStmt
341 addToMemLong = addToMem cLongWidth
342
343 ------------------------------------------------------------------
344 -- Showing the "type category" for ticky-ticky profiling
345
346 showTypeCategory :: Type -> Char
347 {- {C,I,F,D} char, int, float, double
348 T tuple
349 S other single-constructor type
350 {c,i,f,d} unboxed ditto
351 t *unpacked* tuple
352 s *unpacked" single-cons...
353
354 v void#
355 a primitive array
356
357 E enumeration type
358 + dictionary, unless it's a ...
359 L List
360 > function
361 M other (multi-constructor) data-con type
362 . other type
363 - reserved for others to mark as "uninteresting"
364 -}
365 showTypeCategory ty
366 = if isDictTy ty
367 then '+'
368 else
369 case tcSplitTyConApp_maybe ty of
370 Nothing -> if isJust (tcSplitFunTy_maybe ty)
371 then '>'
372 else '.'
373
374 Just (tycon, _) ->
375 let utc = getUnique tycon in
376 if utc == charDataConKey then 'C'
377 else if utc == intDataConKey then 'I'
378 else if utc == floatDataConKey then 'F'
379 else if utc == doubleDataConKey then 'D'
380 else if utc == charPrimTyConKey then 'c'
381 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
382 || utc == addrPrimTyConKey) then 'i'
383 else if utc == floatPrimTyConKey then 'f'
384 else if utc == doublePrimTyConKey then 'd'
385 else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
386 else if isEnumerationTyCon tycon then 'E'
387 else if isTupleTyCon tycon then 'T'
388 else if isJust (tyConSingleDataCon_maybe tycon) then 'S'
389 else if utc == listTyConKey then 'L'
390 else 'M' -- oh, well...