ghc/compiler/profiling/CostCentre.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
   3 %
   4 \section[CostCentre]{The @CostCentre@ data type}
   5
   6 \begin{code}
   7 module CostCentre (
   8         CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..),
   9                 -- All abstract except to friend: ParseIface.y
  10
  11         CostCentreStack,
  12         CollectedCCs,
  13         noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
  14         noCostCentre, noCCAttached,
  15         noCCSAttached, isCurrentCCS,  isSubsumedCCS, currentOrSubsumedCCS,
  16         isDerivedFromCurrentCCS,
  17
  18         mkUserCC, mkAutoCC, mkAllCafsCC,
  19         mkSingletonCCS, cafifyCC, dupifyCC, pushCCOnCCS,
  20         isCafCC, isDupdCC, isEmptyCC, isCafCCS,
  21         isSccCountCostCentre,
  22         sccAbleCostCentre,
  23         ccFromThisModule,
  24
  25         pprCostCentreDecl, pprCostCentreStackDecl, pprCostCentreCore,
  26
  27         cmpCostCentre   -- used for removing dups in a list
  28     ) where
  29
  30 #include "HsVersions.h"
  31
  32 import Var              ( Id )
  33 import Name             ( UserFS, EncodedFS, encodeFS, decode,
  34                           getOccName, occNameFS
  35                         )
  36 import Module           ( Module, ModuleName, moduleName,
  37                           moduleNameUserString
  38                         )
  39 import Outputable
  40 import CStrings         ( pprStringInCStyle )
  41 import FastTypes
  42 import Util             ( thenCmp )
  43 \end{code}
  44
  45 A Cost Centre Stack is something that can be attached to a closure.
  46 This is either:
  47
  48         - the current cost centre stack (CCCS)
  49         - a pre-defined cost centre stack (there are several
  50           pre-defined CCSs, see below).
  51
  52 \begin{code}
  53 data CostCentreStack
  54   = NoCCS
  55
  56   | CurrentCCS          -- Pinned on a let(rec)-bound
  57                         -- thunk/function/constructor, this says that the
  58                         -- cost centre to be attached to the object, when it
  59                         -- is allocated, is whatever is in the
  60                         -- current-cost-centre-stack register.
  61
  62   | SubsumedCCS         -- Cost centre stack for top-level subsumed functions
  63                         -- (CAFs get an AllCafsCC).
  64                         -- Its execution costs get subsumed into the caller.
  65                         -- This guy is *only* ever pinned on static closures,
  66                         -- and is *never* the cost centre for an SCC construct.
  67
  68   | OverheadCCS         -- We charge costs due to the profiling-system
  69                         -- doing its work to "overhead".
  70                         --
  71                         -- Objects whose CCS is "Overhead"
  72                         -- have their *allocation* charged to "overhead",
  73                         -- but have the current CCS put into the object
  74                         -- itself.
  75
  76                         -- For example, if we transform "f g" to "let
  77                         -- g' = g in f g'" (so that something about
  78                         -- profiling works better...), then we charge
  79                         -- the *allocation* of g' to OverheadCCS, but
  80                         -- we put the cost-centre of the call to f
  81                         -- (i.e., current CCS) into the g' object.  When
  82                         -- g' is entered, the CCS of the call
  83                         -- to f will be set.
  84
  85   | DontCareCCS         -- We need a CCS to stick in static closures
  86                         -- (for data), but we *don't* expect them to
  87                         -- accumulate any costs.  But we still need
  88                         -- the placeholder.  This CCS is it.
  89
  90   | PushCC CostCentre CostCentreStack
  91                 -- These are used during code generation as the CCSs
  92                 -- attached to closures.  A PushCC never appears as
  93                 -- the argument to an _scc_.
  94                 --
  95                 -- The tail (2nd argument) is either NoCCS, indicating
  96                 -- a staticly allocated CCS, or CurrentCCS indicating
  97                 -- a dynamically created CCS.  We only support
  98                 -- statically allocated *singleton* CCSs at the
  99                 -- moment, for the purposes of initialising the CCS
 100                 -- field of a CAF.
 101
 102   deriving (Eq, Ord)    -- needed for Ord on CLabel
 103 \end{code}
 104
 105 A Cost Centre is the argument of an _scc_ expression.
 106
 107 \begin{code}
 108 data CostCentre
 109   = NoCostCentre        -- Having this constructor avoids having
 110                         -- to use "Maybe CostCentre" all the time.
 111
 112   | NormalCC {
 113                 cc_name :: CcName,      -- Name of the cost centre itself
 114                 cc_mod  :: ModuleName,  -- Name of module defining this CC.
 115                 cc_is_dupd :: IsDupdCC, -- see below
 116                 cc_is_caf  :: IsCafCC   -- see below
 117     }
 118
 119   | AllCafsCC {
 120                 cc_mod  :: ModuleName   -- Name of module defining this CC.
 121     }
 122
 123 type CcName = EncodedFS
 124
 125 data IsDupdCC
 126   = OriginalCC  -- This says how the CC is *used*.  Saying that
 127   | DupdCC              -- it is DupdCC doesn't make it a different
 128                         -- CC, just that it a sub-expression which has
 129                         -- been moved ("dupd") into a different scope.
 130                         --
 131                         -- The point about a dupd SCC is that we don't
 132                         -- count entries to it, because it's not the
 133                         -- "original" one.
 134                         --
 135                         -- In the papers, it's called "SCCsub",
 136                         --  i.e. SCCsub CC == SCC DupdCC,
 137                         -- but we are trying to avoid confusion between
 138                         -- "subd" and "subsumed".  So we call the former
 139                         -- "dupd".
 140
 141 data IsCafCC = CafCC | NotCafCC
 142
 143 -- synonym for triple which describes the cost centre info in the generated
 144 -- code for a module.
 145 type CollectedCCs
 146   = ( [CostCentre]       -- local cost-centres that need to be decl'd
 147     , [CostCentre]       -- "extern" cost-centres
 148     , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks
 149     )
 150 \end{code}
 151
 152 WILL: Would there be any merit to recording ``I am now using a
 153 cost-centre from another module''?  I don't know if this would help a
 154 user; it might be interesting to us to know how much computation is
 155 being moved across module boundaries.
 156
 157 SIMON: Maybe later...
 158
 159 \begin{code}
 160
 161 noCCS                   = NoCCS
 162 subsumedCCS             = SubsumedCCS
 163 currentCCS              = CurrentCCS
 164 overheadCCS             = OverheadCCS
 165 dontCareCCS             = DontCareCCS
 166
 167 noCostCentre            = NoCostCentre
 168 \end{code}
 169
 170 Predicates on Cost-Centre Stacks
 171
 172 \begin{code}
 173 noCCSAttached NoCCS                     = True
 174 noCCSAttached _                         = False
 175
 176 noCCAttached NoCostCentre               = True
 177 noCCAttached _                          = False
 178
 179 isCurrentCCS CurrentCCS                 = True
 180 isCurrentCCS _                          = False
 181
 182 isSubsumedCCS SubsumedCCS               = True
 183 isSubsumedCCS _                         = False
 184
 185 isCafCCS (PushCC cc NoCCS)              = isCafCC cc
 186 isCafCCS _                              = False
 187
 188 isDerivedFromCurrentCCS CurrentCCS      = True
 189 isDerivedFromCurrentCCS (PushCC _ ccs)  = isDerivedFromCurrentCCS ccs
 190 isDerivedFromCurrentCCS _               = False
 191
 192 currentOrSubsumedCCS SubsumedCCS        = True
 193 currentOrSubsumedCCS CurrentCCS         = True
 194 currentOrSubsumedCCS _                  = False
 195 \end{code}
 196
 197 Building cost centres
 198
 199 \begin{code}
 200 mkUserCC :: UserFS -> Module -> CostCentre
 201 mkUserCC cc_name mod
 202   = NormalCC { cc_name = encodeFS cc_name, cc_mod =  moduleName mod,
 203                cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
 204     }
 205
 206 mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
 207 mkAutoCC id mod is_caf
 208   = NormalCC { cc_name = occNameFS (getOccName id), cc_mod =  moduleName mod,
 209                cc_is_dupd = OriginalCC, cc_is_caf = is_caf
 210     }
 211
 212 mkAllCafsCC m = AllCafsCC  { cc_mod = moduleName m }
 213
 214
 215
 216 mkSingletonCCS :: CostCentre -> CostCentreStack
 217 mkSingletonCCS cc = pushCCOnCCS cc NoCCS
 218
 219 pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
 220 pushCCOnCCS = PushCC
 221
 222 cafifyCC, dupifyCC  :: CostCentre -> CostCentre
 223 cafifyCC cc@(NormalCC {cc_is_caf = is_caf})
 224   = ASSERT(not_a_caf_already is_caf)
 225     cc {cc_is_caf = CafCC}
 226   where
 227     not_a_caf_already CafCC = False
 228     not_a_caf_already _       = True
 229 cafifyCC cc = pprPanic "cafifyCC" (ppr cc)
 230
 231 dupifyCC cc = cc {cc_is_dupd = DupdCC}
 232
 233 isEmptyCC, isCafCC, isDupdCC :: CostCentre -> Bool
 234
 235 isEmptyCC (NoCostCentre)                = True
 236 isEmptyCC _                             = False
 237
 238 isCafCC (AllCafsCC {})                   = True
 239 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
 240 isCafCC _                                = False
 241
 242 isDupdCC (NormalCC   {cc_is_dupd = DupdCC}) = True
 243 isDupdCC _                                   = False
 244
 245 isSccCountCostCentre :: CostCentre -> Bool
 246   -- Is this a cost-centre which records scc counts
 247
 248 #if DEBUG
 249 isSccCountCostCentre NoCostCentre  = panic "isSccCount:NoCostCentre"
 250 #endif
 251 isSccCountCostCentre cc | isCafCC cc  = False
 252                         | isDupdCC cc = False
 253                         | otherwise   = True
 254
 255 sccAbleCostCentre :: CostCentre -> Bool
 256   -- Is this a cost-centre which can be sccd ?
 257
 258 #if DEBUG
 259 sccAbleCostCentre NoCostCentre  = panic "sccAbleCC:NoCostCentre"
 260 #endif
 261 sccAbleCostCentre cc | isCafCC cc = False
 262                      | otherwise  = True
 263
 264 ccFromThisModule :: CostCentre -> Module -> Bool
 265 ccFromThisModule cc m = cc_mod cc == moduleName m
 266 \end{code}
 267
 268 \begin{code}
 269 instance Eq CostCentre where
 270         c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
 271
 272 instance Ord CostCentre where
 273         compare = cmpCostCentre
 274
 275 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
 276
 277 cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2}) = m1 `compare` m2
 278
 279 cmpCostCentre (NormalCC {cc_name = n1, cc_mod =  m1, cc_is_caf = c1})
 280               (NormalCC {cc_name = n2, cc_mod =  m2, cc_is_caf = c2})
 281     -- first key is module name, then we use "kinds" (which include
 282     -- names) and finally the caf flag
 283   = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
 284
 285 cmpCostCentre other_1 other_2
 286   = let
 287         tag1 = tag_CC other_1
 288         tag2 = tag_CC other_2
 289     in
 290     if tag1 <# tag2 then LT else GT
 291   where
 292     tag_CC (NormalCC   {}) = (_ILIT 1 :: FastInt)
 293     tag_CC (AllCafsCC  {}) = _ILIT 2
 294
 295 cmp_caf NotCafCC CafCC     = LT
 296 cmp_caf NotCafCC NotCafCC  = EQ
 297 cmp_caf CafCC    CafCC     = EQ
 298 cmp_caf CafCC    NotCafCC  = GT
 299 \end{code}
 300
 301 -----------------------------------------------------------------------------
 302 Printing Cost Centre Stacks.
 303
 304 The outputable instance for CostCentreStack prints the CCS as a C
 305 expression.
 306
 307 NOTE: Not all cost centres are suitable for using in a static
 308 initializer.  In particular, the PushCC forms where the tail is CCCS
 309 may only be used in inline C code because they expand to a
 310 non-constant C expression.
 311
 312 \begin{code}
 313 instance Outputable CostCentreStack where
 314   ppr NoCCS             = ptext SLIT("NO_CCS")
 315   ppr CurrentCCS        = ptext SLIT("CCCS")
 316   ppr OverheadCCS       = ptext SLIT("CCS_OVERHEAD")
 317   ppr DontCareCCS       = ptext SLIT("CCS_DONT_CARE")
 318   ppr SubsumedCCS       = ptext SLIT("CCS_SUBSUMED")
 319   ppr (PushCC cc NoCCS) = ppr cc <> ptext SLIT("_ccs")
 320   ppr (PushCC cc ccs)   = ptext SLIT("PushCostCentre") <>
 321                            parens (ppr ccs <> comma <> ppr cc)
 322
 323 -- print the static declaration for a singleton CCS.
 324 pprCostCentreStackDecl :: CostCentreStack -> SDoc
 325 pprCostCentreStackDecl ccs@(PushCC cc NoCCS)
 326   = hcat [ ptext SLIT("CCS_DECLARE"), char '(',
 327            ppr ccs,             comma,  -- better be codeStyle
 328            ppCostCentreLbl cc,  comma,
 329            empty,       -- Now always externally visible
 330            text ");"
 331          ]
 332
 333 pprCostCentreStackDecl ccs
 334   = pprPanic "pprCostCentreStackDecl: " (ppr ccs)
 335 \end{code}
 336
 337 -----------------------------------------------------------------------------
 338 Printing Cost Centres.
 339
 340 There are several different ways in which we might want to print a
 341 cost centre:
 342
 343         - the name of the cost centre, for profiling output (a C string)
 344         - the label, i.e. C label for cost centre in .hc file.
 345         - the debugging name, for output in -ddump things
 346         - the interface name, for printing in _scc_ exprs in iface files.
 347
 348 The last 3 are derived from costCentreStr below.  The first is given
 349 by costCentreName.
 350
 351 \begin{code}
 352 instance Outputable CostCentre where
 353   ppr cc = getPprStyle $ \ sty ->
 354            if codeStyle sty
 355            then ppCostCentreLbl cc
 356            else text (costCentreUserName cc)
 357
 358 -- Printing in an interface file or in Core generally
 359 pprCostCentreCore (AllCafsCC {cc_mod = m})
 360   = text "__sccC" <+> braces (ppr m)
 361 pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
 362                              cc_is_caf = caf, cc_is_dupd = dup})
 363   = text "__scc" <+> braces (hsep [
 364         ptext n,
 365         ppr m,
 366         pp_dup dup,
 367         pp_caf caf
 368     ])
 369
 370 pp_dup DupdCC = char '!'
 371 pp_dup other   = empty
 372
 373 pp_caf CafCC = text "__C"
 374 pp_caf other   = empty
 375
 376
 377 -- Printing as a C label
 378 ppCostCentreLbl (NoCostCentre)            = text "NONE_cc"
 379 ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"
 380 ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf})
 381   = ppr m <> ptext n <>
 382         text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
 383
 384 -- This is the name to go in the user-displayed string,
 385 -- recorded in the cost centre declaration
 386 costCentreUserName (NoCostCentre)  = "NO_CC"
 387 costCentreUserName (AllCafsCC {})  = "CAF"
 388 costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf})
 389   =  case is_caf of { CafCC -> "CAF:";   _ -> "" } ++ decode (_UNPK_ name)
 390 \end{code}
 391
 392 Cost Centre Declarations
 393
 394 \begin{code}
 395 #ifdef DEBUG
 396 pprCostCentreDecl is_local (NoCostCentre)
 397   = panic "pprCostCentreDecl: no cost centre!"
 398 #endif
 399 pprCostCentreDecl is_local cc
 400   = if is_local then
 401         hcat [
 402             ptext SLIT("CC_DECLARE"),char '(',
 403             cc_ident,                                                   comma,
 404             pprStringInCStyle (costCentreUserName cc),                  comma,
 405             pprStringInCStyle (moduleNameUserString mod_name),          comma,
 406             ptext is_subsumed,                                          comma,
 407             empty,      -- Now always externally visible
 408             text ");"]
 409     else
 410         hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ]
 411   where
 412     cc_ident    = ppCostCentreLbl cc
 413     mod_name    = cc_mod cc
 414     is_subsumed = ccSubsumed cc
 415
 416 ccSubsumed :: CostCentre -> FAST_STRING         -- subsumed value
 417 ccSubsumed cc | isCafCC  cc = SLIT("CC_IS_CAF")
 418               | otherwise   = SLIT("CC_IS_BORING")
 419 \end{code}