1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
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
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
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
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
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
281
282
283
284
285
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
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
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
|
-----------------------------------------------------------------------------
--
-- Code generation for profiling
--
-- (c) The University of Glasgow 2004
--
-----------------------------------------------------------------------------
module CgProf (
mkCCostCentre, mkCCostCentreStack,
-- Cost-centre Profiling
dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
enterCostCentre, enterCostCentrePAP, enterCostCentreThunk,
chooseDynCostCentres,
costCentreFrom,
curCCS, curCCSAddr,
emitCostCentreDecl, emitCostCentreStackDecl,
emitRegisterCC, emitRegisterCCS,
emitSetCCC, emitCCS,
-- Lag/drag/void stuff
ldvEnter, ldvRecordCreate
) where
#include "HsVersions.h"
#include "../includes/ghcconfig.h"
-- Needed by Constants.h
#include "../includes/Constants.h"
-- For LDV_CREATE_MASK, LDV_STATE_USE
-- which are StgWords
#include "../includes/DerivedConstants.h"
-- For REP_xxx constants, which are MachReps
import ClosureInfo ( ClosureInfo, closureSize,
closureName, isToplevClosure, closureReEntrant, )
import CgUtils
import CgMonad
import SMRep ( StgWord, profHdrSize )
import Cmm
import MachOp
import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr )
import CLabel ( mkCCLabel, mkCCSLabel, mkRtsDataLabel )
import Module ( moduleNameUserString )
import Id ( Id )
import CostCentre
import StgSyn ( GenStgExpr(..), StgExpr )
import CmdLineOpts ( opt_SccProfilingOn )
import FastString ( FastString, mkFastString, LitString )
import Constants -- Lots of field offsets
import Outputable
import Maybe
import Char ( ord )
import Monad ( when )
-----------------------------------------------------------------------------
--
-- Cost-centre-stack Profiling
--
-----------------------------------------------------------------------------
-- Expression representing the current cost centre stack
curCCS :: CmmExpr
curCCS = CmmLoad curCCSAddr wordRep
-- Address of current CCS variable, for storing into
curCCSAddr :: CmmExpr
curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCCS")))
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) wordRep
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.
profAlloc :: CmmExpr -> CmmExpr -> Code
profAlloc words ccs
= ifProfiling $
stmtC (addToMemE alloc_rep
(cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
(CmmMachOp (MO_U_Conv wordRep 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 cost centre in a new closure
chooseDynCostCentres :: CostCentreStack
-> [Id] -- Args
-> StgExpr -- Body
-> FCode (CmmExpr, CmmExpr)
-- Called when alllcating a closure
-- Tells which cost centre to put in the object, and which
-- to blame the cost of allocation on
chooseDynCostCentres ccs args body = do
-- Cost-centre we record in the object
use_ccs <- emitCCS ccs
-- Cost-centre on whom we blame the allocation
let blame_ccs
| null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
| otherwise = use_ccs
return (use_ccs, blame_ccs)
-- Some CostCentreStacks are a sequence of pushes on top of CCCS.
-- These pushes must be performed before we can refer to the stack in
-- an expression.
emitCCS :: CostCentreStack -> FCode CmmExpr
emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
where
(cc's, ccs') = decomposeCCS ccs
push_em ccs [] = return ccs
push_em ccs (cc:rest) = do
tmp <- newTemp wordRep
pushCostCentre tmp ccs cc
push_em (CmmReg tmp) rest
ccsExpr :: CostCentreStack -> CmmExpr
ccsExpr ccs
| isCurrentCCS ccs = curCCS
| otherwise = CmmLit (mkCCostCentreStack ccs)
isBox :: StgExpr -> Bool
-- If it's an utterly trivial RHS, then it must be
-- one introduced by boxHigherOrderArgs for profiling,
-- so we charge it to "OVERHEAD".
-- This looks like a GROSS HACK to me --SDM
isBox (StgApp fun []) = True
isBox other = False
-- -----------------------------------------------------------------------
-- Setting the current cost centre on entry to a closure
-- For lexically scoped profiling we have to load the cost centre from
-- the closure entered, if the costs are not supposed to be inherited.
-- This is done immediately on entering the fast entry point.
-- Load current cost centre from closure, if not inherited.
-- Node is guaranteed to point to it, if profiling and not inherited.
enterCostCentre
:: ClosureInfo
-> CostCentreStack
-> StgExpr -- The RHS of the closure
-> Code
-- We used to have a special case for bindings of form
-- f = g True
-- where g has arity 2. The RHS is a thunk, but we don't
-- need to update it; and we want to subsume costs.
-- We don't have these sort of PAPs any more, so the special
-- case has gone away.
enterCostCentre closure_info ccs body
= ifProfiling $
ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
enter_cost_centre closure_info ccs body
enter_cost_centre closure_info ccs body
| isSubsumedCCS ccs
= ASSERT(isToplevClosure closure_info)
ASSERT(re_entrant)
enter_ccs_fsub
| isDerivedFromCurrentCCS ccs
= do {
if re_entrant && not is_box
then
enter_ccs_fun node_ccs
else
stmtC (CmmStore curCCSAddr node_ccs)
-- don't forget to bump the scc count. This closure might have been
-- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal
-- pass has turned into simply let x = e in ...x... and attached
-- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that
-- we don't lose the scc counter, bump it in the entry code for x.
-- ToDo: for a multi-push we should really bump the counter for
-- each of the intervening CCSs, not just the top one.
; when (not (isCurrentCCS ccs)) $
stmtC (bumpSccCount curCCS)
}
| isCafCCS ccs
= ASSERT(isToplevClosure closure_info)
ASSERT(not re_entrant)
do { -- This is just a special case of the isDerivedFromCurrentCCS
-- case above. We could delete this, but it's a micro
-- optimisation and saves a bit of code.
stmtC (CmmStore curCCSAddr enc_ccs)
; stmtC (bumpSccCount node_ccs)
}
| otherwise
= panic "enterCostCentre"
where
enc_ccs = CmmLit (mkCCostCentreStack ccs)
re_entrant = closureReEntrant closure_info
node_ccs = costCentreFrom (CmmReg nodeReg)
is_box = isBox body
-- set the current CCS when entering a PAP
enterCostCentrePAP :: CmmExpr -> Code
enterCostCentrePAP closure =
ifProfiling $ do
enter_ccs_fun (costCentreFrom closure)
enteringPAP 1
enterCostCentreThunk :: CmmExpr -> Code
enterCostCentreThunk closure =
ifProfiling $ do
stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)]
enter_ccs_fsub = enteringPAP 0
-- When entering a PAP, EnterFunCCS is called by both the PAP entry
-- code and the function entry code; we don't want the function's
-- entry code to also update CCCS in the event that it was called via
-- a PAP, so we set the flag entering_PAP to indicate that we are
-- entering via a PAP.
enteringPAP :: Integer -> Code
enteringPAP n
= stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP"))))
(CmmLit (CmmInt n cIntRep)))
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
{ label <- mkStringCLit (costCentreUserName cc)
; modl <- mkStringCLit (moduleNameUserString (cc_mod cc))
; let
lits = [ zero, -- StgInt ccID,
label, -- char *label,
modl, -- char *module,
zero, -- StgWord time_ticks
zero64, -- StgWord64 mem_alloc
subsumed, -- StgInt is_caf
zero -- struct _CostCentre *link
]
; emitDataLits (mkCCLabel cc) lits
}
where
subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
| otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
emitCostCentreStackDecl
:: CostCentreStack
-> Code
emitCostCentreStackDecl ccs
| Just cc <- maybeSingletonCCS ccs = do
{ let
lits = [ zero,
mkCCostCentre cc,
zero, -- struct _CostCentreStack *prevStack;
zero, -- struct _IndexTable *indexTable;
zero, -- StgWord selected;
zero64, -- StgWord64 scc_count;
zero, -- StgWord time_ticks;
zero64, -- StgWord64 mem_alloc;
zero, -- StgWord inherited_ticks;
zero64, -- StgWord64 inherited_alloc;
zero -- CostCentre *root;
]
; emitDataLits (mkCCSLabel ccs) lits
}
| otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
zero = mkIntCLit 0
zero64 = CmmInt 0 I64
-- ---------------------------------------------------------------------------
-- Registering CCs and CCSs
-- (cc)->link = CC_LIST;
-- CC_LIST = (cc);
-- (cc)->ccID = CC_ID++;
emitRegisterCC :: CostCentre -> Code
emitRegisterCC cc = do
{ tmp <- newTemp cIntRep
; stmtsC [
CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
(CmmLoad cC_LIST wordRep),
CmmStore cC_LIST cc_lit,
CmmAssign tmp (CmmLoad cC_ID cIntRep),
CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp),
CmmStore cC_ID (cmmRegOffB tmp 1)
]
}
where
cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
-- (ccs)->prevStack = CCS_LIST;
-- CCS_LIST = (ccs);
-- (ccs)->ccsID = CCS_ID++;
emitRegisterCCS :: CostCentreStack -> Code
emitRegisterCCS ccs = do
{ tmp <- newTemp cIntRep
; stmtsC [
CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
(CmmLoad cCS_LIST wordRep),
CmmStore cCS_LIST ccs_lit,
CmmAssign tmp (CmmLoad cCS_ID cIntRep),
CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp),
CmmStore cCS_ID (cmmRegOffB tmp 1)
]
}
where
ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
cC_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST")))
cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID")))
-- ---------------------------------------------------------------------------
-- Set the current cost centre stack
emitSetCCC :: CostCentre -> Code
emitSetCCC cc
| not opt_SccProfilingOn = nopC
| otherwise = do
tmp <- newTemp wordRep
ASSERT( sccAbleCostCentre cc )
pushCostCentre tmp curCCS cc
stmtC (CmmStore curCCSAddr (CmmReg tmp))
when (isSccCountCostCentre cc) $
stmtC (bumpSccCount curCCS)
pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code
pushCostCentre result ccs cc
= emitRtsCallWithResult result PtrHint
SLIT("PushCostCentre") [(ccs,PtrHint),
(CmmLit (mkCCostCentre cc), PtrHint)]
bumpSccCount :: CmmExpr -> CmmStmt
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 -> 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.
--
ldvEnter :: CmmExpr -> Code
-- Argument is a closure pointer
ldvEnter cl_ptr
= 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
ldv_wd = ldvWord cl_ptr
new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep)
(CmmLit (mkWordCLit lDV_CREATE_MASK)))
(cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
loadEra :: CmmExpr
loadEra = CmmMachOp (MO_U_Conv cIntRep wordRep)
[CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep]
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
lDV_SHIFT = (LDV_SHIFT :: Int)
--lDV_STATE_MASK = (LDV_STATE_MASK :: StgWord)
lDV_CREATE_MASK = (LDV_CREATE_MASK :: StgWord)
--lDV_LAST_MASK = (LDV_LAST_MASK :: StgWord)
lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
lDV_STATE_USE = (LDV_STATE_USE :: StgWord)
|