Snapshot of codegen refactoring to share with simonpj
[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 <- newStringCLit (fun_descr mod_name)
89 ; arg_descr_lit <- newStringCLit 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 closureLFInfo cl_info of
250 LFCon {} -> tick_alloc_con
251 LFReEntrant {} -> tick_alloc_fun
252 LFThunk {} -> tick_alloc_thk
253 -- black hole
254 _ -> return ()
255 where
256 -- will be needed when we fill in stubs
257 _cl_size = closureSize cl_info
258 -- _slop_size = slopSize cl_info
259
260 tick_alloc_thk
261 | closureUpdReqd cl_info = tick_alloc_up_thk
262 | otherwise = tick_alloc_se_thk
263
264 -- krc: changed from panic to return ()
265 -- just to get something working
266 tick_alloc_con = return ()
267 tick_alloc_fun = return ()
268 tick_alloc_up_thk = return ()
269 tick_alloc_se_thk = return ()
270
271
272 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code
273 tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
274
275 tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
276 tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
277
278 tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
279 tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
280
281 tickyAllocHeap :: VirtualHpOffset -> Code
282 -- Called when doing a heap check [TICK_ALLOC_HEAP]
283 tickyAllocHeap hp
284 = ifTicky $
285 do { ticky_ctr <- getTickyCtrLabel
286 ; stmtsC $
287 if hp == 0 then [] -- Inside the stmtC to avoid control
288 else [ -- dependency on the argument
289 -- Bump the allcoation count in the StgEntCounter
290 addToMem (typeWidth REP_StgEntCounter_allocs)
291 (CmmLit (cmmLabelOffB ticky_ctr
292 oFFSET_StgEntCounter_allocs)) hp,
293 -- Bump ALLOC_HEAP_ctr
294 addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1,
295 -- Bump ALLOC_HEAP_tot
296 addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] }
297
298 -- -----------------------------------------------------------------------------
299 -- Ticky utils
300
301 ifTicky :: Code -> Code
302 ifTicky code = do dflags <- getDynFlags
303 if doingTickyProfiling dflags then code
304 else nopC
305
306 addToMemLbl :: Width -> CLabel -> Int -> CmmStmt
307 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
308
309 -- All the ticky-ticky counters are declared "unsigned long" in C
310 bumpTickyCounter :: FastString -> Code
311 bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0)
312
313 bumpTickyCounter' :: CmmLit -> Code
314 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
315 bumpTickyCounter' lhs = stmtC (addToMemLong (CmmLit lhs) 1)
316
317 bumpHistogram :: FastString -> Int -> Code
318 bumpHistogram _lbl _n
319 -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLong))
320 = return () -- TEMP SPJ Apr 07
321
322 {-
323 bumpHistogramE :: LitString -> CmmExpr -> Code
324 bumpHistogramE lbl n
325 = do t <- newTemp cLong
326 stmtC (CmmAssign (CmmLocal t) n)
327 emitIf (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight]) $
328 stmtC (CmmAssign (CmmLocal t) eight)
329 stmtC (addToMemLong (cmmIndexExpr cLongWidth
330 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
331 (CmmReg (CmmLocal t)))
332 1)
333 where
334 eight = CmmLit (CmmInt 8 cLongWidth)
335 -}
336
337 ------------------------------------------------------------------
338 addToMemLong :: CmmExpr -> Int -> CmmStmt
339 addToMemLong = addToMem cLongWidth
340
341 ------------------------------------------------------------------
342 -- Showing the "type category" for ticky-ticky profiling
343
344 showTypeCategory :: Type -> Char
345 {- {C,I,F,D} char, int, float, double
346 T tuple
347 S other single-constructor type
348 {c,i,f,d} unboxed ditto
349 t *unpacked* tuple
350 s *unpacked" single-cons...
351
352 v void#
353 a primitive array
354
355 E enumeration type
356 + dictionary, unless it's a ...
357 L List
358 > function
359 M other (multi-constructor) data-con type
360 . other type
361 - reserved for others to mark as "uninteresting"
362 -}
363 showTypeCategory ty
364 = if isDictTy ty
365 then '+'
366 else
367 case tcSplitTyConApp_maybe ty of
368 Nothing -> if isJust (tcSplitFunTy_maybe ty)
369 then '>'
370 else '.'
371
372 Just (tycon, _) ->
373 let utc = getUnique tycon in
374 if utc == charDataConKey then 'C'
375 else if utc == intDataConKey then 'I'
376 else if utc == floatDataConKey then 'F'
377 else if utc == doubleDataConKey then 'D'
378 else if utc == charPrimTyConKey then 'c'
379 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
380 || utc == addrPrimTyConKey) then 'i'
381 else if utc == floatPrimTyConKey then 'f'
382 else if utc == doublePrimTyConKey then 'd'
383 else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
384 else if isEnumerationTyCon tycon then 'E'
385 else if isTupleTyCon tycon then 'T'
386 else if isJust (tyConSingleDataCon_maybe tycon) then 'S'
387 else if utc == listTyConKey then 'L'
388 else 'M' -- oh, well...