2 -- Lots of missing type sigs etc
4 -----------------------------------------------------------------------------
6 -- Code generation for ticky-ticky profiling
8 -- (c) The University of Glasgow 2004-2006
10 -----------------------------------------------------------------------------
21 tickySlowCall, tickyDirectCall,
24 tickyUpdateFrameOmitted,
35 tickyUnboxedTupleReturn, tickyVectoredReturn,
36 tickyReturnOldCon, tickyReturnNewCon,
38 tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
39 tickyUnknownCall, tickySlowCallPat,
44 #include "HsVersions.h"
45 #include "../includes/DerivedConstants.h"
46 -- For REP_xxx constants, which are MachReps
67 -- Turgid imports for showTypeCategory
74 -----------------------------------------------------------------------------
76 -- Ticky-ticky profiling
78 -----------------------------------------------------------------------------
80 staticTickyHdr :: [CmmLit]
81 -- krc: not using this right now --
82 -- in the new version of ticky-ticky, we
83 -- don't change the closure layout.
84 -- leave it defined, though, to avoid breaking
88 emitTickyCounter :: ClosureInfo -> [Id] -> FCode ()
89 emitTickyCounter cl_info args
91 do { mod_name <- getModuleName
92 ; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
93 ; arg_descr_lit <- mkStringCLit arg_descr
94 ; emitDataLits ticky_ctr_label -- Must match layout of StgEntCounter
95 -- krc: note that all the fields are I32 now; some were I16 before,
96 -- but the code generator wasn't handling that properly and it led to chaos,
97 -- panic and disorder.
99 mkIntCLit (length args), -- Arity
100 mkIntCLit 0, -- XXX: we no longer know this! Words passed on stack
103 zeroCLit, -- Entry count
108 name = closureName cl_info
109 ticky_ctr_label = mkRednCountsLabel name $ clHasCafRefs cl_info
110 arg_descr = map (showTypeCategory . idType) args
111 fun_descr mod_name = ppr_for_ticky_name mod_name name
113 -- When printing the name of a thing in a ticky file, we want to
114 -- give the module name even for *local* things. We print
115 -- just "x (M)" rather that "M.x" to distinguish them from the global kind.
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 = ifTicky $ bumpTickyCounter (sLit "UPDF_PUSHED_ctr")
124 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (sLit "UPDF_OMITTED_ctr")
126 -- -----------------------------------------------------------------------------
129 tickyEnterDynCon = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_CON_ctr")
130 tickyEnterDynThunk = ifTicky $ bumpTickyCounter (sLit "ENT_DYN_THK_ctr")
131 tickyEnterStaticCon = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_CON_ctr")
132 tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (sLit "ENT_STATIC_THK_ctr")
133 tickyEnterViaNode = ifTicky $ bumpTickyCounter (sLit "ENT_VIA_NODE_ctr")
135 tickyEnterThunk :: ClosureInfo -> FCode ()
136 tickyEnterThunk cl_info
137 | isStaticClosure cl_info = tickyEnterStaticThunk
138 | otherwise = tickyEnterDynThunk
140 tickyBlackHole :: Bool{-updatable-} -> FCode ()
141 tickyBlackHole updatable
142 = ifTicky (bumpTickyCounter ctr)
144 ctr | updatable = (sLit "UPD_BH_SINGLE_ENTRY_ctr")
145 | otherwise = (sLit "UPD_BH_UPDATABLE_ctr")
147 tickyUpdateBhCaf cl_info
148 = ifTicky (bumpTickyCounter ctr)
150 ctr | closureUpdReqd cl_info = (sLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
151 | otherwise = (sLit "UPD_CAF_BH_UPDATABLE_ctr")
153 tickyEnterFun :: ClosureInfo -> FCode ()
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 = (sLit "ENT_STATIC_FUN_DIRECT_ctr")
163 | otherwise = (sLit "ENT_DYN_FUN_DIRECT_ctr")
165 registerTickyCtr :: CLabel -> FCode ()
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 = emit (mkCmmIfThen test (catAGraphs 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 = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
181 (CmmLoad ticky_entry_ctrs bWord)
182 , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
183 , mkStore (CmmLit (cmmLabelOffB ctr_lbl
184 oFFSET_StgEntCounter_registeredp))
185 (CmmLit (mkIntCLit 1)) ]
186 ticky_entry_ctrs = mkLblExpr (mkRtsDataLabel (sLit "ticky_entry_ctrs"))
188 tickyReturnOldCon, tickyReturnNewCon :: Arity -> FCode ()
189 tickyReturnOldCon arity
190 = ifTicky $ do { bumpTickyCounter (sLit "RET_OLD_ctr")
191 ; bumpHistogram (sLit "RET_OLD_hst") arity }
192 tickyReturnNewCon arity
193 | not opt_DoTickyProfiling = nopC
195 = ifTicky $ do { bumpTickyCounter (sLit "RET_NEW_ctr")
196 ; bumpHistogram (sLit "RET_NEW_hst") arity }
198 tickyUnboxedTupleReturn :: Int -> FCode ()
199 tickyUnboxedTupleReturn arity
200 = ifTicky $ do { bumpTickyCounter (sLit "RET_UNBOXED_TUP_ctr")
201 ; bumpHistogram (sLit "RET_UNBOXED_TUP_hst") arity }
203 tickyVectoredReturn :: Int -> FCode ()
204 tickyVectoredReturn family_size
205 = ifTicky $ do { bumpTickyCounter (sLit "VEC_RETURN_ctr")
206 ; bumpHistogram (sLit "RET_VEC_RETURN_hst") family_size }
208 -- -----------------------------------------------------------------------------
211 -- Ticks at a *call site*:
212 tickyDirectCall :: Arity -> [StgArg] -> FCode ()
213 tickyDirectCall arity args
214 | arity == length args = tickyKnownCallExact
215 | otherwise = do tickyKnownCallExtraArgs
216 tickySlowCallPat (map argPrimRep (drop arity args))
218 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
219 tickyKnownCallExact = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_ctr")
220 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (sLit "KNOWN_CALL_EXTRA_ARGS_ctr")
221 tickyUnknownCall = ifTicky $ bumpTickyCounter (sLit "UNKNOWN_CALL_ctr")
223 -- Tick for the call pattern at slow call site (i.e. in addition to
224 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
225 tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
226 tickySlowCall lf_info []
228 tickySlowCall lf_info args
229 = do { if (isKnownFun lf_info)
230 then tickyKnownCallTooFewArgs
231 else tickyUnknownCall
232 ; tickySlowCallPat (map argPrimRep args) }
234 tickySlowCallPat :: [PrimRep] -> FCode ()
235 tickySlowCallPat args = return ()
236 {- LATER: (introduces recursive module dependency now).
237 case callPattern args of
238 (str, True) -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
239 (str, False) -> bumpTickyCounter (sLit "TICK_SLOW_CALL_OTHER")
241 callPattern :: [CgRep] -> (String,Bool)
243 | match == length reps = (chars, True)
244 | otherwise = (chars, False)
245 where (_,match) = findMatch reps
246 chars = map argChar reps
248 argChar VoidArg = 'v'
250 argChar NonPtrArg = 'n'
251 argChar LongArg = 'l'
252 argChar FloatArg = 'f'
253 argChar DoubleArg = 'd'
256 -- -----------------------------------------------------------------------------
259 tickyDynAlloc :: ClosureInfo -> FCode ()
260 -- Called when doing a dynamic heap allocation
261 tickyDynAlloc cl_info
263 case smRepClosureType (closureSMRep cl_info) of
264 Just Constr -> tick_alloc_con
265 Just ConstrNoCaf -> tick_alloc_con
266 Just Fun -> tick_alloc_fun
267 Just Thunk -> tick_alloc_thk
268 Just ThunkSelector -> tick_alloc_thk
272 -- will be needed when we fill in stubs
273 cl_size = closureSize cl_info
274 slop_size = slopSize cl_info
277 | closureUpdReqd cl_info = tick_alloc_up_thk
278 | otherwise = tick_alloc_se_thk
280 -- krc: changed from panic to return ()
281 -- just to get something working
282 tick_alloc_con = return ()
283 tick_alloc_fun = return ()
284 tick_alloc_up_thk = return ()
285 tick_alloc_se_thk = return ()
288 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
289 tickyAllocPrim hdr goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
291 tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
292 tickyAllocThunk goods slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
294 tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
295 tickyAllocPAP goods slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
297 tickyAllocHeap :: VirtualHpOffset -> FCode ()
298 -- Called when doing a heap check [TICK_ALLOC_HEAP]
299 -- Must be lazy in the amount of allocation!
302 do { ticky_ctr <- getTickyCtrLabel
303 ; emit $ catAGraphs $
304 if hp == 0 then [] -- Inside the emitMiddle to avoid control
305 else [ -- dependency on the argument
306 -- Bump the allcoation count in the StgEntCounter
307 addToMem REP_StgEntCounter_allocs
308 (CmmLit (cmmLabelOffB ticky_ctr
309 oFFSET_StgEntCounter_allocs)) hp,
310 -- Bump ALLOC_HEAP_ctr
311 addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_ctr")) 1,
312 -- Bump ALLOC_HEAP_tot
313 addToMemLbl cLong (mkRtsDataLabel (sLit "ALLOC_HEAP_tot")) hp] }
315 -- -----------------------------------------------------------------------------
318 ifTicky :: FCode () -> FCode ()
320 | opt_DoTickyProfiling = code
323 -- All the ticky-ticky counters are declared "unsigned long" in C
324 bumpTickyCounter :: LitString -> FCode ()
325 bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkRtsDataLabel lbl) 0)
327 bumpTickyCounter' :: CmmLit -> FCode ()
328 -- krc: note that we're incrementing the _entry_count_ field of the ticky counter
329 bumpTickyCounter' lhs = emit (addToMem cLong (CmmLit lhs) 1)
331 bumpHistogram :: LitString -> Int -> FCode ()
333 -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth))
334 = return () -- TEMP SPJ Apr 07
336 bumpHistogramE :: LitString -> CmmExpr -> FCode ()
338 = do t <- newTemp cLong
339 emit (mkAssign (CmmLocal t) n)
340 emit (mkCmmIfThen (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight])
341 (mkAssign (CmmLocal t) eight))
343 (cmmIndexExpr cLongWidth
344 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
345 (CmmReg (CmmLocal t)))
348 eight = CmmLit (CmmInt 8 cLongWidth)
350 ------------------------------------------------------------------
351 -- Showing the "type category" for ticky-ticky profiling
353 showTypeCategory :: Type -> Char
354 {- {C,I,F,D} char, int, float, double
356 S other single-constructor type
357 {c,i,f,d} unboxed ditto
359 s *unpacked" single-cons...
365 + dictionary, unless it's a ...
368 M other (multi-constructor) data-con type
370 - reserved for others to mark as "uninteresting"
376 case tcSplitTyConApp_maybe ty of
377 Nothing -> if isJust (tcSplitFunTy_maybe ty)
382 let utc = getUnique tycon in
383 if utc == charDataConKey then 'C'
384 else if utc == intDataConKey then 'I'
385 else if utc == floatDataConKey then 'F'
386 else if utc == doubleDataConKey then 'D'
387 else if utc == charPrimTyConKey then 'c'
388 else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
389 || utc == addrPrimTyConKey) then 'i'
390 else if utc == floatPrimTyConKey then 'f'
391 else if utc == doublePrimTyConKey then 'd'
392 else if isPrimTyCon tycon {- array, we hope -} then 'A' -- Bogus
393 else if isEnumerationTyCon tycon then 'E'
394 else if isTupleTyCon tycon then 'T'
395 else if isJust (tyConSingleDataCon_maybe tycon) then 'S'
396 else if utc == listTyConKey then 'L'
397 else 'M' -- oh, well...