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