StgCmmProf.hs 11.8 KB
Newer Older
1 2 3 4 5 6 7 8
-----------------------------------------------------------------------------
--
-- Code generation for profiling
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------

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
module StgCmmProf (
	initCostCentres, ccType, ccsType,
	mkCCostCentre, mkCCostCentreStack,

	-- Cost-centre Profiling
	dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
22 23
        enterCostCentreThunk,
        costCentreFrom,
24
        curCCS, storeCurCCS,
25
        emitSetCCC,
26 27 28 29 30 31 32 33

	saveCurrentCostCentre, restoreCurrentCostCentre,

	-- Lag/drag/void stuff
	ldvEnter, ldvEnterClosure, ldvRecordCreate
  ) where

#include "HsVersions.h"
Simon Marlow's avatar
Simon Marlow committed
34
#include "../includes/MachDeps.h"
35
 -- For WORD_SIZE_IN_BITS only.
Simon Marlow's avatar
Simon Marlow committed
36
#include "../includes/rts/Constants.h"
37 38 39 40 41 42 43 44 45 46
	-- For LDV_CREATE_MASK, LDV_STATE_USE
	-- which are StgWords
#include "../includes/DerivedConstants.h"
	-- For REP_xxx constants, which are MachReps

import StgCmmClosure
import StgCmmUtils
import StgCmmMonad
import SMRep

47
import MkGraph
48
import Cmm
49 50 51 52 53 54 55
import CmmUtils
import CLabel

import qualified Module
import CostCentre
import StaticFlags
import FastString
56
import Module
57
import Constants        -- Lots of field offsets
58 59 60
import Outputable

import Control.Monad
61
import Data.Char (ord)
62 63 64 65 66 67 68 69 70 71 72 73 74 75 76

-----------------------------------------------------------------------------
--
-- Cost-centre-stack Profiling
--
-----------------------------------------------------------------------------

-- Expression representing the current cost centre stack
ccsType :: CmmType 	-- Type of a cost-centre stack
ccsType = bWord

ccType :: CmmType 	-- Type of a cost centre
ccType = bWord

curCCS :: CmmExpr
77
curCCS = CmmReg (CmmGlobal CCCS)
78

79 80
storeCurCCS :: CmmExpr -> CmmAGraph
storeCurCCS e = mkAssign (CmmGlobal CCCS) e
81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152

mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre cc = CmmLabel (mkCCLabel cc)

mkCCostCentreStack :: CostCentreStack -> CmmLit
mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)

costCentreFrom :: CmmExpr 	-- A closure pointer
	       -> CmmExpr	-- The cost centre from that closure
costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) ccsType

staticProfHdr :: CostCentreStack -> [CmmLit]
-- The profiling header words in a static closure
-- Was SET_STATIC_PROF_HDR
staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs, 
			  	  staticLdvInit]

dynProfHdr :: CmmExpr -> [CmmExpr]
-- Profiling header words in a dynamic closure
dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]

initUpdFrameProf :: CmmExpr -> FCode ()
-- Initialise the profiling field of an update frame
initUpdFrameProf frame_amode 
  = ifProfiling $	-- frame->header.prof.ccs = CCCS
    emit (mkStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
	-- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0) 
	-- is unnecessary because it is not used anyhow.

---------------------------------------------------------------------------
-- 	Saving and restoring the current cost centre
---------------------------------------------------------------------------

{-	Note [Saving the current cost centre]
	~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
The current cost centre is like a global register.  Like other 
global registers, it's a caller-saves one.  But consider
	case (f x) of (p,q) -> rhs
Since 'f' may set the cost centre, we must restore it 
before resuming rhs.  So we want code like this:
	local_cc = CCC  -- save
	r = f( x )
	CCC = local_cc  -- restore
That is, we explicitly "save" the current cost centre in
a LocalReg, local_cc; and restore it after the call. The
C-- infrastructure will arrange to save local_cc across the
call. 

The same goes for join points;
	let j x = join-stuff
	in blah-blah
We want this kind of code:
	local_cc = CCC  -- save
	blah-blah
     J: 
        CCC = local_cc  -- restore
-}

saveCurrentCostCentre :: FCode (Maybe LocalReg)
	-- Returns Nothing if profiling is off
saveCurrentCostCentre
  | not opt_SccProfilingOn 
  = return Nothing
  | otherwise
  = do	{ local_cc <- newTemp ccType
	; emit (mkAssign (CmmLocal local_cc) curCCS)
	; return (Just local_cc) }

restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
restoreCurrentCostCentre Nothing 
  = return ()
restoreCurrentCostCentre (Just local_cc)
153
  = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))
154 155 156 157 158 159 160 161


-------------------------------------------------------------------------------
-- Recording allocation in a cost centre
-------------------------------------------------------------------------------

-- | Record the allocation of a closure.  The CmmExpr is the cost
-- centre stack to which to attribute the allocation.
Simon Marlow's avatar
Simon Marlow committed
162 163
profDynAlloc :: SMRep -> CmmExpr -> FCode ()
profDynAlloc rep ccs
164
  = ifProfiling $
Simon Marlow's avatar
Simon Marlow committed
165
    profAlloc (CmmLit (mkIntCLit (heapClosureSize rep))) ccs
166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181 182 183 184 185 186 187 188

-- | Record the allocation of a closure (size is given by a CmmExpr)
-- The size must be in words, because the allocation counter in a CCS counts
-- in words.
profAlloc :: CmmExpr -> CmmExpr -> FCode ()
profAlloc words ccs
  = ifProfiling $
    emit (addToMemE alloc_rep
		(cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
	  	(CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $
		  [CmmMachOp mo_wordSub [words, 
					 CmmLit (mkIntCLit profHdrSize)]]))
		-- subtract the "profiling overhead", which is the
		-- profiling header in a closure.
 where 
	alloc_rep =  REP_CostCentreStack_mem_alloc

-- -----------------------------------------------------------------------
-- Setting the current cost centre on entry to a closure

enterCostCentreThunk :: CmmExpr -> FCode ()
enterCostCentreThunk closure = 
  ifProfiling $ do 
189
    emit $ storeCurCCS (costCentreFrom closure)
190 191 192 193 194 195 196 197 198 199 200 201 202 203 204 205

ifProfiling :: FCode () -> FCode ()
ifProfiling code
  | opt_SccProfilingOn = code
  | otherwise	       = nopC

ifProfilingL :: [a] -> [a]
ifProfilingL xs
  | opt_SccProfilingOn = xs
  | otherwise	       = []


---------------------------------------------------------------
--	Initialising Cost Centres & CCSs
---------------------------------------------------------------

206 207
initCostCentres :: CollectedCCs -> FCode ()
-- Emit the declarations
208
initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
209
  = whenC opt_SccProfilingOn $
210
    do	{ mapM_ emitCostCentreDecl local_CCs
211
        ; mapM_ emitCostCentreStackDecl  singleton_CCSs  }
212 213 214 215


emitCostCentreDecl :: CostCentre -> FCode ()
emitCostCentreDecl cc = do 
216 217 218 219 220
                        -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
  { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
  ; modl  <- newByteStringCLit (bytesFS $ Module.moduleNameFS
                                        $ Module.moduleName
                                        $ cc_mod cc)
221 222
  ; loc <- newStringCLit (showSDoc (ppr (costCentreSrcSpan cc)))
           -- XXX should UTF-8 encode
223 224 225 226 227
                -- All cost centres will be in the main package, since we
                -- don't normally use -auto-all or add SCCs to other packages.
                -- Hence don't emit the package name in the module here.
  ; let lits = [ zero,   	-- StgInt ccID,
	      	 label,	-- char *label,
228 229 230
                 modl,  -- char *module,
                 loc,   -- char *srcloc,
                 zero,  -- StgWord time_ticks
231
              	 zero64,	-- StgWord64 mem_alloc
232
                 is_caf,   -- StgInt is_caf
233
                 zero   -- struct _CostCentre *link
234 235 236
	       ] 
  ; emitDataLits (mkCCLabel cc) lits
  }
237 238 239
  where
     is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
            | otherwise  = zero
240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255

emitCostCentreStackDecl :: CostCentreStack -> FCode ()
emitCostCentreStackDecl ccs 
  = case maybeSingletonCCS ccs of
	Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc)
	Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
  where
     mk_lits cc = zero : 
		  mkCCostCentre cc : 
		  replicate (sizeof_ccs_words - 2) zero
	-- Note: to avoid making any assumptions about how the
	-- C compiler (that compiles the RTS, in particular) does
	-- layouts of structs containing long-longs, simply
	-- pad out the struct with zero words until we hit the
	-- size of the overall struct (which we get via DerivedConstants.h)

Ian Lynagh's avatar
Ian Lynagh committed
256
zero :: CmmLit
257
zero = mkIntCLit 0
Ian Lynagh's avatar
Ian Lynagh committed
258
zero64 :: CmmLit
259 260 261 262 263 264 265 266 267 268 269 270 271
zero64 = CmmInt 0 W64

sizeof_ccs_words :: Int
sizeof_ccs_words 
    -- round up to the next word.
  | ms == 0   = ws
  | otherwise = ws + 1
  where
   (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE

-- ---------------------------------------------------------------------------
-- Set the current cost centre stack

272 273
emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
emitSetCCC cc tick push
274 275 276
  | not opt_SccProfilingOn = nopC
  | otherwise = do 
    tmp <- newTemp ccsType -- TODO FIXME NOW
277 278
    pushCostCentre tmp curCCS cc
    when tick $ emit (bumpSccCount (CmmReg (CmmLocal tmp)))
279
    when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
280 281 282 283

pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre result ccs cc
  = emitRtsCallWithResult result AddrHint
284
	rtsPackageId
285
	(fsLit "PushCostCentre") [(ccs,AddrHint), 
286 287 288 289 290 291 292 293 294 295 296 297 298 299 300 301 302 303 304 305 306 307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324 325 326 327 328 329 330 331 332 333 334 335 336 337 338 339 340 341 342 343 344 345 346 347 348 349 350 351
				(CmmLit (mkCCostCentre cc), AddrHint)]
        False

bumpSccCount :: CmmExpr -> CmmAGraph
bumpSccCount ccs
  = addToMem REP_CostCentreStack_scc_count
	 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1

-----------------------------------------------------------------------------
--
--		Lag/drag/void stuff
--
-----------------------------------------------------------------------------

--
-- Initial value for the LDV field in a static closure
--
staticLdvInit :: CmmLit
staticLdvInit = zeroCLit

--
-- Initial value of the LDV field in a dynamic closure
--
dynLdvInit :: CmmExpr
dynLdvInit =     -- (era << LDV_SHIFT) | LDV_STATE_CREATE  
  CmmMachOp mo_wordOr [
      CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
      CmmLit (mkWordCLit lDV_STATE_CREATE)
  ]
        
--
-- Initialise the LDV word of a new closure
--
ldvRecordCreate :: CmmExpr -> FCode ()
ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit

--
-- Called when a closure is entered, marks the closure as having been "used".
-- The closure is not an 'inherently used' one.
-- The closure is not IND or IND_OLDGEN because neither is considered for LDV
-- profiling.
--
ldvEnterClosure :: ClosureInfo -> FCode ()
ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
  where tag = funTag closure_info
        -- don't forget to substract node's tag
  
ldvEnter :: CmmExpr -> FCode ()
-- Argument is a closure pointer
ldvEnter cl_ptr
  = ifProfiling $
     -- if (era > 0) {
     --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
     --                era | LDV_STATE_USE }
    emit (mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
		(mkStore ldv_wd new_ldv_wd)
		mkNop)
  where
        -- don't forget to substract node's tag
    ldv_wd = ldvWord cl_ptr
    new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
				       (CmmLit (mkWordCLit lDV_CREATE_MASK)))
		 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))

loadEra :: CmmExpr 
loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
352
	  [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt]
353 354 355 356 357 358 359

ldvWord :: CmmExpr -> CmmExpr
-- Takes the address of a closure, and returns 
-- the address of the LDV word in the closure
ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw

-- LDV constants, from ghc/includes/Constants.h
Ian Lynagh's avatar
Ian Lynagh committed
360 361 362 363 364 365 366 367 368 369 370 371
lDV_SHIFT :: Int
lDV_SHIFT = LDV_SHIFT
--lDV_STATE_MASK :: StgWord
--lDV_STATE_MASK   = LDV_STATE_MASK
lDV_CREATE_MASK :: StgWord
lDV_CREATE_MASK  = LDV_CREATE_MASK
--lDV_LAST_MASK :: StgWord
--lDV_LAST_MASK    = LDV_LAST_MASK
lDV_STATE_CREATE :: StgWord
lDV_STATE_CREATE = LDV_STATE_CREATE
lDV_STATE_USE :: StgWord
lDV_STATE_USE    = LDV_STATE_USE
372