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