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
66 -- Turgid imports for showTypeCategory
73 -----------------------------------------------------------------------------
75 -- Ticky-ticky profiling
77 -----------------------------------------------------------------------------
79 staticTickyHdr :: [CmmLit]
80 -- krc: not using this right now --
81 -- in the new version of ticky-ticky, we
82 -- don't change the closure layout.
83 -- leave it defined, though, to avoid breaking
87 emitTickyCounter :: ClosureInfo -> [Id] -> FCode ()
88 emitTickyCounter cl_info args
90 do { mod_name <- getModuleName
91 ; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
92 ; arg_descr_lit <- mkStringCLit arg_descr
93 ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter
94 -- krc: note that all the fields are I32 now; some were I16 before,
95 -- but the code generator wasn't handling that properly and it led to chaos,
96 -- panic and disorder.
98 mkIntCLit (length args), -- Arity
99 mkIntCLit 0, -- XXX: we no longer know this! Words passed on stack
102 zeroCLit, -- Entry count
107 name = closureName cl_info
108 ticky_ctr_label = mkRednCountsLabel name $ clHasCafRefs cl_info
109 arg_descr = map (showTypeCategory . idType) args
110 fun_descr mod_name = ppr_for_ticky_name mod_name name
112 -- When printing the name of a thing in a ticky file, we want to
113 -- give the module name even for *local* things. We print
114 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
115 ppr_for_ticky_name :: Module -> Name -> String
116 ppr_for_ticky_name mod_name name
117 | isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
118 | otherwise = showSDocDebug (ppr name)
120 -- -----------------------------------------------------------------------------
121 -- Ticky stack frames
123 tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
124 tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
125 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
127 -- -----------------------------------------------------------------------------
130 tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon,
131 tickyEnterStaticThunk, tickyEnterViaNode :: FCode ()
132 tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
133 tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr")
134 tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
135 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr")
136 tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
138 tickyEnterThunk :: ClosureInfo -> FCode ()
139 tickyEnterThunk cl_info
140 | isStaticClosure cl_info = tickyEnterStaticThunk
141 | otherwise = tickyEnterDynThunk
143 tickyBlackHole :: Bool{-updatable-} -> FCode ()
144 tickyBlackHole updatable
145 = ifTicky (bumpTickyCounter ctr)
147 ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")
148 | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")
150 tickyUpdateBhCaf :: ClosureInfo -> FCode ()
151 tickyUpdateBhCaf cl_info
152 = ifTicky (bumpTickyCounter ctr)
154 ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
155 | otherwise = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")
157 tickyEnterFun :: ClosureInfo -> FCode ()
158 tickyEnterFun cl_info
160 do { bumpTickyCounter ctr
161 ; fun_ctr_lbl <- getTickyCtrLabel
162 ; registerTickyCtr fun_ctr_lbl
163 ; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count)
166 ctr | isStaticClosure cl_info = (fsLit "ENT_STATIC_FUN_DIRECT_ctr")
167 | otherwise = (fsLit "ENT_DYN_FUN_DIRECT_ctr")
169 registerTickyCtr :: CLabel -> FCode ()
170 -- Register a ticky counter
171 -- if ( ! f_ct.registeredp ) {
172 -- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */
173 -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */
174 -- f_ct.registeredp = 1 }
175 registerTickyCtr ctr_lbl
176 = emit (mkCmmIfThen test (catAGraphs register_stmts))
178 -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
179 test = CmmMachOp (MO_Eq wordWidth)
180 [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
181 oFFSET_StgEntCounter_registeredp)) bWord,
182 CmmLit (mkIntCLit 0)]
184 = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
185 (CmmLoad ticky_entry_ctrs bWord)
186 , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
187 , mkStore (CmmLit (cmmLabelOffB ctr_lbl
188 oFFSET_StgEntCounter_registeredp))
189 (CmmLit (mkIntCLit 1)) ]
190 ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
192 tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode ()
193 tickyReturnOldCon arity
194 = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
195 ; bumpHistogram (fsLit "RET_OLD_hst") arity }
196 tickyReturnNewCon arity
197 = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
198 ; bumpHistogram (fsLit "RET_NEW_hst") arity }
200 tickyUnboxedTupleReturn :: Int -> FCode ()
201 tickyUnboxedTupleReturn arity
202 = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
203 ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity }
205 tickyVectoredReturn :: Int -> FCode ()
206 tickyVectoredReturn family_size
207 = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr")
208 ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size }
210 -- -----------------------------------------------------------------------------
213 -- Ticks at a *call site*:
214 tickyDirectCall :: Arity -> [StgArg] -> FCode ()
215 tickyDirectCall arity args
216 | arity == length args = tickyKnownCallExact
217 | otherwise = do tickyKnownCallExtraArgs
218 tickySlowCallPat (map argPrimRep (drop arity args))
220 tickyKnownCallTooFewArgs :: FCode ()
221 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
223 tickyKnownCallExact :: FCode ()
224 tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
226 tickyKnownCallExtraArgs :: FCode ()
227 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
229 tickyUnknownCall :: FCode ()
230 tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
232 -- Tick for the call pattern at slow call site (i.e. in addition to
233 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
234 tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
237 tickySlowCall lf_info args
238 = do { if (isKnownFun lf_info)
239 then tickyKnownCallTooFewArgs
240 else tickyUnknownCall
241 ; tickySlowCallPat (map argPrimRep args) }
243 tickySlowCallPat :: [PrimRep] -> FCode ()
244 tickySlowCallPat _args = return ()
245 {- LATER: (introduces recursive module dependency now).
246 case callPattern args of
247 (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
248 (str, False) -> bumpTickyCounter (sLit "TICK_SLOW_CALL_OTHER")
250 callPattern :: [CgRep] -> (String,Bool)
252 | match == length reps = (chars, True)
253 | otherwise = (chars, False)
254 where (_,match) = findMatch reps
255 chars = map argChar reps
257 argChar VoidArg = 'v'
259 argChar NonPtrArg = 'n'
260 argChar LongArg = 'l'
261 argChar FloatArg = 'f'
262 argChar DoubleArg = 'd'
265 -- -----------------------------------------------------------------------------
268 tickyDynAlloc :: ClosureInfo -> FCode ()
269 -- Called when doing a dynamic heap allocation
270 tickyDynAlloc cl_info
272 case smRepClosureType (closureSMRep cl_info) of
273 Just Constr -> tick_alloc_con
274 Just ConstrNoCaf -> tick_alloc_con
275 Just Fun -> tick_alloc_fun
276 Just Thunk -> tick_alloc_thk
277 Just ThunkSelector -> tick_alloc_thk
281 -- will be needed when we fill in stubs
282 _cl_size = closureSize cl_info
283 _slop_size = slopSize cl_info
286 | closureUpdReqd cl_info = tick_alloc_up_thk
287 | otherwise = tick_alloc_se_thk
289 -- krc: changed from panic to return ()
290 -- just to get something working
291 tick_alloc_con = return ()
292 tick_alloc_fun = return ()
293 tick_alloc_up_thk = return ()
294 tick_alloc_se_thk = return ()
297 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
298 tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
300 tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
301 tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
303 tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
304 tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
306 tickyAllocHeap :: VirtualHpOffset -> FCode ()
307 -- Called when doing a heap check [TICK_ALLOC_HEAP]
308 -- Must be lazy in the amount of allocation!
311 do { ticky_ctr <- getTickyCtrLabel
312 ; emit $ catAGraphs $
313 if hp == 0 then [] -- Inside the emitMiddle to avoid control
314 else [ -- dependency on the argument
315 -- Bump the allcoation count in the StgEntCounter
316 addToMem REP_StgEntCounter_allocs
317 (CmmLit (cmmLabelOffB ticky_ctr
318 oFFSET_StgEntCounter_allocs)) hp,
319 -- Bump ALLOC_HEAP_ctr
320 addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1,
321 -- Bump ALLOC_HEAP_tot
322 addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) hp] }
324 -- -----------------------------------------------------------------------------
327 ifTicky :: FCode () -> FCode ()
328 ifTicky code = do dflags <- getDynFlags
329 if doingTickyProfiling dflags then code
332 -- All the ticky-ticky counters are declared "unsigned long" in C
333 bumpTickyCounter :: FastString -> FCode ()
334 bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0)
336 bumpTickyCounter' :: CmmLit -> FCode ()
337 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
338 bumpTickyCounter' lhs = emit (addToMem cLong (CmmLit lhs) 1)
340 bumpHistogram :: FastString -> Int -> FCode ()
341 bumpHistogram _lbl _n
342 -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth))
343 = return () -- TEMP SPJ Apr 07
346 bumpHistogramE :: LitString -> CmmExpr -> FCode ()
348 = do t <- newTemp cLong
349 emit (mkAssign (CmmLocal t) n)
350 emit (mkCmmIfThen (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight])
351 (mkAssign (CmmLocal t) eight))
353 (cmmIndexExpr cLongWidth
354 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
355 (CmmReg (CmmLocal t)))
358 eight = CmmLit (CmmInt 8 cLongWidth)
361 ------------------------------------------------------------------
362 -- Showing the "type category" for ticky-ticky profiling
364 showTypeCategory :: Type -> Char
365 {- {C,I,F,D} char, int, float, double
367 S other single-constructor type
368 {c,i,f,d} unboxed ditto
370 s *unpacked" single-cons...
376 + dictionary, unless it's a ...
379 M other (multi-constructor) data-con type
381 - reserved for others to mark as "uninteresting"
387 case tcSplitTyConApp_maybe ty of
388 Nothing -> if isJust (tcSplitFunTy_maybe ty)
393 let utc = getUnique tycon in
394 if utc == charDataConKey then 'C'
395 else if utc == intDataConKey then 'I'
396 else if utc == floatDataConKey then 'F'
397 else if utc == doubleDataConKey then 'D'
398 else if utc == charPrimTyConKey then 'c'
399 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
400 || utc == addrPrimTyConKey) then 'i'
401 else if utc == floatPrimTyConKey then 'f'
402 else if utc == doublePrimTyConKey then 'd'
403 else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
404 else if isEnumerationTyCon tycon then 'E'
405 else if isTupleTyCon tycon then 'T'
406 else if isJust (tyConSingleDataCon_maybe tycon) then 'S'
407 else if utc == listTyConKey then 'L'
408 else 'M' -- oh, well...