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