1 -----------------------------------------------------------------------------
3 -- Code generation for ticky-ticky profiling
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
18 tickySlowCall, tickyDirectCall,
21 tickyUpdateFrameOmitted,
32 tickyUnboxedTupleReturn, tickyVectoredReturn,
33 tickyReturnOldCon, tickyReturnNewCon,
35 tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
36 tickyUnknownCall, tickySlowCallPat,
41 #include "HsVersions.h"
42 #include "../includes/DerivedConstants.h"
43 -- For REP_xxx constants, which are MachReps
65 -- Turgid imports for showTypeCategory
72 -----------------------------------------------------------------------------
74 -- Ticky-ticky profiling
76 -----------------------------------------------------------------------------
78 staticTickyHdr :: [CmmLit]
79 -- krc: not using this right now --
80 -- in the new version of ticky-ticky, we
81 -- don't change the closure layout.
82 -- leave it defined, though, to avoid breaking
86 emitTickyCounter :: ClosureInfo -> [Id] -> FCode ()
87 emitTickyCounter cl_info args
89 do { mod_name <- getModuleName
90 ; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
91 ; arg_descr_lit <- mkStringCLit arg_descr
92 ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter
93 -- krc: note that all the fields are I32 now; some were I16 before,
94 -- but the code generator wasn't handling that properly and it led to chaos,
95 -- panic and disorder.
97 mkIntCLit (length args), -- Arity
98 mkIntCLit 0, -- XXX: we no longer know this! Words passed on stack
101 zeroCLit, -- Entry count
106 name = closureName cl_info
107 ticky_ctr_label = mkRednCountsLabel name $ clHasCafRefs cl_info
108 arg_descr = map (showTypeCategory . idType) args
109 fun_descr mod_name = ppr_for_ticky_name mod_name name
111 -- When printing the name of a thing in a ticky file, we want to
112 -- give the module name even for *local* things. We print
113 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
114 ppr_for_ticky_name :: Module -> Name -> String
115 ppr_for_ticky_name mod_name name
116 | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
117 | otherwise = showSDocDebug (ppr name)
119 -- -----------------------------------------------------------------------------
120 -- Ticky stack frames
122 tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
123 tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (sLit "UPDF_PUSHED_ctr")
124 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (sLit "UPDF_OMITTED_ctr")
126 -- -----------------------------------------------------------------------------
129 tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon,
130 tickyEnterStaticThunk, tickyEnterViaNode :: FCode ()
131 tickyEnterDynCon = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_CON_ctr")
132 tickyEnterDynThunk = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_THK_ctr")
133 tickyEnterStaticCon = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_CON_ctr")
134 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_THK_ctr")
135 tickyEnterViaNode = ifTicky $ bumpTickyCounter (sLit "ENT_VIA_NODE_ctr")
137 tickyEnterThunk :: ClosureInfo -> FCode ()
138 tickyEnterThunk cl_info
139 | isStaticClosure cl_info = tickyEnterStaticThunk
140 | otherwise = tickyEnterDynThunk
142 tickyBlackHole :: Bool{-updatable-} -> FCode ()
143 tickyBlackHole updatable
144 = ifTicky (bumpTickyCounter ctr)
146 ctr | updatable = (sLit "UPD_BH_SINGLE_ENTRY_ctr")
147 | otherwise = (sLit "UPD_BH_UPDATABLE_ctr")
149 tickyUpdateBhCaf :: ClosureInfo -> FCode ()
150 tickyUpdateBhCaf cl_info
151 = ifTicky (bumpTickyCounter ctr)
153 ctr | closureUpdReqd cl_info = (sLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
154 | otherwise = (sLit "UPD_CAF_BH_UPDATABLE_ctr")
156 tickyEnterFun :: ClosureInfo -> FCode ()
157 tickyEnterFun cl_info
159 do { bumpTickyCounter ctr
160 ; fun_ctr_lbl <- getTickyCtrLabel
161 ; registerTickyCtr fun_ctr_lbl
162 ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count)
165 ctr | isStaticClosure cl_info = (sLit "ENT_STATIC_FUN_DIRECT_ctr")
166 | otherwise = (sLit "ENT_DYN_FUN_DIRECT_ctr")
168 registerTickyCtr :: CLabel -> FCode ()
169 -- Register a ticky counter
170 -- if ( ! f_ct.registeredp ) {
171 -- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */
172 -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */
173 -- f_ct.registeredp = 1 }
174 registerTickyCtr ctr_lbl
175 = emit (mkCmmIfThen test (catAGraphs register_stmts))
177 -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
178 test = CmmMachOp (MO_Eq wordWidth)
179 [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
180 oFFSET_StgEntCounter_registeredp)) bWord,
181 CmmLit (mkIntCLit 0)]
183 = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
184 (CmmLoad ticky_entry_ctrs bWord)
185 , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
186 , mkStore (CmmLit (cmmLabelOffB ctr_lbl
187 oFFSET_StgEntCounter_registeredp))
188 (CmmLit (mkIntCLit 1)) ]
189 ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (sLit "ticky_entry_ctrs"))
191 tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode ()
192 tickyReturnOldCon arity
193 = ifTicky $ do { bumpTickyCounter (sLit "RET_OLD_ctr")
194 ; bumpHistogram (sLit "RET_OLD_hst") arity }
195 tickyReturnNewCon arity
196 = ifTicky $ do { bumpTickyCounter (sLit "RET_NEW_ctr")
197 ; bumpHistogram (sLit "RET_NEW_hst") arity }
199 tickyUnboxedTupleReturn :: Int -> FCode ()
200 tickyUnboxedTupleReturn arity
201 = ifTicky $ do { bumpTickyCounter (sLit "RET_UNBOXED_TUP_ctr")
202 ; bumpHistogram (sLit "RET_UNBOXED_TUP_hst") arity }
204 tickyVectoredReturn :: Int -> FCode ()
205 tickyVectoredReturn family_size
206 = ifTicky $ do { bumpTickyCounter (sLit "VEC_RETURN_ctr")
207 ; bumpHistogram (sLit "RET_VEC_RETURN_hst") family_size }
209 -- -----------------------------------------------------------------------------
212 -- Ticks at a *call site*:
213 tickyDirectCall :: Arity -> [StgArg] -> FCode ()
214 tickyDirectCall arity args
215 | arity == length args = tickyKnownCallExact
216 | otherwise = do tickyKnownCallExtraArgs
217 tickySlowCallPat (map argPrimRep (drop arity args))
219 tickyKnownCallTooFewArgs :: FCode ()
220 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
221 tickyKnownCallExact :: FCode ()
222 tickyKnownCallExact = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_ctr")
223 tickyKnownCallExtraArgs :: FCode ()
224 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_EXTRA_ARGS_ctr")
225 tickyUnknownCall :: FCode ()
226 tickyUnknownCall = ifTicky $ bumpTickyCounter (sLit "UNKNOWN_CALL_ctr")
228 -- Tick for the call pattern at slow call site (i.e. in addition to
229 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
230 tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
233 tickySlowCall lf_info args
234 = do { if (isKnownFun lf_info)
235 then tickyKnownCallTooFewArgs
236 else tickyUnknownCall
237 ; tickySlowCallPat (map argPrimRep args) }
239 tickySlowCallPat :: [PrimRep] -> FCode ()
240 tickySlowCallPat _args = return ()
241 {- LATER: (introduces recursive module dependency now).
242 case callPattern args of
243 (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
244 (str, False) -> bumpTickyCounter (sLit "TICK_SLOW_CALL_OTHER")
246 callPattern :: [CgRep] -> (String,Bool)
248 | match == length reps = (chars, True)
249 | otherwise = (chars, False)
250 where (_,match) = findMatch reps
251 chars = map argChar reps
253 argChar VoidArg = 'v'
255 argChar NonPtrArg = 'n'
256 argChar LongArg = 'l'
257 argChar FloatArg = 'f'
258 argChar DoubleArg = 'd'
261 -- -----------------------------------------------------------------------------
264 tickyDynAlloc :: ClosureInfo -> FCode ()
265 -- Called when doing a dynamic heap allocation
266 tickyDynAlloc cl_info
268 case smRepClosureType (closureSMRep cl_info) of
269 Just Constr -> tick_alloc_con
270 Just ConstrNoCaf -> tick_alloc_con
271 Just Fun -> tick_alloc_fun
272 Just Thunk -> tick_alloc_thk
273 Just ThunkSelector -> tick_alloc_thk
277 -- will be needed when we fill in stubs
278 _cl_size = closureSize cl_info
279 _slop_size = slopSize cl_info
282 | closureUpdReqd cl_info = tick_alloc_up_thk
283 | otherwise = tick_alloc_se_thk
285 -- krc: changed from panic to return ()
286 -- just to get something working
287 tick_alloc_con = return ()
288 tick_alloc_fun = return ()
289 tick_alloc_up_thk = return ()
290 tick_alloc_se_thk = return ()
293 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
294 tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
296 tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
297 tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
299 tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
300 tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
302 tickyAllocHeap :: VirtualHpOffset -> FCode ()
303 -- Called when doing a heap check [TICK_ALLOC_HEAP]
304 -- Must be lazy in the amount of allocation!
307 do { ticky_ctr <- getTickyCtrLabel
308 ; emit $ catAGraphs $
309 if hp == 0 then [] -- Inside the emitMiddle to avoid control
310 else [ -- dependency on the argument
311 -- Bump the allcoation count in the StgEntCounter
312 addToMem REP_StgEntCounter_allocs
313 (CmmLit (cmmLabelOffB ticky_ctr
314 oFFSET_StgEntCounter_allocs)) hp,
315 -- Bump ALLOC_HEAP_ctr
316 addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_ctr")) 1,
317 -- Bump ALLOC_HEAP_tot
318 addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_tot")) hp] }
320 -- -----------------------------------------------------------------------------
323 ifTicky :: FCode () -> FCode ()
325 | opt_DoTickyProfiling = code
328 -- All the ticky-ticky counters are declared "unsigned long" in C
329 bumpTickyCounter :: LitString -> FCode ()
330 bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0)
332 bumpTickyCounter' :: CmmLit -> FCode ()
333 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
334 bumpTickyCounter' lhs = emit (addToMem cLong (CmmLit lhs) 1)
336 bumpHistogram :: LitString -> Int -> FCode ()
337 bumpHistogram _lbl _n
338 -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth))
339 = return () -- TEMP SPJ Apr 07
342 bumpHistogramE :: LitString -> CmmExpr -> FCode ()
344 = do t <- newTemp cLong
345 emit (mkAssign (CmmLocal t) n)
346 emit (mkCmmIfThen (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight])
347 (mkAssign (CmmLocal t) eight))
349 (cmmIndexExpr cLongWidth
350 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
351 (CmmReg (CmmLocal t)))
354 eight = CmmLit (CmmInt 8 cLongWidth)
357 ------------------------------------------------------------------
358 -- Showing the "type category" for ticky-ticky profiling
360 showTypeCategory :: Type -> Char
361 {- {C,I,F,D} char, int, float, double
363 S other single-constructor type
364 {c,i,f,d} unboxed ditto
366 s *unpacked" single-cons...
372 + dictionary, unless it's a ...
375 M other (multi-constructor) data-con type
377 - reserved for others to mark as "uninteresting"
383 case tcSplitTyConApp_maybe ty of
384 Nothing -> if isJust (tcSplitFunTy_maybe ty)
389 let utc = getUnique tycon in
390 if utc == charDataConKey then 'C'
391 else if utc == intDataConKey then 'I'
392 else if utc == floatDataConKey then 'F'
393 else if utc == doubleDataConKey then 'D'
394 else if utc == charPrimTyConKey then 'c'
395 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
396 || utc == addrPrimTyConKey) then 'i'
397 else if utc == floatPrimTyConKey then 'f'
398 else if utc == doublePrimTyConKey then 'd'
399 else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
400 else if isEnumerationTyCon tycon then 'E'
401 else if isTupleTyCon tycon then 'T'
402 else if isJust (tyConSingleDataCon_maybe tycon) then 'S'
403 else if utc == listTyConKey then 'L'
404 else 'M' -- oh, well...