CgProf.hs 10.4 KB
Newer Older
1
2
3
4
-----------------------------------------------------------------------------
--
-- Code generation for 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
module CgProf (
	mkCCostCentre, mkCCostCentreStack,

	-- Cost-centre Profiling
20
21
22
23
        dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
        enterCostCentreThunk,
        enterCostCentreFun,
        costCentreFrom,
24
        curCCS, storeCurCCS,
25
	emitCostCentreDecl, emitCostCentreStackDecl, 
26
        emitSetCCC,
27
28

	-- Lag/drag/void stuff
Simon Marlow's avatar
Simon Marlow committed
29
	ldvEnter, ldvEnterClosure, ldvRecordCreate
30
31
32
  ) where

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

Simon Marlow's avatar
Simon Marlow committed
41
import ClosureInfo
42
43
import CgUtils
import CgMonad
Simon Marlow's avatar
Simon Marlow committed
44
import SMRep
45

46
47
import OldCmm
import OldCmmUtils
Simon Marlow's avatar
Simon Marlow committed
48
import CLabel
49

Simon Marlow's avatar
Simon Marlow committed
50
import qualified Module
51
import CostCentre
Simon Marlow's avatar
Simon Marlow committed
52
53
import StaticFlags
import FastString
54
import Module
55
56
57
import Constants	-- Lots of field offsets
import Outputable

Simon Marlow's avatar
Simon Marlow committed
58
59
import Data.Char
import Control.Monad
60
61
62
63
64
65
66
67
68

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

-- Expression representing the current cost centre stack
curCCS :: CmmExpr
69
curCCS = CmmReg (CmmGlobal CCCS)
70

71
72
storeCurCCS :: CmmExpr -> CmmStmt
storeCurCCS e = CmmAssign (CmmGlobal CCCS) e
73
74
75
76
77
78
79
80
81

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
82
costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) bWord
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

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 -> Code
-- Initialise the profiling field of an update frame
initUpdFrameProf frame_amode 
  = ifProfiling $	-- frame->header.prof.ccs = CCCS
    stmtC (CmmStore (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.

-- -----------------------------------------------------------------------------
-- 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.
profDynAlloc :: ClosureInfo -> CmmExpr -> Code
profDynAlloc cl_info ccs
  = ifProfiling $
    profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs

-- | 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.
115
116
117
--
-- This API is used by the @CCS_ALLOC()@ macro in @.cmm@ code.
--
118
119
120
121
122
profAlloc :: CmmExpr -> CmmExpr -> Code
profAlloc words ccs
  = ifProfiling $
    stmtC (addToMemE alloc_rep
		(cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
123
	  	(CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $
124
125
126
127
128
		  [CmmMachOp mo_wordSub [words, 
					 CmmLit (mkIntCLit profHdrSize)]]))
		-- subtract the "profiling overhead", which is the
		-- profiling header in a closure.
 where 
129
   alloc_rep = typeWidth REP_CostCentreStack_mem_alloc
130
131
132
133
134
135
136

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

enterCostCentreThunk :: CmmExpr -> Code
enterCostCentreThunk closure = 
  ifProfiling $ do 
137
    stmtC $ storeCurCCS (costCentreFrom closure)
138

139
140
enterCostCentreFun :: CostCentreStack -> CmmExpr -> [GlobalReg] -> Code
enterCostCentreFun ccs closure vols =
141
142
  ifProfiling $ do
    if isCurrentCCS ccs
143
144
145
       then emitRtsCallWithVols rtsPackageId (fsLit "enterFunCCS")
               [CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
                CmmHinted (costCentreFrom closure) AddrHint] vols
146
       else return () -- top-level function, nothing to do
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164

ifProfiling :: Code -> Code
ifProfiling code
  | opt_SccProfilingOn = code
  | otherwise	       = nopC

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

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

emitCostCentreDecl
   :: CostCentre
   -> Code
emitCostCentreDecl cc = do 
165
166
167
168
169
                        -- 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)
170
171
172
                -- 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.
173
174
175
  ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
                   showSDoc (ppr (costCentreSrcSpan cc))
           -- XXX going via FastString to get UTF-8 encoding is silly
176
177
178
179
  ; let
     lits = [ zero,   	-- StgInt ccID,
	      label,	-- char *label,
	      modl,	-- char *module,
180
181
              loc,      -- char *srcloc,
              zero,     -- StgWord time_ticks
182
              zero64,	-- StgWord64 mem_alloc
183
184
              is_caf,   -- StgInt is_caf
              zero      -- struct _CostCentre *link
185
186
187
188
	    ] 
  ; emitDataLits (mkCCLabel cc) lits
  }
  where
189
190
191
     is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
            | otherwise  = zero

192
193
194
195
196
197
198

emitCostCentreStackDecl
   :: CostCentreStack
   -> Code
emitCostCentreStackDecl ccs 
  | Just cc <- maybeSingletonCCS ccs = do
  { let
199
200
201
202
203
204
205
	-- 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)
	--
     lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero
206
207
208
209
  ; emitDataLits (mkCCSLabel ccs) lits
  }
  | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)

Ian Lynagh's avatar
Ian Lynagh committed
210
zero :: CmmLit
211
zero = mkIntCLit 0
Ian Lynagh's avatar
Ian Lynagh committed
212
zero64 :: CmmLit
213
zero64 = CmmInt 0 W64
214

215
216
217
218
219
220
221
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
222
223
224
225

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

226
227
emitSetCCC :: CostCentre -> Bool -> Bool -> Code
emitSetCCC cc tick push
228
229
  | not opt_SccProfilingOn = nopC
  | otherwise = do 
230
    tmp <- newTemp bWord -- TODO FIXME NOW
231
232
    pushCostCentre tmp curCCS cc
    when tick $ stmtC (bumpSccCount (CmmReg (CmmLocal tmp)))
233
    when push $ stmtC (storeCurCCS (CmmReg (CmmLocal tmp)))
234

235
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
236
pushCostCentre result ccs cc
237
  = emitRtsCallWithResult result AddrHint
238
	rtsPackageId 
239
240
        (fsLit "pushCostCentre") [CmmHinted ccs AddrHint,
                                  CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
241
242
243

bumpSccCount :: CmmExpr -> CmmStmt
bumpSccCount ccs
244
  = addToMem (typeWidth REP_CostCentreStack_scc_count)
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
	 (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 -> Code
ldvRecordCreate closure = stmtC $ CmmStore (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.
--
Simon Marlow's avatar
Simon Marlow committed
281
282
283
284
285
ldvEnterClosure :: ClosureInfo -> Code
ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
  where tag = funTag closure_info
        -- don't forget to substract node's tag
  
286
287
ldvEnter :: CmmExpr -> Code
-- Argument is a closure pointer
Simon Marlow's avatar
Simon Marlow committed
288
ldvEnter cl_ptr
289
290
291
292
293
294
295
  =  ifProfiling $
     -- if (era > 0) {
     --    LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
     --                era | LDV_STATE_USE }
    emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
	   (stmtC (CmmStore ldv_wd new_ldv_wd))
  where
Simon Marlow's avatar
Simon Marlow committed
296
        -- don't forget to substract node's tag
297
    ldv_wd = ldvWord cl_ptr
298
    new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
299
300
301
302
				       (CmmLit (mkWordCLit lDV_CREATE_MASK)))
		 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))

loadEra :: CmmExpr 
303
loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
304
	  [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt]
305
306
307
308
309
310
311

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
312
313
314
315
316
317
318
319
320
321
322
323
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
324