1 -----------------------------------------------------------------------------
3 -- Code generation for ticky-ticky profiling
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
19 tickyUpdateFrameOmitted,
30 tickyUnboxedTupleReturn, tickyVectoredReturn,
31 tickyReturnOldCon, tickyReturnNewCon,
33 tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
34 tickyUnknownCall, tickySlowCallPat,
39 #include "../includes/DerivedConstants.h"
40 -- For REP_xxx constants, which are MachReps
60 -- Turgid imports for showTypeCategory
69 -----------------------------------------------------------------------------
71 -- Ticky-ticky profiling
73 -----------------------------------------------------------------------------
75 staticTickyHdr :: [CmmLit]
76 -- krc: not using this right now --
77 -- in the new version of ticky-ticky, we
78 -- don't change the closure layout.
79 -- leave it defined, though, to avoid breaking
83 emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
84 emitTickyCounter cl_info args on_stk
86 do { mod_name <- getModuleName
87 ; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
88 ; arg_descr_lit <- mkStringCLit arg_descr
89 ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter
90 -- krc: note that all the fields are I32 now; some were I16 before,
91 -- but the code generator wasn't handling that properly and it led to chaos,
92 -- panic and disorder.
94 mkIntCLit (length args),-- Arity
95 mkIntCLit on_stk, -- Words passed on stack
98 zeroCLit, -- Entry count
103 name = closureName cl_info
104 ticky_ctr_label = mkRednCountsLabel name NoCafRefs
105 arg_descr = map (showTypeCategory . idType) args
106 fun_descr mod_name = ppr_for_ticky_name mod_name name
108 -- When printing the name of a thing in a ticky file, we want to
109 -- give the module name even for *local* things. We print
110 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
111 ppr_for_ticky_name :: Module -> Name -> String
112 ppr_for_ticky_name mod_name name
113 | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
114 | otherwise = showSDocDebug (ppr name)
116 -- -----------------------------------------------------------------------------
117 -- Ticky stack frames
119 tickyPushUpdateFrame, tickyUpdateFrameOmitted :: Code
120 tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
121 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
123 -- -----------------------------------------------------------------------------
126 tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon,
127 tickyEnterStaticThunk, tickyEnterViaNode :: Code
128 tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
129 tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr")
130 tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
131 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr")
132 tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
134 tickyEnterThunk :: ClosureInfo -> Code
135 tickyEnterThunk cl_info
136 | isStaticClosure cl_info = tickyEnterStaticThunk
137 | otherwise = tickyEnterDynThunk
139 tickyBlackHole :: Bool{-updatable-} -> Code
140 tickyBlackHole updatable
141 = ifTicky (bumpTickyCounter ctr)
143 ctr | updatable = fsLit "UPD_BH_SINGLE_ENTRY_ctr"
144 | otherwise = fsLit "UPD_BH_UPDATABLE_ctr"
146 tickyUpdateBhCaf :: ClosureInfo -> Code
147 tickyUpdateBhCaf cl_info
148 = ifTicky (bumpTickyCounter ctr)
150 ctr | closureUpdReqd cl_info = fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr"
151 | otherwise = fsLit "UPD_CAF_BH_UPDATABLE_ctr"
153 tickyEnterFun :: ClosureInfo -> Code
154 tickyEnterFun cl_info
156 do { bumpTickyCounter ctr
157 ; fun_ctr_lbl <- getTickyCtrLabel
158 ; registerTickyCtr fun_ctr_lbl
159 ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count)
162 ctr | isStaticClosure cl_info = fsLit "ENT_STATIC_FUN_DIRECT_ctr"
163 | otherwise = fsLit "ENT_DYN_FUN_DIRECT_ctr"
165 registerTickyCtr :: CLabel -> Code
166 -- Register a ticky counter
167 -- if ( ! f_ct.registeredp ) {
168 -- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */
169 -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */
170 -- f_ct.registeredp = 1 }
171 registerTickyCtr ctr_lbl
172 = emitIf test (stmtsC register_stmts)
174 -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
175 test = CmmMachOp (MO_Eq wordWidth)
176 [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
177 oFFSET_StgEntCounter_registeredp)) bWord,
178 CmmLit (mkIntCLit 0)]
180 = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
181 (CmmLoad ticky_entry_ctrs bWord)
182 , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
183 , CmmStore (CmmLit (cmmLabelOffB ctr_lbl
184 oFFSET_StgEntCounter_registeredp))
185 (CmmLit (mkIntCLit 1)) ]
186 ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
188 tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
189 tickyReturnOldCon arity
190 = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
191 ; bumpHistogram (fsLit "RET_OLD_hst") arity }
192 tickyReturnNewCon arity
193 = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
194 ; bumpHistogram (fsLit "RET_NEW_hst") arity }
196 tickyUnboxedTupleReturn :: Int -> Code
197 tickyUnboxedTupleReturn arity
198 = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
199 ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity }
201 tickyVectoredReturn :: Int -> Code
202 tickyVectoredReturn family_size
203 = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr")
204 ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size }
206 -- -----------------------------------------------------------------------------
209 -- Ticks at a *call site*:
210 tickyKnownCallTooFewArgs, tickyKnownCallExact,
211 tickyKnownCallExtraArgs, tickyUnknownCall :: Code
212 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
213 tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
214 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
215 tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
217 -- Tick for the call pattern at slow call site (i.e. in addition to
218 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
219 tickySlowCallPat :: [CgRep] -> Code
220 tickySlowCallPat _args = return ()
221 {- LATER: (introduces recursive module dependency now).
222 case callPattern args of
223 (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
224 (str, False) -> bumpTickyCounter (sLit "TICK_SLOW_CALL_OTHER")
226 callPattern :: [CgRep] -> (String,Bool)
228 | match == length reps = (chars, True)
229 | otherwise = (chars, False)
230 where (_,match) = findMatch reps
231 chars = map argChar reps
233 argChar VoidArg = 'v'
235 argChar NonPtrArg = 'n'
236 argChar LongArg = 'l'
237 argChar FloatArg = 'f'
238 argChar DoubleArg = 'd'
241 -- -----------------------------------------------------------------------------
244 tickyDynAlloc :: ClosureInfo -> Code
245 -- Called when doing a dynamic heap allocation
246 tickyDynAlloc cl_info
248 case smRepClosureType (closureSMRep cl_info) of
249 Just Constr -> tick_alloc_con
250 Just ConstrNoCaf -> tick_alloc_con
251 Just Fun -> tick_alloc_fun
252 Just Thunk -> tick_alloc_thk
253 Just ThunkSelector -> tick_alloc_thk
257 -- will be needed when we fill in stubs
258 _cl_size = closureSize cl_info
259 _slop_size = slopSize cl_info
262 | closureUpdReqd cl_info = tick_alloc_up_thk
263 | otherwise = tick_alloc_se_thk
265 -- krc: changed from panic to return ()
266 -- just to get something working
267 tick_alloc_con = return ()
268 tick_alloc_fun = return ()
269 tick_alloc_up_thk = return ()
270 tick_alloc_se_thk = return ()
273 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code
274 tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
276 tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
277 tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
279 tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
280 tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
282 tickyAllocHeap :: VirtualHpOffset -> Code
283 -- Called when doing a heap check [TICK_ALLOC_HEAP]
286 do { ticky_ctr <- getTickyCtrLabel
288 if hp == 0 then [] -- Inside the stmtC to avoid control
289 else [ -- dependency on the argument
290 -- Bump the allcoation count in the StgEntCounter
291 addToMem (typeWidth REP_StgEntCounter_allocs)
292 (CmmLit (cmmLabelOffB ticky_ctr
293 oFFSET_StgEntCounter_allocs)) hp,
294 -- Bump ALLOC_HEAP_ctr
295 addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1,
296 -- Bump ALLOC_HEAP_tot
297 addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] }
299 -- -----------------------------------------------------------------------------
302 ifTicky :: Code -> Code
303 ifTicky code = do dflags <- getDynFlags
304 if doingTickyProfiling dflags then code
307 addToMemLbl :: Width -> CLabel -> Int -> CmmStmt
308 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
310 -- All the ticky-ticky counters are declared "unsigned long" in C
311 bumpTickyCounter :: FastString -> Code
312 bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0)
314 bumpTickyCounter' :: CmmLit -> Code
315 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
316 bumpTickyCounter' lhs = stmtC (addToMemLong (CmmLit lhs) 1)
318 bumpHistogram :: FastString -> Int -> Code
319 bumpHistogram _lbl _n
320 -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLong))
321 = return () -- TEMP SPJ Apr 07
324 bumpHistogramE :: LitString -> CmmExpr -> Code
326 = do t <- newTemp cLong
327 stmtC (CmmAssign (CmmLocal t) n)
328 emitIf (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight]) $
329 stmtC (CmmAssign (CmmLocal t) eight)
330 stmtC (addToMemLong (cmmIndexExpr cLongWidth
331 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
332 (CmmReg (CmmLocal t)))
335 eight = CmmLit (CmmInt 8 cLongWidth)
338 ------------------------------------------------------------------
339 addToMemLong :: CmmExpr -> Int -> CmmStmt
340 addToMemLong = addToMem cLongWidth
342 ------------------------------------------------------------------
343 -- Showing the "type category" for ticky-ticky profiling
345 showTypeCategory :: Type -> Char
346 {- {C,I,F,D} char, int, float, double
348 S other single-constructor type
349 {c,i,f,d} unboxed ditto
351 s *unpacked" single-cons...
357 + dictionary, unless it's a ...
360 M other (multi-constructor) data-con type
362 - reserved for others to mark as "uninteresting"
368 case tcSplitTyConApp_maybe ty of
369 Nothing -> if isJust (tcSplitFunTy_maybe ty)
374 let utc = getUnique tycon in
375 if utc == charDataConKey then 'C'
376 else if utc == intDataConKey then 'I'
377 else if utc == floatDataConKey then 'F'
378 else if utc == doubleDataConKey then 'D'
379 else if utc == charPrimTyConKey then 'c'
380 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
381 || utc == addrPrimTyConKey) then 'i'
382 else if utc == floatPrimTyConKey then 'f'
383 else if utc == doublePrimTyConKey then 'd'
384 else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
385 else if isEnumerationTyCon tycon then 'E'
386 else if isTupleTyCon tycon then 'T'
387 else if isJust (tyConSingleDataCon_maybe tycon) then 'S'
388 else if utc == listTyConKey then 'L'
389 else 'M' -- oh, well...