1 -----------------------------------------------------------------------------
3 -- Code generation for ticky-ticky profiling
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and fix
12 -- any warnings in the module. See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
26 tickyUpdateFrameOmitted,
37 tickyUnboxedTupleReturn, tickyVectoredReturn,
38 tickyReturnOldCon, tickyReturnNewCon,
40 tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
41 tickyUnknownCall, tickySlowCallPat,
46 #include "HsVersions.h"
47 #include "../includes/DerivedConstants.h"
48 -- For REP_xxx constants, which are MachReps
68 -- Turgid imports for showTypeCategory
75 -----------------------------------------------------------------------------
77 -- Ticky-ticky profiling
79 -----------------------------------------------------------------------------
81 staticTickyHdr :: [CmmLit]
82 -- krc: not using this right now --
83 -- in the new version of ticky-ticky, we
84 -- don't change the closure layout.
85 -- leave it defined, though, to avoid breaking
89 emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
90 emitTickyCounter cl_info args on_stk
92 do { mod_name <- getModuleName
93 ; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
94 ; arg_descr_lit <- mkStringCLit arg_descr
95 ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter
96 -- krc: note that all the fields are I32 now; some were I16 before,
97 -- but the code generator wasn't handling that properly and it led to chaos,
98 -- panic and disorder.
100 mkIntCLit (length args),-- Arity
101 mkIntCLit on_stk, -- Words passed on stack
104 zeroCLit, -- Entry count
109 name = closureName cl_info
110 ticky_ctr_label = mkRednCountsLabel name
111 arg_descr = map (showTypeCategory . idType) args
112 fun_descr mod_name = ppr_for_ticky_name mod_name name
114 -- When printing the name of a thing in a ticky file, we want to
115 -- give the module name even for *local* things. We print
116 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
117 ppr_for_ticky_name mod_name name
118 | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
119 | otherwise = showSDocDebug (ppr name)
121 -- -----------------------------------------------------------------------------
122 -- Ticky stack frames
124 tickyPushUpdateFrame = ifTicky $ bumpTickyCounter SLIT("UPDF_PUSHED_ctr")
125 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter SLIT("UPDF_OMITTED_ctr")
127 -- -----------------------------------------------------------------------------
130 tickyEnterDynCon = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_CON_ctr")
131 tickyEnterDynThunk = ifTicky $ bumpTickyCounter SLIT("ENT_DYN_THK_ctr")
132 tickyEnterStaticCon = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_CON_ctr")
133 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter SLIT("ENT_STATIC_THK_ctr")
134 tickyEnterViaNode = ifTicky $ bumpTickyCounter SLIT("ENT_VIA_NODE_ctr")
136 tickyEnterThunk :: ClosureInfo -> Code
137 tickyEnterThunk cl_info
138 | isStaticClosure cl_info = tickyEnterStaticThunk
139 | otherwise = tickyEnterDynThunk
141 tickyBlackHole :: Bool{-updatable-} -> Code
142 tickyBlackHole updatable
143 = ifTicky (bumpTickyCounter ctr)
145 ctr | updatable = SLIT("UPD_BH_SINGLE_ENTRY_ctr")
146 | otherwise = SLIT("UPD_BH_UPDATABLE_ctr")
148 tickyUpdateBhCaf cl_info
149 = ifTicky (bumpTickyCounter ctr)
151 ctr | closureUpdReqd cl_info = SLIT("UPD_CAF_BH_SINGLE_ENTRY_ctr")
152 | otherwise = SLIT("UPD_CAF_BH_UPDATABLE_ctr")
154 tickyEnterFun :: ClosureInfo -> Code
155 tickyEnterFun cl_info
157 do { bumpTickyCounter ctr
158 ; fun_ctr_lbl <- getTickyCtrLabel
159 ; registerTickyCtr fun_ctr_lbl
160 ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count)
163 ctr | isStaticClosure cl_info = SLIT("ENT_STATIC_FUN_DIRECT_ctr")
164 | otherwise = SLIT("ENT_DYN_FUN_DIRECT_ctr")
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)
175 -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
176 test = CmmMachOp (MO_Eq wordRep)
177 [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
178 oFFSET_StgEntCounter_registeredp)) wordRep,
179 CmmLit (mkIntCLit 0)]
181 = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
182 (CmmLoad ticky_entry_ctrs wordRep)
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 (mkRtsDataLabel SLIT("ticky_entry_ctrs"))
189 tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
190 tickyReturnOldCon arity
191 = ifTicky $ do { bumpTickyCounter SLIT("RET_OLD_ctr")
192 ; bumpHistogram SLIT("RET_OLD_hst") arity }
193 tickyReturnNewCon arity
194 | not opt_DoTickyProfiling = nopC
196 = ifTicky $ do { bumpTickyCounter SLIT("RET_NEW_ctr")
197 ; bumpHistogram SLIT("RET_NEW_hst") arity }
199 tickyUnboxedTupleReturn :: Int -> Code
200 tickyUnboxedTupleReturn arity
201 = ifTicky $ do { bumpTickyCounter SLIT("RET_UNBOXED_TUP_ctr")
202 ; bumpHistogram SLIT("RET_UNBOXED_TUP_hst") arity }
204 tickyVectoredReturn :: Int -> Code
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 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_TOO_FEW_ARGS_ctr")
214 tickyKnownCallExact = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_ctr")
215 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter SLIT("KNOWN_CALL_EXTRA_ARGS_ctr")
216 tickyUnknownCall = ifTicky $ bumpTickyCounter SLIT("UNKNOWN_CALL_ctr")
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")
227 callPattern :: [CgRep] -> (String,Bool)
229 | match == length reps = (chars, True)
230 | otherwise = (chars, False)
231 where (_,match) = findMatch reps
232 chars = map argChar reps
234 argChar VoidArg = 'v'
236 argChar NonPtrArg = 'n'
237 argChar LongArg = 'l'
238 argChar FloatArg = 'f'
239 argChar DoubleArg = 'd'
242 -- -----------------------------------------------------------------------------
245 tickyDynAlloc :: ClosureInfo -> Code
246 -- Called when doing a dynamic heap allocation
247 tickyDynAlloc cl_info
249 case smRepClosureType (closureSMRep cl_info) of
250 Just Constr -> tick_alloc_con
251 Just ConstrNoCaf -> tick_alloc_con
252 Just Fun -> tick_alloc_fun
253 Just Thunk -> tick_alloc_thk
254 Just ThunkSelector -> tick_alloc_thk
258 -- will be needed when we fill in stubs
259 cl_size = closureSize cl_info
260 slop_size = slopSize cl_info
263 | closureUpdReqd cl_info = tick_alloc_up_thk
264 | otherwise = tick_alloc_se_thk
266 -- krc: changed from panic to return ()
267 -- just to get something working
268 tick_alloc_con = return ()
269 tick_alloc_fun = return ()
270 tick_alloc_up_thk = return ()
271 tick_alloc_se_thk = return ()
274 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code
275 tickyAllocPrim hdr goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
277 tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
278 tickyAllocThunk goods slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
280 tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
281 tickyAllocPAP goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
283 tickyAllocHeap :: VirtualHpOffset -> Code
284 -- Called when doing a heap check [TICK_ALLOC_HEAP]
287 do { ticky_ctr <- getTickyCtrLabel
289 if hp == 0 then [] -- Inside the stmtC to avoid control
290 else [ -- dependency on the argument
291 -- Bump the allcoation count in the StgEntCounter
292 addToMem REP_StgEntCounter_allocs
293 (CmmLit (cmmLabelOffB ticky_ctr
294 oFFSET_StgEntCounter_allocs)) hp,
295 -- Bump ALLOC_HEAP_ctr
296 addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_ctr")) 1,
297 -- Bump ALLOC_HEAP_tot
298 addToMemLbl cLongRep (mkRtsDataLabel SLIT("ALLOC_HEAP_tot")) hp] }
300 -- -----------------------------------------------------------------------------
303 ifTicky :: Code -> Code
305 | opt_DoTickyProfiling = code
308 addToMemLbl :: MachRep -> CLabel -> Int -> CmmStmt
309 addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
311 -- All the ticky-ticky counters are declared "unsigned long" in C
312 bumpTickyCounter :: LitString -> Code
313 bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0)
315 bumpTickyCounter' :: CmmLit -> Code
316 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
317 bumpTickyCounter' lhs = stmtC (addToMem cLongRep (CmmLit lhs) 1)
319 addToMemLong = addToMem cLongRep
321 bumpHistogram :: LitString -> Int -> Code
323 -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongRep))
324 = return () -- TEMP SPJ Apr 07
326 bumpHistogramE :: LitString -> CmmExpr -> Code
328 = do t <- newNonPtrTemp cLongRep
329 stmtC (CmmAssign (CmmLocal t) n)
330 emitIf (CmmMachOp (MO_U_Le cLongRep) [CmmReg (CmmLocal t), eight]) $
331 stmtC (CmmAssign (CmmLocal t) eight)
332 stmtC (addToMemLong (cmmIndexExpr cLongRep
333 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
334 (CmmReg (CmmLocal t)))
337 eight = CmmLit (CmmInt 8 cLongRep)
339 ------------------------------------------------------------------
340 -- Showing the "type category" for ticky-ticky profiling
342 showTypeCategory :: Type -> Char
343 {- {C,I,F,D} char, int, float, double
345 S other single-constructor type
346 {c,i,f,d} unboxed ditto
348 s *unpacked" single-cons...
354 + dictionary, unless it's a ...
357 M other (multi-constructor) data-con type
359 - reserved for others to mark as "uninteresting"
365 case tcSplitTyConApp_maybe ty of
366 Nothing -> if isJust (tcSplitFunTy_maybe ty)
371 let utc = getUnique tycon in
372 if utc == charDataConKey then 'C'
373 else if utc == intDataConKey then 'I'
374 else if utc == floatDataConKey then 'F'
375 else if utc == doubleDataConKey then 'D'
376 else if utc == smallIntegerDataConKey ||
377 utc == largeIntegerDataConKey then 'J'
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 (maybeTyConSingleCon tycon) then 'S'
387 else if utc == listTyConKey then 'L'
388 else 'M' -- oh, well...