1 -----------------------------------------------------------------------------
3 -- Code generation for ticky-ticky profiling
5 -- (c) The University of Glasgow 2004
7 -----------------------------------------------------------------------------
19 tickyUpdateFrameOmitted,
30 tickyUnboxedTupleReturn, tickyVectoredReturn,
31 tickyReturnOldCon, tickyReturnNewCon,
33 tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
34 tickyUnknownCall, tickySlowCallPat,
39 #include "HsVersions.h"
40 #include "../includes/DerivedConstants.h"
41 -- For REP_xxx constants, which are MachReps
43 import ClosureInfo ( ClosureInfo, closureSize, slopSize, closureSMRep,
44 closureUpdReqd, closureName, isStaticClosure )
47 import SMRep ( ClosureType(..), smRepClosureType, CgRep )
51 import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr, cmmIndexExpr )
52 import CLabel ( CLabel, mkRtsDataLabel, mkRednCountsLabel )
54 import Name ( isInternalName )
55 import Id ( Id, idType )
56 import StaticFlags ( opt_DoTickyProfiling )
57 import BasicTypes ( Arity )
58 import FastString ( FastString, mkFastString, LitString )
59 import Constants -- Lots of field offsets
62 -- Turgid imports for showTypeCategory
64 import TcType ( Type, isDictTy, tcSplitTyConApp_maybe,
66 import TyCon ( isPrimTyCon, isTupleTyCon, isEnumerationTyCon,
70 -----------------------------------------------------------------------------
72 -- Ticky-ticky profiling
74 -----------------------------------------------------------------------------
76 staticTickyHdr :: [CmmLit]
77 -- The ticky header words in a static closure
78 -- Was SET_STATIC_TICKY_HDR
80 | not opt_DoTickyProfiling = []
81 | otherwise = [zeroCLit]
83 emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
84 emitTickyCounter cl_info args on_stk
86 do { mod_name <- moduleName
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
91 CmmInt (fromIntegral (length args)) I16, -- Arity
92 CmmInt (fromIntegral on_stk) I16, -- Words passed on stack
93 CmmInt 0 I16, -- 2-byte gap
96 zeroCLit, -- Entry count
101 name = closureName cl_info
102 ticky_ctr_label = mkRednCountsLabel name
103 arg_descr = map (showTypeCategory . idType) args
104 fun_descr mod_name = ppr_for_ticky_name mod_name name
106 -- When printing the name of a thing in a ticky file, we want to
107 -- give the module name even for *local* things. We print
108 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
109 ppr_for_ticky_name mod_name name
110 | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
111 | otherwise = showSDocDebug (ppr name)
113 -- -----------------------------------------------------------------------------
114 -- Ticky stack frames
116 tickyPushUpdateFrame = ifTicky $ bumpTickyCounter SLIT("UPDF_PUSHED_ctr")
117 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter SLIT("UPDF_OMITTED_ctr")
119 -- -----------------------------------------------------------------------------
122 tickyEnterDynCon = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_CON_ctr")
123 tickyEnterDynThunk = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_THK_ctr")
124 tickyEnterStaticCon = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_CON_ctr")
125 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_THK_ctr")
126 tickyEnterViaNode = ifTicky $ bumpTickyCounter SLIT("ENT_VIA_NODE_ctr")
128 tickyEnterThunk :: ClosureInfo -> Code
129 tickyEnterThunk cl_info
130 | isStaticClosure cl_info = tickyEnterStaticThunk
131 | otherwise = tickyEnterDynThunk
133 tickyBlackHole :: Bool{-updatable-} -> Code
134 tickyBlackHole updatable
135 = ifTicky (bumpTickyCounter ctr)
137 ctr | updatable = SLIT("UPD_BH_SINGLE_ENTRY_ctr")
138 | otherwise = SLIT("UPD_BH_UPDATABLE_ctr")
140 tickyUpdateBhCaf cl_info
141 = ifTicky (bumpTickyCounter ctr)
143 ctr | closureUpdReqd cl_info = SLIT("UPD_CAF_BH_SINGLE_ENTRY_ctr")
144 | otherwise = SLIT("UPD_CAF_BH_UPDATABLE_ctr")
146 tickyEnterFun :: ClosureInfo -> Code
147 tickyEnterFun cl_info
149 do { bumpTickyCounter ctr
150 ; fun_ctr_lbl <- getTickyCtrLabel
151 ; registerTickyCtr fun_ctr_lbl
152 ; bumpTickyCounter' fun_ctr_lbl }
154 ctr | isStaticClosure cl_info = SLIT("TICK_ENT_STATIC_FUN_DIRECT")
155 | otherwise = SLIT("TICK_ENT_DYN_FUN_DIRECT")
157 registerTickyCtr :: CLabel -> Code
158 -- Register a ticky counter
159 -- if ( ! f_ct.registeredp ) {
160 -- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */
161 -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */
162 -- f_ct.registeredp = 1 }
163 registerTickyCtr ctr_lbl
164 = emitIf test (stmtsC register_stmts)
166 test = CmmMachOp (MO_Not I16)
167 [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
168 oFFSET_StgEntCounter_registeredp)) I16]
170 = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
171 (CmmLoad ticky_entry_ctrs wordRep)
172 , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
173 , CmmStore (CmmLit (cmmLabelOffB ctr_lbl
174 oFFSET_StgEntCounter_registeredp))
175 (CmmLit (mkIntCLit 1)) ]
176 ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel SLIT("ticky_entry_ctrs"))
178 tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
179 tickyReturnOldCon arity
180 = ifTicky $ do { bumpTickyCounter SLIT("RET_OLD_ctr")
181 ; bumpHistogram SLIT("RET_OLD_hst") arity }
182 tickyReturnNewCon arity
183 | not opt_DoTickyProfiling = nopC
185 = ifTicky $ do { bumpTickyCounter SLIT("RET_NEW_ctr")
186 ; bumpHistogram SLIT("RET_NEW_hst") arity }
188 tickyUnboxedTupleReturn :: Int -> Code
189 tickyUnboxedTupleReturn arity
190 = ifTicky $ do { bumpTickyCounter SLIT("RET_UNBOXED_TUP_ctr")
191 ; bumpHistogram SLIT("RET_UNBOXED_TUP_hst") arity }
193 tickyVectoredReturn :: Int -> Code
194 tickyVectoredReturn family_size
195 = ifTicky $ do { bumpTickyCounter SLIT("VEC_RETURN_ctr")
196 ; bumpHistogram SLIT("RET_VEC_RETURN_hst") family_size }
198 -- -----------------------------------------------------------------------------
201 -- Ticks at a *call site*:
202 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_TOO_FEW_ARGS_ctr")
203 tickyKnownCallExact = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_ctr")
204 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_EXTRA_ctr")
205 tickyUnknownCall = ifTicky $ bumpTickyCounter SLIT("UNKNOWN_CALL_ctr")
207 -- Tick for the call pattern at slow call site (i.e. in addition to
208 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
209 tickySlowCallPat :: [CgRep] -> Code
210 tickySlowCallPat args = return ()
211 {- LATER: (introduces recursive module dependency now).
212 case callPattern args of
213 (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
214 (str, False) -> bumpTickyCounter SLIT("TICK_SLOW_CALL_OTHER")
216 callPattern :: [CgRep] -> (String,Bool)
218 | match == length reps = (chars, True)
219 | otherwise = (chars, False)
220 where (_,match) = findMatch reps
221 chars = map argChar reps
223 argChar VoidArg = 'v'
225 argChar NonPtrArg = 'n'
226 argChar LongArg = 'l'
227 argChar FloatArg = 'f'
228 argChar DoubleArg = 'd'
231 -- -----------------------------------------------------------------------------
234 tickyDynAlloc :: ClosureInfo -> Code
235 -- Called when doing a dynamic heap allocation
236 tickyDynAlloc cl_info
238 case smRepClosureType (closureSMRep cl_info) of
239 Constr -> tick_alloc_con
240 ConstrNoCaf -> tick_alloc_con
241 Fun -> tick_alloc_fun
242 Thunk -> tick_alloc_thk
243 ThunkSelector -> tick_alloc_thk
245 -- will be needed when we fill in stubs
246 cl_size = closureSize cl_info
247 slop_size = slopSize cl_info
250 | closureUpdReqd cl_info = tick_alloc_up_thk
251 | otherwise = tick_alloc_se_thk
253 tick_alloc_con = panic "ToDo: tick_alloc"
254 tick_alloc_fun = panic "ToDo: tick_alloc"
255 tick_alloc_up_thk = panic "ToDo: tick_alloc"
256 tick_alloc_se_thk = panic "ToDo: tick_alloc"
258 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code
259 tickyAllocPrim hdr goods slop = ifTicky $ panic "ToDo: tickyAllocPrim"
261 tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
262 tickyAllocThunk goods slop = ifTicky $ panic "ToDo: tickyAllocThunk"
264 tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
265 tickyAllocPAP goods slop = ifTicky $ panic "ToDo: tickyAllocPAP"
267 tickyAllocHeap :: VirtualHpOffset -> Code
268 -- Called when doing a heap check [TICK_ALLOC_HEAP]
271 do { ticky_ctr <- getTickyCtrLabel
273 if hp == 0 then [] -- Inside the stmtC to avoid control
274 else [ -- dependency on the argument
275 -- Bump the allcoation count in the StgEntCounter
276 addToMem REP_StgEntCounter_allocs
277 (CmmLit (cmmLabelOffB ticky_ctr
278 oFFSET_StgEntCounter_allocs)) hp,
279 -- Bump ALLOC_HEAP_ctr
280 addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_ctr")) 1,
281 -- Bump ALLOC_HEAP_tot
282 addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_tot")) hp] }
284 -- -----------------------------------------------------------------------------
287 ifTicky :: Code -> Code
289 | opt_DoTickyProfiling = code
292 addToMemLbl :: MachRep -> CLabel -> Int -> CmmStmt
293 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
295 -- All the ticky-ticky counters are declared "unsigned long" in C
296 bumpTickyCounter :: LitString -> Code
297 bumpTickyCounter lbl = bumpTickyCounter' (mkRtsDataLabel lbl)
299 bumpTickyCounter' :: CLabel -> Code
300 bumpTickyCounter' lbl = stmtC (addToMemLbl cLongRep lbl 1)
302 addToMemLong = addToMem cLongRep
304 bumpHistogram :: LitString -> Int -> Code
306 = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongRep))
308 bumpHistogramE :: LitString -> CmmExpr -> Code
310 = do t <- newTemp cLongRep
311 stmtC (CmmAssign t n)
312 emitIf (CmmMachOp (MO_U_Le cLongRep) [CmmReg t, eight]) $
313 stmtC (CmmAssign t eight)
314 stmtC (addToMemLong (cmmIndexExpr cLongRep
315 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
319 eight = CmmLit (CmmInt 8 cLongRep)
321 ------------------------------------------------------------------
322 -- Showing the "type category" for ticky-ticky profiling
324 showTypeCategory :: Type -> Char
325 {- {C,I,F,D} char, int, float, double
327 S other single-constructor type
328 {c,i,f,d} unboxed ditto
330 s *unpacked" single-cons...
336 + dictionary, unless it's a ...
339 M other (multi-constructor) data-con type
341 - reserved for others to mark as "uninteresting"
347 case tcSplitTyConApp_maybe ty of
348 Nothing -> if isJust (tcSplitFunTy_maybe ty)
353 let utc = getUnique tycon in
354 if utc == charDataConKey then 'C'
355 else if utc == intDataConKey then 'I'
356 else if utc == floatDataConKey then 'F'
357 else if utc == doubleDataConKey then 'D'
358 else if utc == smallIntegerDataConKey ||
359 utc == largeIntegerDataConKey then 'J'
360 else if utc == charPrimTyConKey then 'c'
361 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
362 || utc == addrPrimTyConKey) then 'i'
363 else if utc == floatPrimTyConKey then 'f'
364 else if utc == doublePrimTyConKey then 'd'
365 else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
366 else if isEnumerationTyCon tycon then 'E'
367 else if isTupleTyCon tycon then 'T'
368 else if isJust (maybeTyConSingleCon tycon) then 'S'
369 else if utc == listTyConKey then 'L'
370 else 'M' -- oh, well...