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

\begin{code}
7
{-# OPTIONS -fno-warn-incomplete-patterns #-}
8 9 10
-- The above warning supression flag is a temporary kludge.
-- While working on this module you are encouraged to remove it and fix
-- any warnings in the module. See
Ian Lynagh's avatar
Ian Lynagh committed
11
--     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
12 13
-- for details

14
module CostCentre (
15
	CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..),
16 17
		-- All abstract except to friend: ParseIface.y

18
	CostCentreStack,
sof's avatar
sof committed
19
	CollectedCCs,
20
	noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
21
	noCostCentre, noCCAttached,
22
	noCCSAttached, isCurrentCCS,  isSubsumedCCS, currentOrSubsumedCCS,
23 24
	isDerivedFromCurrentCCS, maybeSingletonCCS,
	decomposeCCS,
25

26
	mkUserCC, mkAutoCC, mkAllCafsCC, 
27
	mkSingletonCCS, dupifyCC, pushCCOnCCS,
28
	isCafCCS, isCafCC,
29 30
	isSccCountCostCentre,
	sccAbleCostCentre,
31 32
	ccFromThisModule,

33 34
	pprCostCentreCore,
	costCentreUserName,
35

36
	cmpCostCentre	-- used for removing dups in a list
37 38
    ) where

39
import Var		( Id )
Simon Marlow's avatar
Simon Marlow committed
40
import Name
Simon Marlow's avatar
Simon Marlow committed
41
import Module		( Module )
42
import Unique
43
import Outputable	
44
import FastTypes
45
import FastString
46
import Util	        ( thenCmp )
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
\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.
88

89 90 91 92 93
  | 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.

94 95 96 97 98 99 100 101 102 103 104
  | 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.
105 106

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

109 110
A Cost Centre is the argument of an _scc_ expression.
 
111 112 113 114 115
\begin{code}
data CostCentre
  = NoCostCentre	-- Having this constructor avoids having
			-- to use "Maybe CostCentre" all the time.

116
  | NormalCC {  
117
		cc_name :: CcName,	-- Name of the cost centre itself
118
		cc_mod  :: Module,	-- Name of module defining this CC.
119 120
		cc_is_dupd :: IsDupdCC,	-- see below
		cc_is_caf  :: IsCafCC	-- see below
121 122 123
    }

  | AllCafsCC {	
124
		cc_mod  :: Module	-- Name of module defining this CC.
125
    }
126

127
type CcName = FastString
128 129

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

145
data IsCafCC = CafCC | NotCafCC
sof's avatar
sof committed
146 147 148 149 150 151 152 153

-- 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
    )
154 155 156 157 158 159 160 161 162 163
\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}
164
noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS :: CostCentreStack
165

166 167 168 169 170 171
noCCS 			= NoCCS
subsumedCCS 		= SubsumedCCS
currentCCS	 	= CurrentCCS
overheadCCS	 	= OverheadCCS
dontCareCCS	 	= DontCareCCS

172
noCostCentre :: CostCentre
173 174 175 176 177 178
noCostCentre  		= NoCostCentre
\end{code}

Predicates on Cost-Centre Stacks

\begin{code}
179
noCCSAttached :: CostCentreStack -> Bool
180 181 182
noCCSAttached NoCCS			= True
noCCSAttached _				= False

183
noCCAttached :: CostCentre -> Bool
184 185 186
noCCAttached NoCostCentre		= True
noCCAttached _				= False

187
isCurrentCCS :: CostCentreStack -> Bool
188 189 190
isCurrentCCS CurrentCCS			= True
isCurrentCCS _	      			= False

191
isSubsumedCCS :: CostCentreStack -> Bool
192 193
isSubsumedCCS SubsumedCCS 		= True
isSubsumedCCS _		     		= False
194

195
isCafCCS :: CostCentreStack -> Bool
196
isCafCCS (PushCC cc NoCCS)		= isCafCC cc
197
isCafCCS _				= False
sof's avatar
sof committed
198

199
isDerivedFromCurrentCCS :: CostCentreStack -> Bool
200 201 202 203
isDerivedFromCurrentCCS CurrentCCS	= True
isDerivedFromCurrentCCS (PushCC _ ccs)	= isDerivedFromCurrentCCS ccs
isDerivedFromCurrentCCS _		= False

204
currentOrSubsumedCCS :: CostCentreStack -> Bool
205 206 207
currentOrSubsumedCCS SubsumedCCS	= True
currentOrSubsumedCCS CurrentCCS		= True
currentOrSubsumedCCS _			= False
208

209
maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
210 211
maybeSingletonCCS (PushCC cc NoCCS)	= Just cc
maybeSingletonCCS _			= Nothing
212
\end{code}
213

214
Building cost centres
215

216
\begin{code}
217
mkUserCC :: FastString -> Module -> CostCentre
218
mkUserCC cc_name mod
219
  = NormalCC { cc_name = cc_name, cc_mod =  mod,
220
	       cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
221
    }
222

223 224
mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
mkAutoCC id mod is_caf
Simon Marlow's avatar
Simon Marlow committed
225
  = NormalCC { cc_name = str, cc_mod =  mod,
226
	       cc_is_dupd = OriginalCC, cc_is_caf = is_caf
227
    }
Simon Marlow's avatar
Simon Marlow committed
228 229
  where 
        name = getName id
230 231 232 233 234 235 236 237
        -- beware: only external names are guaranteed to have unique
        -- Occnames.  If the name is not external, we must append its
        -- Unique.
        -- See bug #249, tests prof001, prof002,  also #2411
        str | isExternalName name = occNameFS (getOccName id)
            | otherwise           = mkFastString $ showSDoc $
                                      ftext (occNameFS (getOccName id))
                                      <> char '_' <> pprUnique (getUnique name)
238
mkAllCafsCC :: Module -> CostCentre
239
mkAllCafsCC m = AllCafsCC  { cc_mod = m }
240

241 242


243
mkSingletonCCS :: CostCentre -> CostCentreStack
244
mkSingletonCCS cc = pushCCOnCCS cc NoCCS
245

246 247
pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
pushCCOnCCS = PushCC
248

249
dupifyCC :: CostCentre -> CostCentre
250
dupifyCC cc = cc {cc_is_dupd = DupdCC}
251

252
isCafCC, isDupdCC :: CostCentre -> Bool
253

254 255 256
isCafCC (AllCafsCC {})		         = True
isCafCC (NormalCC {cc_is_caf = CafCC}) = True
isCafCC _		                 = False
257

258 259
isDupdCC (NormalCC   {cc_is_dupd = DupdCC}) = True
isDupdCC _		                     = False
260

261 262
isSccCountCostCentre :: CostCentre -> Bool
  -- Is this a cost-centre which records scc counts
263

264 265
#if DEBUG
isSccCountCostCentre NoCostCentre  = panic "isSccCount:NoCostCentre"
266
#endif
267 268 269 270 271 272 273 274 275 276 277 278
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
279

280
ccFromThisModule :: CostCentre -> Module -> Bool
281
ccFromThisModule cc m = cc_mod cc == m
282 283 284
\end{code}

\begin{code}
285 286 287 288 289 290
instance Eq CostCentre where
	c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }

instance Ord CostCentre where
	compare = cmpCostCentre

291
cmpCostCentre :: CostCentre -> CostCentre -> Ordering
292

293
cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2}) = m1 `compare` m2
294

295 296
cmpCostCentre (NormalCC {cc_name = n1, cc_mod =  m1, cc_is_caf = c1}) 
	      (NormalCC {cc_name = n2, cc_mod =  m2, cc_is_caf = c2}) 
297
    -- first key is module name, then we use "kinds" (which include
298
    -- names) and finally the caf flag
299
  = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
300 301 302

cmpCostCentre other_1 other_2
  = let
303 304
	!tag1 = tag_CC other_1
	!tag2 = tag_CC other_2
305
    in
306
    if tag1 <# tag2 then LT else GT
307
  where
308 309
    tag_CC (NormalCC   {}) = _ILIT(1)
    tag_CC (AllCafsCC  {}) = _ILIT(2)
310

311 312
-- TODO: swap order of IsCafCC, add deriving Ord
cmp_caf :: IsCafCC -> IsCafCC -> Ordering
313 314 315 316
cmp_caf NotCafCC CafCC     = LT
cmp_caf NotCafCC NotCafCC  = EQ
cmp_caf CafCC    CafCC     = EQ
cmp_caf CafCC    NotCafCC  = GT
317 318 319 320 321

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

324 325
-----------------------------------------------------------------------------
Printing Cost Centre Stacks.
326

327 328
The outputable instance for CostCentreStack prints the CCS as a C
expression.
329

330 331 332 333
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.
334 335

\begin{code}
336
instance Outputable CostCentreStack where
Ian Lynagh's avatar
Ian Lynagh committed
337 338 339 340 341 342 343
  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") <> 
344
			   parens (ppr ccs <> comma <> 
Ian Lynagh's avatar
Ian Lynagh committed
345
			   parens(ptext (sLit "void *")) <> ppr cc)
346
\end{code}
347

348 349
-----------------------------------------------------------------------------
Printing Cost Centres.
350

351 352
There are several different ways in which we might want to print a
cost centre:
353

354 355 356 357
	- 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.
358

359 360
The last 3 are derived from costCentreStr below.  The first is given
by costCentreName.
sof's avatar
sof committed
361

362 363 364 365
\begin{code}
instance Outputable CostCentre where
  ppr cc = getPprStyle $ \ sty ->
	   if codeStyle sty
366 367 368 369
  	   then ppCostCentreLbl cc
	   else text (costCentreUserName cc)

-- Printing in an interface file or in Core generally
370
pprCostCentreCore :: CostCentre -> SDoc
371
pprCostCentreCore (AllCafsCC {cc_mod = m})
Simon Marlow's avatar
Simon Marlow committed
372
  = text "__sccC" <+> braces (ppr m)
373
pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
374
			     cc_is_caf = caf, cc_is_dupd = dup})
375
  = text "__scc" <+> braces (hsep [
376
	ftext (zEncodeFS n),
Simon Marlow's avatar
Simon Marlow committed
377
	ppr m,
378 379 380 381
	pp_dup dup,
	pp_caf caf
    ])

382
pp_dup :: IsDupdCC -> SDoc
383
pp_dup DupdCC = char '!'
384
pp_dup _      = empty
385

386
pp_caf :: IsCafCC -> SDoc
387
pp_caf CafCC = text "__C"
388
pp_caf _     = empty
389 390

-- Printing as a C label
391
ppCostCentreLbl :: CostCentre -> SDoc
392
ppCostCentreLbl (NoCostCentre)		  = text "NONE_cc"
393
ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"
394
ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf}) 
Simon Marlow's avatar
Simon Marlow committed
395
  = ppr m <> char '_' <> ftext (zEncodeFS n) <> 
396
	text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
397 398 399

-- This is the name to go in the user-displayed string, 
-- recorded in the cost centre declaration
400
costCentreUserName :: CostCentre -> String
401
costCentreUserName (NoCostCentre)  = "NO_CC"
402
costCentreUserName (AllCafsCC {})  = "CAF"
403
costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf})
404
  =  case is_caf of { CafCC -> "CAF:";   _ -> "" } ++ unpackFS name
405
\end{code}