CgTicky.hs 13.7 KB
Newer Older
1 2 3 4
-----------------------------------------------------------------------------
--
-- Code generation for ticky-ticky profiling
--
Simon Marlow's avatar
Simon Marlow committed
5
-- (c) The University of Glasgow 2004-2006
6 7 8
--
-----------------------------------------------------------------------------

Ian Lynagh's avatar
Ian Lynagh committed
9 10 11 12 13 14 15
{-# OPTIONS -fno-warn-tabs #-}
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and
-- detab the module (please do the detabbing in a separate patch). See
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
-- for details

16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42
module CgTicky (
	emitTickyCounter,

	tickyDynAlloc,
	tickyAllocHeap,
	tickyAllocPrim,
	tickyAllocThunk,
	tickyAllocPAP,

	tickyPushUpdateFrame,
	tickyUpdateFrameOmitted,

	tickyEnterDynCon,
	tickyEnterStaticCon,
	tickyEnterViaNode,

	tickyEnterFun, 
	tickyEnterThunk,

	tickyUpdateBhCaf,
	tickyBlackHole,
	tickyUnboxedTupleReturn, tickyVectoredReturn,
	tickyReturnOldCon, tickyReturnNewCon,

	tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
	tickyUnknownCall, tickySlowCallPat,

43
       staticTickyHdr,
44 45
  ) where

46
#include "../includes/dist-derivedconstants/header/DerivedConstants.h"
47 48
	-- For REP_xxx constants, which are MachReps

Simon Marlow's avatar
Simon Marlow committed
49
import ClosureInfo
50 51 52
import CgUtils
import CgMonad

53 54
import OldCmm
import OldCmmUtils
Simon Marlow's avatar
Simon Marlow committed
55 56 57 58
import CLabel

import Name
import Id
59
import IdInfo
Simon Marlow's avatar
Simon Marlow committed
60 61
import BasicTypes
import FastString
62
import Outputable
Ian Lynagh's avatar
Ian Lynagh committed
63
import Module
64 65 66

-- Turgid imports for showTypeCategory
import PrelNames
Simon Marlow's avatar
Simon Marlow committed
67
import TcType
68
import Type
Simon Marlow's avatar
Simon Marlow committed
69 70
import TyCon

71 72
import DynFlags

Simon Marlow's avatar
Simon Marlow committed
73
import Data.Maybe
74 75 76 77 78 79 80 81

-----------------------------------------------------------------------------
--
--		Ticky-ticky profiling
--
-----------------------------------------------------------------------------

staticTickyHdr :: [CmmLit]
82 83 84 85 86 87
-- krc: not using this right now --
-- in the new version of ticky-ticky, we
-- don't change the closure layout.
-- leave it defined, though, to avoid breaking
-- other things.
staticTickyHdr = []
88 89 90 91

emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
emitTickyCounter cl_info args on_stk
  = ifTicky $
Simon Marlow's avatar
Simon Marlow committed
92
    do	{ mod_name <- getModuleName
93 94
	; dflags <- getDynFlags
	; fun_descr_lit <- newStringCLit (fun_descr dflags mod_name)
95
	; arg_descr_lit <- newStringCLit arg_descr
96
	; emitDataLits ticky_ctr_label 	-- Must match layout of StgEntCounter
97 98 99
-- krc: note that all the fields are I32 now; some were I16 before, 
-- but the code generator wasn't handling that properly and it led to chaos, 
-- panic and disorder.
100 101 102
	    [ mkIntCLit dflags 0,
	      mkIntCLit dflags (length args),-- Arity
	      mkIntCLit dflags on_stk,	-- Words passed on stack
103 104
	      fun_descr_lit,
	      arg_descr_lit,
105 106 107
	      zeroCLit dflags, 		-- Entry count
	      zeroCLit dflags, 		-- Allocs
	      zeroCLit dflags 			-- Link
108 109 110
	    ] }
  where
    name = closureName cl_info
111
    ticky_ctr_label = mkRednCountsLabel name NoCafRefs
112
    arg_descr = map (showTypeCategory . idType) args
113
    fun_descr dflags mod_name = ppr_for_ticky_name dflags mod_name name
114 115 116 117

-- When printing the name of a thing in a ticky file, we want to
-- give the module name even for *local* things.   We print
-- just "x (M)" rather that "M.x" to distinguish them from the global kind.
118 119 120 121
ppr_for_ticky_name :: DynFlags -> Module -> Name -> String
ppr_for_ticky_name dflags mod_name name
  | isInternalName name = showSDocDebug dflags (ppr name <+> (parens (ppr mod_name)))
  | otherwise           = showSDocDebug dflags (ppr name)
122 123 124 125

-- -----------------------------------------------------------------------------
-- Ticky stack frames

Ian Lynagh's avatar
Ian Lynagh committed
126
tickyPushUpdateFrame, tickyUpdateFrameOmitted :: Code
127 128
tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
129 130 131 132

-- -----------------------------------------------------------------------------
-- Ticky entries

Ian Lynagh's avatar
Ian Lynagh committed
133 134
tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon,
    tickyEnterStaticThunk, tickyEnterViaNode :: Code
135 136 137 138 139
tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
tickyEnterDynThunk    = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr")
tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr")
tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
140 141 142 143 144 145 146 147 148 149

tickyEnterThunk :: ClosureInfo -> Code
tickyEnterThunk cl_info
  | isStaticClosure cl_info = tickyEnterStaticThunk
  | otherwise		    = tickyEnterDynThunk

tickyBlackHole :: Bool{-updatable-} -> Code
tickyBlackHole updatable
  = ifTicky (bumpTickyCounter ctr)
  where
150 151
    ctr | updatable = fsLit "UPD_BH_SINGLE_ENTRY_ctr"
	| otherwise = fsLit "UPD_BH_UPDATABLE_ctr"
152

Ian Lynagh's avatar
Ian Lynagh committed
153
tickyUpdateBhCaf :: ClosureInfo -> Code
154 155 156
tickyUpdateBhCaf cl_info
  = ifTicky (bumpTickyCounter ctr)
  where
157 158
    ctr | closureUpdReqd cl_info = fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr"
	| otherwise	         = fsLit "UPD_CAF_BH_UPDATABLE_ctr"
159 160 161 162

tickyEnterFun :: ClosureInfo -> Code
tickyEnterFun cl_info
  = ifTicky $ 
163 164
    do  { dflags <- getDynFlags
        ; bumpTickyCounter ctr
165 166
	; fun_ctr_lbl <- getTickyCtrLabel
	; registerTickyCtr fun_ctr_lbl
167
	; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl (oFFSET_StgEntCounter_entry_count dflags))
168
        }
169
  where
170 171
    ctr | isStaticClosure cl_info = fsLit "ENT_STATIC_FUN_DIRECT_ctr"
	| otherwise		  = fsLit "ENT_DYN_FUN_DIRECT_ctr"
172 173 174 175 176 177 178 179

registerTickyCtr :: CLabel -> Code
-- Register a ticky counter
--   if ( ! f_ct.registeredp ) {
--	    f_ct.link = ticky_entry_ctrs; 	/* hook this one onto the front of the list */
--	    ticky_entry_ctrs = & (f_ct);	/* mark it as "registered" */
--	    f_ct.registeredp = 1 }
registerTickyCtr ctr_lbl
180 181
  = do dflags <- getDynFlags
       let -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
182
           test = CmmMachOp (MO_Eq (wordWidth dflags))
183
                     [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl 
184
                                       (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),
185
                      CmmLit (mkIntCLit dflags 0)]
186
           register_stmts
187
             = [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))
188 189 190
                          (CmmLoad ticky_entry_ctrs (bWord dflags))
               , CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
               , CmmStore (CmmLit (cmmLabelOffB ctr_lbl 
191
                                       (oFFSET_StgEntCounter_registeredp dflags)))
192
                          (CmmLit (mkIntCLit dflags 1)) ]
193 194
           ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
       emitIf test (stmtsC register_stmts)
195 196 197

tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
tickyReturnOldCon arity 
198 199
  = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
	         ; bumpHistogram    (fsLit "RET_OLD_hst") arity }
200
tickyReturnNewCon arity 
201 202
  = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
	         ; bumpHistogram    (fsLit "RET_NEW_hst") arity }
203 204 205

tickyUnboxedTupleReturn :: Int -> Code
tickyUnboxedTupleReturn arity
206 207
  = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
 	         ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }
208 209 210

tickyVectoredReturn :: Int -> Code
tickyVectoredReturn family_size 
211 212
  = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr")
		 ; bumpHistogram    (fsLit "RET_VEC_RETURN_hst") family_size }
213 214 215 216 217

-- -----------------------------------------------------------------------------
-- Ticky calls

-- Ticks at a *call site*:
Ian Lynagh's avatar
Ian Lynagh committed
218 219
tickyKnownCallTooFewArgs, tickyKnownCallExact,
    tickyKnownCallExtraArgs, tickyUnknownCall :: Code
220 221 222 223
tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
224 225 226 227

-- Tick for the call pattern at slow call site (i.e. in addition to
-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
tickySlowCallPat :: [CgRep] -> Code
Ian Lynagh's avatar
Ian Lynagh committed
228
tickySlowCallPat _args = return ()
229 230 231
{- LATER: (introduces recursive module dependency now).
  case callPattern args of
    (str, True)  -> bumpTickyCounter' (mkRtsSlowTickyCtrLabel pat)
Ian Lynagh's avatar
Ian Lynagh committed
232
    (str, False) -> bumpTickyCounter  (sLit "TICK_SLOW_CALL_OTHER")
233 234 235 236 237 238 239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255

callPattern :: [CgRep] -> (String,Bool)
callPattern reps 
  | match == length reps = (chars, True)
  | otherwise            = (chars, False)
  where (_,match) = findMatch reps
	chars     = map argChar reps

argChar VoidArg   = 'v'
argChar PtrArg    = 'p'
argChar NonPtrArg = 'n'
argChar LongArg   = 'l'
argChar FloatArg  = 'f'
argChar DoubleArg = 'd'
-}

-- -----------------------------------------------------------------------------
-- Ticky allocation

tickyDynAlloc :: ClosureInfo -> Code
-- Called when doing a dynamic heap allocation
tickyDynAlloc cl_info
  = ifTicky $
256 257 258 259
    case cl_info of {
      ConInfo {} -> tick_alloc_con ;
      ClosureInfo { closureLFInfo = lf_info } -> 
    case lf_info of
260 261 262
	LFCon {}        -> tick_alloc_con
	LFReEntrant {}  -> tick_alloc_fun
	LFThunk {}      -> tick_alloc_thk
263
        -- black hole
264
        _               -> return () }
265 266
  where
	-- will be needed when we fill in stubs
267
    -- _cl_size   = closureSize dflags cl_info
268
--    _slop_size = slopSize cl_info
269 270 271 272 273

    tick_alloc_thk 
	| closureUpdReqd cl_info = tick_alloc_up_thk
	| otherwise	         = tick_alloc_se_thk

274 275 276 277 278 279 280
    -- krc: changed from panic to return () 
    -- just to get something working
    tick_alloc_con = return ()
    tick_alloc_fun = return ()
    tick_alloc_up_thk = return ()
    tick_alloc_se_thk = return ()

281 282

tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> Code
Ian Lynagh's avatar
Ian Lynagh committed
283
tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
284 285

tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
Ian Lynagh's avatar
Ian Lynagh committed
286
tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
287 288

tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
Ian Lynagh's avatar
Ian Lynagh committed
289
tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
290 291 292 293 294

tickyAllocHeap :: VirtualHpOffset -> Code
-- Called when doing a heap check [TICK_ALLOC_HEAP]
tickyAllocHeap hp
  = ifTicky $
295 296
    do  { dflags <- getDynFlags
        ; ticky_ctr <- getTickyCtrLabel
297 298 299 300
	; stmtsC $
	  if hp == 0 then [] 	-- Inside the stmtC to avoid control
	  else [		-- dependency on the argument
		-- Bump the allcoation count in the StgEntCounter
301
	    addToMem (typeWidth REP_StgEntCounter_allocs)
302
			(CmmLit (cmmLabelOffB ticky_ctr 
303
				(oFFSET_StgEntCounter_allocs dflags))) hp,
304
		-- Bump ALLOC_HEAP_ctr
ian@well-typed.com's avatar
ian@well-typed.com committed
305
	    addToMemLbl (cLongWidth dflags) (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1,
306
  		-- Bump ALLOC_HEAP_tot
ian@well-typed.com's avatar
ian@well-typed.com committed
307
	    addToMemLbl (cLongWidth dflags) (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] }
308 309 310 311 312

-- -----------------------------------------------------------------------------
-- Ticky utils

ifTicky :: Code -> Code
313
ifTicky code = do dflags <- getDynFlags
314 315
                  if dopt Opt_Ticky dflags then code
                                           else nopC
316

317
addToMemLbl :: Width -> CLabel -> Int -> CmmStmt
318 319 320
addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n

-- All the ticky-ticky counters are declared "unsigned long" in C
321
bumpTickyCounter :: FastString -> Code
322
bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0)
323

324 325
bumpTickyCounter' :: CmmLit -> Code
-- krc: note that we're incrementing the _entry_count_ field of the ticky counter
ian@well-typed.com's avatar
ian@well-typed.com committed
326 327
bumpTickyCounter' lhs = do dflags <- getDynFlags
                           stmtC (addToMemLong dflags (CmmLit lhs) 1)
328

329
bumpHistogram :: FastString -> Int -> Code
Ian Lynagh's avatar
Ian Lynagh committed
330
bumpHistogram _lbl _n
331
--  = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLong))
332
    = return ()	   -- TEMP SPJ Apr 07
333

Ian Lynagh's avatar
Ian Lynagh committed
334
{-
335 336
bumpHistogramE :: LitString -> CmmExpr -> Code
bumpHistogramE lbl n 
337
  = do  t <- newTemp cLong
338
	stmtC (CmmAssign (CmmLocal t) n)
339
	emitIf (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight]) $
340
		stmtC (CmmAssign (CmmLocal t) eight)
341
	stmtC (addToMemLong (cmmIndexExpr cLongWidth
342
				(CmmLit (CmmLabel (mkRtsDataLabel lbl)))
343
				(CmmReg (CmmLocal t)))
344 345
			    1)
  where 
346
   eight = CmmLit (CmmInt 8 cLongWidth)
Ian Lynagh's avatar
Ian Lynagh committed
347
-}
348 349

------------------------------------------------------------------
ian@well-typed.com's avatar
ian@well-typed.com committed
350 351
addToMemLong :: DynFlags -> CmmExpr -> Int -> CmmStmt
addToMemLong dflags = addToMem (cLongWidth dflags)
352 353 354 355 356 357 358 359 360 361 362 363 364 365 366 367 368 369 370 371 372 373 374 375 376 377 378 379 380 381 382 383 384 385 386 387 388 389 390 391 392 393 394 395 396 397

------------------------------------------------------------------
-- Showing the "type category" for ticky-ticky profiling

showTypeCategory :: Type -> Char
  {-	{C,I,F,D}   char, int, float, double
	T	    tuple
	S	    other single-constructor type
	{c,i,f,d}   unboxed ditto
	t	    *unpacked* tuple
	s	    *unpacked" single-cons...

	v	    void#
	a	    primitive array

	E	    enumeration type
	+	    dictionary, unless it's a ...
	L	    List
	>	    function
	M	    other (multi-constructor) data-con type
	.	    other type
	-	    reserved for others to mark as "uninteresting"
    -}
showTypeCategory ty
  = if isDictTy ty
    then '+'
    else
      case tcSplitTyConApp_maybe ty of
	Nothing -> if isJust (tcSplitFunTy_maybe ty)
		   then '>'
		   else '.'

	Just (tycon, _) ->
          let utc = getUnique tycon in
	  if	  utc == charDataConKey    then 'C'
	  else if utc == intDataConKey     then 'I'
	  else if utc == floatDataConKey   then 'F'
	  else if utc == doubleDataConKey  then 'D'
	  else if utc == charPrimTyConKey  then 'c'
	  else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
		|| utc == addrPrimTyConKey)		   then 'i'
	  else if utc  == floatPrimTyConKey		   then 'f'
	  else if utc  == doublePrimTyConKey		   then 'd'
	  else if isPrimTyCon tycon {- array, we hope -}   then 'A'	-- Bogus
	  else if isEnumerationTyCon tycon		   then 'E'
	  else if isTupleTyCon tycon			   then 'T'
398
	  else if isJust (tyConSingleDataCon_maybe tycon)       then 'S'
399 400
	  else if utc == listTyConKey			   then 'L'
	  else 'M' -- oh, well...