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