CostCentre.lhs 11.2 KB
Newer Older
1
%
2
% (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
3
4
5
6
7
%
\section[CostCentre]{The @CostCentre@ data type}

\begin{code}
module CostCentre (
8
	CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..),
9
10
		-- All abstract except to friend: ParseIface.y

11
	CostCentreStack,
sof's avatar
sof committed
12
	CollectedCCs,
13
	noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
14
	noCostCentre, noCCAttached,
15
	noCCSAttached, isCurrentCCS,  isSubsumedCCS, currentOrSubsumedCCS,
16
17
	isDerivedFromCurrentCCS, maybeSingletonCCS,
	decomposeCCS,
18

19
	mkUserCC, mkAutoCC, mkAllCafsCC, 
20
	mkSingletonCCS, dupifyCC, pushCCOnCCS,
21
	isCafCCS, isCafCC,
22
23
	isSccCountCostCentre,
	sccAbleCostCentre,
24
25
	ccFromThisModule,

26
27
	pprCostCentreCore,
	costCentreUserName,
28

29
	cmpCostCentre	-- used for removing dups in a list
30
31
    ) where

32
#include "HsVersions.h"
33

34
import Var		( Id )
Simon Marlow's avatar
Simon Marlow committed
35
import Name
Simon Marlow's avatar
Simon Marlow committed
36
import Module		( Module )
37
import Outputable	
38
import FastTypes
39
import FastString
40
import Util	        ( thenCmp )
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
\end{code}

A Cost Centre Stack is something that can be attached to a closure.
This is either:
	
	- the current cost centre stack (CCCS)
	- a pre-defined cost centre stack (there are several
	  pre-defined CCSs, see below).

\begin{code}
data CostCentreStack
  = NoCCS

  | CurrentCCS		-- Pinned on a let(rec)-bound 
			-- thunk/function/constructor, this says that the 
			-- cost centre to be attached to the object, when it 
			-- is allocated, is whatever is in the 
			-- current-cost-centre-stack register.

  | SubsumedCCS		-- Cost centre stack for top-level subsumed functions
			-- (CAFs get an AllCafsCC).
			-- Its execution costs get subsumed into the caller.
			-- This guy is *only* ever pinned on static closures,
			-- and is *never* the cost centre for an SCC construct.

  | OverheadCCS		-- We charge costs due to the profiling-system
  			-- doing its work to "overhead".
			--
			-- Objects whose CCS is "Overhead"
			-- have their *allocation* charged to "overhead",
			-- but have the current CCS put into the object
			-- itself.

			-- For example, if we transform "f g" to "let
			-- g' = g in f g'" (so that something about
			-- profiling works better...), then we charge
			-- the *allocation* of g' to OverheadCCS, but
			-- we put the cost-centre of the call to f
			-- (i.e., current CCS) into the g' object.  When
			-- g' is entered, the CCS of the call
			-- to f will be set.
82

83
84
85
86
87
  | DontCareCCS		-- We need a CCS to stick in static closures
			-- (for data), but we *don't* expect them to
			-- accumulate any costs.  But we still need
			-- the placeholder.  This CCS is it.

88
89
90
91
92
93
94
95
96
97
98
  | PushCC CostCentre CostCentreStack
		-- These are used during code generation as the CCSs
		-- attached to closures.  A PushCC never appears as
		-- the argument to an _scc_.
		--
		-- The tail (2nd argument) is either NoCCS, indicating
		-- a staticly allocated CCS, or CurrentCCS indicating
		-- a dynamically created CCS.  We only support
		-- statically allocated *singleton* CCSs at the
		-- moment, for the purposes of initialising the CCS
		-- field of a CAF.
99
100

  deriving (Eq, Ord)	-- needed for Ord on CLabel
101
102
\end{code}

103
104
A Cost Centre is the argument of an _scc_ expression.
 
105
106
107
108
109
\begin{code}
data CostCentre
  = NoCostCentre	-- Having this constructor avoids having
			-- to use "Maybe CostCentre" all the time.

110
  | NormalCC {  
111
		cc_name :: CcName,	-- Name of the cost centre itself
112
		cc_mod  :: Module,	-- Name of module defining this CC.
113
114
		cc_is_dupd :: IsDupdCC,	-- see below
		cc_is_caf  :: IsCafCC	-- see below
115
116
117
    }

  | AllCafsCC {	
118
		cc_mod  :: Module	-- Name of module defining this CC.
119
    }
120

121
type CcName = FastString
122
123

data IsDupdCC
124
125
  = OriginalCC	-- This says how the CC is *used*.  Saying that
  | DupdCC		-- it is DupdCC doesn't make it a different
126
127
			-- CC, just that it a sub-expression which has
			-- been moved ("dupd") into a different scope.
128
129
130
131
132
			--
			-- The point about a dupd SCC is that we don't
			-- count entries to it, because it's not the
			-- "original" one.
			--
133
			-- In the papers, it's called "SCCsub",
134
			--  i.e. SCCsub CC == SCC DupdCC,
135
136
137
138
			-- but we are trying to avoid confusion between
			-- "subd" and "subsumed".  So we call the former
			-- "dupd".

139
data IsCafCC = CafCC | NotCafCC
sof's avatar
sof committed
140
141
142
143
144
145
146
147

-- synonym for triple which describes the cost centre info in the generated
-- code for a module.
type CollectedCCs
  = ( [CostCentre]       -- local cost-centres that need to be decl'd
    , [CostCentre]       -- "extern" cost-centres
    , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks
    )
148
149
150
151
152
153
154
155
156
157
158
\end{code}

WILL: Would there be any merit to recording ``I am now using a
cost-centre from another module''?  I don't know if this would help a
user; it might be interesting to us to know how much computation is
being moved across module boundaries.

SIMON: Maybe later...

\begin{code}

159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
noCCS 			= NoCCS
subsumedCCS 		= SubsumedCCS
currentCCS	 	= CurrentCCS
overheadCCS	 	= OverheadCCS
dontCareCCS	 	= DontCareCCS

noCostCentre  		= NoCostCentre
\end{code}

Predicates on Cost-Centre Stacks

\begin{code}
noCCSAttached NoCCS			= True
noCCSAttached _				= False

noCCAttached NoCostCentre		= True
noCCAttached _				= False

isCurrentCCS CurrentCCS			= True
isCurrentCCS _	      			= False

isSubsumedCCS SubsumedCCS 		= True
isSubsumedCCS _		     		= False
182

183
isCafCCS (PushCC cc NoCCS)		= isCafCC cc
184
isCafCCS _				= False
sof's avatar
sof committed
185

186
187
188
189
isDerivedFromCurrentCCS CurrentCCS	= True
isDerivedFromCurrentCCS (PushCC _ ccs)	= isDerivedFromCurrentCCS ccs
isDerivedFromCurrentCCS _		= False

190
191
192
currentOrSubsumedCCS SubsumedCCS	= True
currentOrSubsumedCCS CurrentCCS		= True
currentOrSubsumedCCS _			= False
193
194
195

maybeSingletonCCS (PushCC cc NoCCS)	= Just cc
maybeSingletonCCS _			= Nothing
196
\end{code}
197

198
Building cost centres
199

200
\begin{code}
201
mkUserCC :: FastString -> Module -> CostCentre
202
mkUserCC cc_name mod
203
  = NormalCC { cc_name = cc_name, cc_mod =  mod,
204
	       cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
205
    }
206

207
208
mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
mkAutoCC id mod is_caf
Simon Marlow's avatar
Simon Marlow committed
209
  = NormalCC { cc_name = str, cc_mod =  mod,
210
	       cc_is_dupd = OriginalCC, cc_is_caf = is_caf
211
    }
Simon Marlow's avatar
Simon Marlow committed
212
213
214
215
216
217
218
  where 
        name = getName id
        -- beware: we might be making an auto CC for a compiler-generated
        -- thing (like a CAF when -caf-all is on), so include the uniq.
        -- See bug #249, tests prof001, prof002
        str | isSystemName name = mkFastString (showSDoc (ppr name))
            | otherwise         = occNameFS (getOccName id)
219

220
mkAllCafsCC m = AllCafsCC  { cc_mod = m }
221

222
223


224
mkSingletonCCS :: CostCentre -> CostCentreStack
225
mkSingletonCCS cc = pushCCOnCCS cc NoCCS
226

227
228
pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
pushCCOnCCS = PushCC
229

230
dupifyCC cc = cc {cc_is_dupd = DupdCC}
231

232
isCafCC, isDupdCC :: CostCentre -> Bool
233

234
235
236
isCafCC (AllCafsCC {})		         = True
isCafCC (NormalCC {cc_is_caf = CafCC}) = True
isCafCC _		                 = False
237

238
239
isDupdCC (NormalCC   {cc_is_dupd = DupdCC}) = True
isDupdCC _		                     = False
240

241
242
isSccCountCostCentre :: CostCentre -> Bool
  -- Is this a cost-centre which records scc counts
243

244
245
#if DEBUG
isSccCountCostCentre NoCostCentre  = panic "isSccCount:NoCostCentre"
246
#endif
247
248
249
250
251
252
253
254
255
256
257
258
isSccCountCostCentre cc | isCafCC cc  = False
                        | isDupdCC cc = False
			| otherwise   = True

sccAbleCostCentre :: CostCentre -> Bool
  -- Is this a cost-centre which can be sccd ?

#if DEBUG
sccAbleCostCentre NoCostCentre  = panic "sccAbleCC:NoCostCentre"
#endif
sccAbleCostCentre cc | isCafCC cc = False
		     | otherwise  = True
259

260
ccFromThisModule :: CostCentre -> Module -> Bool
261
ccFromThisModule cc m = cc_mod cc == m
262
263
264
\end{code}

\begin{code}
265
266
267
268
269
270
instance Eq CostCentre where
	c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }

instance Ord CostCentre where
	compare = cmpCostCentre

271
cmpCostCentre :: CostCentre -> CostCentre -> Ordering
272

273
cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2}) = m1 `compare` m2
274

275
276
cmpCostCentre (NormalCC {cc_name = n1, cc_mod =  m1, cc_is_caf = c1}) 
	      (NormalCC {cc_name = n2, cc_mod =  m2, cc_is_caf = c2}) 
277
    -- first key is module name, then we use "kinds" (which include
278
    -- names) and finally the caf flag
279
  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
280
281
282
283
284
285

cmpCostCentre other_1 other_2
  = let
	tag1 = tag_CC other_1
	tag2 = tag_CC other_2
    in
286
    if tag1 <# tag2 then LT else GT
287
  where
288
289
    tag_CC (NormalCC   {}) = (_ILIT 1 :: FastInt)
    tag_CC (AllCafsCC  {}) = _ILIT 2
290
291
292
293
294

cmp_caf NotCafCC CafCC     = LT
cmp_caf NotCafCC NotCafCC  = EQ
cmp_caf CafCC    CafCC     = EQ
cmp_caf CafCC    NotCafCC  = GT
295
296
297
298
299

decomposeCCS :: CostCentreStack -> ([CostCentre],CostCentreStack)
decomposeCCS (PushCC cc ccs) = (cc:more, ccs') 
  where (more,ccs') = decomposeCCS ccs
decomposeCCS ccs = ([],ccs)
300
301
\end{code}

302
303
-----------------------------------------------------------------------------
Printing Cost Centre Stacks.
304

305
306
The outputable instance for CostCentreStack prints the CCS as a C
expression.
307

308
309
310
311
NOTE: Not all cost centres are suitable for using in a static
initializer.  In particular, the PushCC forms where the tail is CCCS
may only be used in inline C code because they expand to a
non-constant C expression.
312
313

\begin{code}
314
instance Outputable CostCentreStack where
315
316
317
318
319
320
321
  ppr NoCCS		= ptext SLIT("NO_CCS")
  ppr CurrentCCS	= ptext SLIT("CCCS")
  ppr OverheadCCS	= ptext SLIT("CCS_OVERHEAD")
  ppr DontCareCCS	= ptext SLIT("CCS_DONT_CARE")
  ppr SubsumedCCS	= ptext SLIT("CCS_SUBSUMED")
  ppr (PushCC cc NoCCS) = ppr cc <> ptext SLIT("_ccs")
  ppr (PushCC cc ccs)   = ptext SLIT("PushCostCentre") <> 
322
323
			   parens (ppr ccs <> comma <> 
			   parens(ptext SLIT("void *")) <> ppr cc)
324
\end{code}
325

326
327
-----------------------------------------------------------------------------
Printing Cost Centres.
328

329
330
There are several different ways in which we might want to print a
cost centre:
331

332
333
334
335
	- the name of the cost centre, for profiling output (a C string)
	- the label, i.e. C label for cost centre in .hc file.
	- the debugging name, for output in -ddump things
	- the interface name, for printing in _scc_ exprs in iface files.
336

337
338
The last 3 are derived from costCentreStr below.  The first is given
by costCentreName.
sof's avatar
sof committed
339

340
341
342
343
\begin{code}
instance Outputable CostCentre where
  ppr cc = getPprStyle $ \ sty ->
	   if codeStyle sty
344
345
346
347
  	   then ppCostCentreLbl cc
	   else text (costCentreUserName cc)

-- Printing in an interface file or in Core generally
348
pprCostCentreCore (AllCafsCC {cc_mod = m})
Simon Marlow's avatar
Simon Marlow committed
349
  = text "__sccC" <+> braces (ppr m)
350
pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
351
			     cc_is_caf = caf, cc_is_dupd = dup})
352
  = text "__scc" <+> braces (hsep [
353
	ftext (zEncodeFS n),
Simon Marlow's avatar
Simon Marlow committed
354
	ppr m,
355
356
357
358
359
360
361
362
363
364
365
	pp_dup dup,
	pp_caf caf
    ])

pp_dup DupdCC = char '!'
pp_dup other   = empty

pp_caf CafCC = text "__C"
pp_caf other   = empty

-- Printing as a C label
366
ppCostCentreLbl (NoCostCentre)		  = text "NONE_cc"
367
ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"
368
ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf}) 
Simon Marlow's avatar
Simon Marlow committed
369
  = ppr m <> char '_' <> ftext (zEncodeFS n) <> 
370
	text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
371
372
373
374

-- This is the name to go in the user-displayed string, 
-- recorded in the cost centre declaration
costCentreUserName (NoCostCentre)  = "NO_CC"
375
costCentreUserName (AllCafsCC {})  = "CAF"
376
costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf})
377
  =  case is_caf of { CafCC -> "CAF:";   _ -> "" } ++ unpackFS name
378
\end{code}