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