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, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..),
   9         CostCentreStack,
  10         noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
  11         noCostCentre, noCCAttached,
  12         noCCSAttached, isCurrentCCS,  isSubsumedCCS, currentOrSubsumedCCS,
  13
  14         mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC,
  15         mkSingletonCCS, cafifyCC, dupifyCC,
  16         isCafCC, isDictCC, isDupdCC, isEmptyCC, isCafCCS,
  17         isSccCountCostCentre,
  18         sccAbleCostCentre,
  19         ccFromThisModule,
  20         ccMentionsId,
  21
  22         pprCostCentreDecl, pprCostCentreStackDecl,
  23
  24         cmpCostCentre   -- used for removing dups in a list
  25     ) where
  26
  27 #include "HsVersions.h"
  28
  29 import Var              ( externallyVisibleId, GenId, Id )
  30 import CStrings         ( identToC, stringToC )
  31 import Name             ( getOccString )
  32 import Outputable
  33 import BasicTypes       ( moduleString )
  34 import Util             ( panic, assertPanic, thenCmp )
  35 \end{code}
  36
  37 A Cost Centre Stack is something that can be attached to a closure.
  38 This is either:
  39
  40         - the current cost centre stack (CCCS)
  41         - a pre-defined cost centre stack (there are several
  42           pre-defined CCSs, see below).
  43
  44 \begin{code}
  45 data CostCentreStack
  46   = NoCCS
  47
  48   | CurrentCCS          -- Pinned on a let(rec)-bound
  49                         -- thunk/function/constructor, this says that the
  50                         -- cost centre to be attached to the object, when it
  51                         -- is allocated, is whatever is in the
  52                         -- current-cost-centre-stack register.
  53
  54   | SubsumedCCS         -- Cost centre stack for top-level subsumed functions
  55                         -- (CAFs get an AllCafsCC).
  56                         -- Its execution costs get subsumed into the caller.
  57                         -- This guy is *only* ever pinned on static closures,
  58                         -- and is *never* the cost centre for an SCC construct.
  59
  60   | OverheadCCS         -- We charge costs due to the profiling-system
  61                         -- doing its work to "overhead".
  62                         --
  63                         -- Objects whose CCS is "Overhead"
  64                         -- have their *allocation* charged to "overhead",
  65                         -- but have the current CCS put into the object
  66                         -- itself.
  67
  68                         -- For example, if we transform "f g" to "let
  69                         -- g' = g in f g'" (so that something about
  70                         -- profiling works better...), then we charge
  71                         -- the *allocation* of g' to OverheadCCS, but
  72                         -- we put the cost-centre of the call to f
  73                         -- (i.e., current CCS) into the g' object.  When
  74                         -- g' is entered, the CCS of the call
  75                         -- to f will be set.
  76
  77   | DontCareCCS         -- We need a CCS to stick in static closures
  78                         -- (for data), but we *don't* expect them to
  79                         -- accumulate any costs.  But we still need
  80                         -- the placeholder.  This CCS is it.
  81
  82   | SingletonCCS CostCentre
  83                         -- This is primarily for CAF cost centres, which
  84                         -- are attached to top-level thunks right at the
  85                         -- end of STG processing, before code generation.
  86                         -- Hence, a CAF cost centre never appears as the
  87                         -- argument of an _scc_.
  88                         -- Also, we generate these singleton CCSs statically
  89                         -- as part of code generation.
  90
  91   deriving (Eq, Ord)    -- needed for Ord on CLabel
  92 \end{code}
  93
  94 A Cost Centre is the argument of an _scc_ expression.
  95
  96 \begin{code}
  97 data CostCentre
  98   = NoCostCentre        -- Having this constructor avoids having
  99                         -- to use "Maybe CostCentre" all the time.
 100
 101   | NormalCC    CcKind   -- CcKind will include a cost-centre name
 102                 FAST_STRING      -- Name of module defining this CC.
 103                 FAST_STRING   -- "Group" that this CC is in.
 104                 IsDupdCC -- see below
 105                 IsCafCC  -- see below
 106
 107   | AllCafsCC   FAST_STRING     -- Ditto for CAFs.
 108                 FAST_STRING  -- We record module and group names.
 109                         -- Again, one "big" CAF cc per module, where all
 110                         -- CAF costs are attributed unless the user asked for
 111                         -- per-individual-CAF cost attribution.
 112
 113   | AllDictsCC  FAST_STRING     -- Ditto for dictionaries.
 114                 FAST_STRING  -- We record module and group names.
 115                         -- Again, one "big" DICT cc per module, where all
 116                         -- DICT costs are attributed unless the user asked for
 117                         -- per-individual-DICT cost attribution.
 118                 IsDupdCC -- see below
 119
 120 data CcKind
 121   = UserCC  FAST_STRING -- Supplied by user: String is the cc name
 122   | AutoCC  Id          -- CC -auto-magically inserted for that Id
 123   | DictCC  Id
 124
 125 data IsDupdCC
 126   = AnOriginalCC        -- This says how the CC is *used*.  Saying that
 127   | ADupdCC             -- it is ADupdCC 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 ADupdCC,
 137                         -- but we are trying to avoid confusion between
 138                         -- "subd" and "subsumed".  So we call the former
 139                         -- "dupd".
 140
 141 data IsCafCC
 142   = IsCafCC
 143   | IsNotCafCC
 144 \end{code}
 145
 146 WILL: Would there be any merit to recording ``I am now using a
 147 cost-centre from another module''?  I don't know if this would help a
 148 user; it might be interesting to us to know how much computation is
 149 being moved across module boundaries.
 150
 151 SIMON: Maybe later...
 152
 153 \begin{code}
 154
 155 noCCS                   = NoCCS
 156 subsumedCCS             = SubsumedCCS
 157 currentCCS              = CurrentCCS
 158 overheadCCS             = OverheadCCS
 159 dontCareCCS             = DontCareCCS
 160
 161 noCostCentre            = NoCostCentre
 162 \end{code}
 163
 164 Predicates on Cost-Centre Stacks
 165
 166 \begin{code}
 167 noCCSAttached NoCCS                     = True
 168 noCCSAttached _                         = False
 169
 170 noCCAttached NoCostCentre               = True
 171 noCCAttached _                          = False
 172
 173 isCurrentCCS CurrentCCS                 = True
 174 isCurrentCCS _                          = False
 175
 176 isSubsumedCCS SubsumedCCS               = True
 177 isSubsumedCCS _                         = False
 178
 179 isCafCCS (SingletonCCS cc)              = isCafCC cc
 180 isCafCCS _                              = False
 181
 182 isDictCCS (SingletonCCS cc)             = isDictCC cc
 183 isDictCCS _                             = False
 184
 185 currentOrSubsumedCCS SubsumedCCS        = True
 186 currentOrSubsumedCCS CurrentCCS         = True
 187 currentOrSubsumedCCS _                  = False
 188 \end{code}
 189
 190 Building cost centres
 191
 192 \begin{code}
 193 mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
 194
 195 mkUserCC cc_name module_name group_name
 196   = NormalCC (UserCC cc_name) module_name group_name
 197              AnOriginalCC IsNotCafCC{-might be changed-}
 198
 199 mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre
 200
 201 mkDictCC id module_name group_name is_caf
 202   = NormalCC (DictCC id) module_name group_name
 203              AnOriginalCC is_caf
 204
 205 mkAutoCC id module_name group_name is_caf
 206   = NormalCC (AutoCC id) module_name group_name
 207              AnOriginalCC is_caf
 208
 209 mkAllCafsCC  m g   = AllCafsCC  m g
 210 mkAllDictsCC m g is_dupd
 211   = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC)
 212
 213 mkSingletonCCS :: CostCentre -> CostCentreStack
 214 mkSingletonCCS cc = SingletonCCS cc
 215
 216 cafifyCC, dupifyCC  :: CostCentre -> CostCentre
 217
 218 cafifyCC cc@(AllDictsCC _ _ _) = cc -- ToDo ???
 219 cafifyCC (NormalCC kind m g is_dupd is_caf)
 220   = ASSERT(not_a_calf_already is_caf)
 221     NormalCC kind m g is_dupd IsCafCC
 222   where
 223     not_a_calf_already IsCafCC = False
 224     not_a_calf_already _       = True
 225 cafifyCC cc = pprPanic "cafifyCC" (ppr cc)
 226
 227 dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC
 228 dupifyCC (NormalCC kind m g is_dupd is_caf)
 229   = NormalCC kind m g ADupdCC is_caf
 230 dupifyCC cc = pprPanic "dupifyCC" (ppr cc)
 231
 232 isEmptyCC, isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
 233
 234 isEmptyCC (NoCostCentre)                = True
 235 isEmptyCC _                             = False
 236
 237 isCafCC (AllCafsCC _ _)            = True
 238 isCafCC (NormalCC _ _ _ _ IsCafCC) = True
 239 isCafCC _                          = False
 240
 241 isDictCC (AllDictsCC _ _ _)             = True
 242 isDictCC (NormalCC (DictCC _) _ _ _ _)  = True
 243 isDictCC _                              = False
 244
 245 isDupdCC (AllDictsCC _ _ ADupdCC)   = True
 246 isDupdCC (NormalCC _ _ _ ADupdCC _) = True
 247 isDupdCC _                          = False
 248
 249 isSccCountCostCentre :: CostCentre -> Bool
 250   -- Is this a cost-centre which records scc counts
 251
 252 #if DEBUG
 253 isSccCountCostCentre NoCostCentre  = panic "isSccCount:NoCostCentre"
 254 #endif
 255 isSccCountCostCentre cc | isCafCC cc  = False
 256                         | isDupdCC cc = False
 257                         | isDictCC cc = True
 258                         | otherwise   = True
 259
 260 sccAbleCostCentre :: CostCentre -> Bool
 261   -- Is this a cost-centre which can be sccd ?
 262
 263 #if DEBUG
 264 sccAbleCostCentre NoCostCentre  = panic "sccAbleCC:NoCostCentre"
 265 #endif
 266 sccAbleCostCentre cc | isCafCC cc = False
 267                      | otherwise  = True
 268
 269 ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool
 270
 271 ccFromThisModule (NormalCC _ m _ _ _) mod_name = m == mod_name
 272 ccFromThisModule (AllCafsCC  m _)     mod_name = m == mod_name
 273 ccFromThisModule (AllDictsCC m _ _)   mod_name = m == mod_name
 274 \end{code}
 275
 276 \begin{code}
 277 ccMentionsId :: CostCentre -> Maybe Id
 278
 279 ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id
 280 ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id
 281 ccMentionsId other                          = Nothing
 282 \end{code}
 283
 284 \begin{code}
 285 instance Eq CostCentre where
 286         c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
 287
 288 instance Ord CostCentre where
 289         compare = cmpCostCentre
 290
 291 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
 292
 293 cmpCostCentre (AllCafsCC  m1 _)   (AllCafsCC  m2 _)   = m1 `compare` m2
 294 cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = m1 `compare` m2
 295
 296 cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ 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` (k1 `cmp_kind` k2) `thenCmp` (c1 `cmp_caf` c2)
 300
 301 cmpCostCentre other_1 other_2
 302   = let
 303         tag1 = tag_CC other_1
 304         tag2 = tag_CC other_2
 305     in
 306     if tag1 _LT_ tag2 then LT else GT
 307   where
 308     tag_CC (NormalCC _ _ _ _ _) = (ILIT(1) :: FAST_INT)
 309     tag_CC (AllCafsCC  _ _)     = ILIT(2)
 310     tag_CC (AllDictsCC _ _ _)   = ILIT(3)
 311
 312 cmp_kind (UserCC n1) (UserCC n2) = n1 `compare` n2
 313 cmp_kind (AutoCC i1) (AutoCC i2) = i1 `compare` i2
 314 cmp_kind (DictCC i1) (DictCC i2) = i1 `compare` i2
 315 cmp_kind other_1     other_2
 316   = let
 317         tag1 = tag_CcKind other_1
 318         tag2 = tag_CcKind other_2
 319     in
 320     if tag1 _LT_ tag2 then LT else GT
 321   where
 322     tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT)
 323     tag_CcKind (AutoCC _) = ILIT(2)
 324     tag_CcKind (DictCC _) = ILIT(3)
 325
 326 cmp_caf IsNotCafCC IsCafCC     = LT
 327 cmp_caf IsNotCafCC IsNotCafCC  = EQ
 328 cmp_caf IsCafCC    IsCafCC     = EQ
 329 cmp_caf IsCafCC    IsNotCafCC  = GT
 330 \end{code}
 331
 332 -----------------------------------------------------------------------------
 333 Printing Cost Centre Stacks.
 334
 335 There are two ways to print a CCS:
 336
 337         - for debugging output (i.e. -ddump-whatever),
 338         - as a C label
 339
 340 \begin{code}
 341 instance Outputable CostCentreStack where
 342   ppr ccs = case ccs of
 343                 NoCCS           -> ptext SLIT("NO_CCS")
 344                 CurrentCCS      -> ptext SLIT("CCCS")
 345                 OverheadCCS     -> ptext SLIT("CCS_OVERHEAD")
 346                 DontCareCCS     -> ptext SLIT("CCS_DONTZuCARE")
 347                 SubsumedCCS     -> ptext SLIT("CCS_SUBSUMED")
 348                 SingletonCCS cc ->
 349                         getPprStyle $ \sty ->
 350                         if (codeStyle sty)
 351                             then ptext SLIT("CCS_") <>
 352                                  identToC (_PK_ (costCentreStr cc))
 353                             else ptext SLIT("CCS.") <> text (costCentreStr cc)
 354
 355 pprCostCentreStackDecl :: CostCentreStack -> SDoc
 356
 357 pprCostCentreStackDecl ccs@(SingletonCCS cc)
 358   = let
 359        (mod_name, grp_name, is_subsumed, externally_visible) = get_cc_info cc
 360     in
 361     hcat [ ptext SLIT("CCS_DECLARE"), char '(',
 362            ppr ccs,             comma,  -- better be codeStyle
 363            ppCostCentreLbl cc,  comma,
 364            ptext is_subsumed,   comma,
 365            if externally_visible
 366                 then empty
 367                 else ptext SLIT("static"),
 368            text ");"
 369          ]
 370
 371 pprCostCentreStackDecl ccs
 372   = pprPanic "pprCostCentreStackDecl: " (ppr ccs)
 373 \end{code}
 374
 375 -----------------------------------------------------------------------------
 376 Printing Cost Centres.
 377
 378 There are several different ways in which we might want to print a
 379 cost centre:
 380
 381         - the name of the cost centre, for profiling output (a C string)
 382         - the label, i.e. C label for cost centre in .hc file.
 383         - the debugging name, for output in -ddump things
 384         - the interface name, for printing in _scc_ exprs in iface files.
 385
 386 The last 3 are derived from costCentreStr below.  The first is given
 387 by costCentreName.
 388
 389 \begin{code}
 390 instance Outputable CostCentre where
 391   ppr cc = getPprStyle $ \ sty ->
 392            if codeStyle sty
 393                 then ppCostCentreLbl cc
 394                 else
 395            if ifaceStyle sty
 396                 then ppCostCentreIface cc
 397                 else text (costCentreStr cc)
 398
 399 ppCostCentreLbl cc   = ptext SLIT("CC_") <> identToC (_PK_ (costCentreStr cc))
 400 ppCostCentreIface cc = doubleQuotes (text (costCentreStr cc))
 401 ppCostCentreName cc  = doubleQuotes (text (stringToC (costCentreName cc)))
 402
 403 costCentreStr (NoCostCentre)            = "NO_CC"
 404 costCentreStr (AllCafsCC m _)           = "CAFs."  ++ _UNPK_ m
 405 costCentreStr (AllDictsCC m _ d)        = "DICTs." ++ _UNPK_ m
 406 costCentreStr (NormalCC kind mod_name grp_name is_dupd is_caf)
 407   =  case is_caf of { IsCafCC -> "CAF:";   _ -> "" }
 408   ++ moduleString mod_name
 409   ++ case kind of { UserCC name -> _UNPK_ name;
 410                     AutoCC id   -> getOccString id ++ "/AUTO";
 411                     DictCC id   -> getOccString id ++ "/DICT"
 412                   }
 413   -- ToDo: group name
 414   ++ case is_dupd of { ADupdCC -> "/DUPD";   _ -> "" }
 415
 416 -- This is the name to go in the cost centre declaration
 417 costCentreName (NoCostCentre)           = "NO_CC"
 418 costCentreName (AllCafsCC _ _)          = "CAFs_in_..."
 419 costCentreName (AllDictsCC _ _ _)       = "DICTs_in_..."
 420 costCentreName (NormalCC kind mod_name grp_name is_dupd is_caf)
 421   =  case is_caf of { IsCafCC -> "CAF:";   _ -> "" }
 422   ++ case kind of { UserCC name -> _UNPK_ name;
 423                     AutoCC id   -> getOccString id;
 424                     DictCC id   -> getOccString id
 425                   }
 426 \end{code}
 427
 428 Cost Centre Declarations
 429
 430 \begin{code}
 431 #ifdef DEBUG
 432 pprCostCentreDecl is_local (NoCostCentre)
 433   = panic "pprCostCentreDecl: no cost centre!"
 434 #endif
 435 pprCostCentreDecl is_local cc
 436   = if is_local then
 437         hcat [
 438             ptext SLIT("CC_DECLARE"),char '(',
 439             cc_ident,             comma,
 440             ppCostCentreName cc,  comma,
 441             pp_str mod_name,      comma,
 442             pp_str grp_name,      comma,
 443             ptext is_subsumed,    comma,
 444             if externally_visible
 445                then empty
 446                else ptext SLIT("static"),
 447             text ");"]
 448     else
 449         hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ]
 450   where
 451     cc_ident = ppCostCentreLbl cc
 452
 453     pp_str s  = doubleQuotes (ptext s)
 454
 455     (mod_name, grp_name, is_subsumed, externally_visible)
 456       = get_cc_info cc
 457
 458
 459 get_cc_info :: CostCentre ->
 460         (FAST_STRING,                   -- module name
 461          FAST_STRING,                   -- group name
 462          FAST_STRING,                   -- subsumed value
 463          Bool)                          -- externally visible
 464
 465 get_cc_info cc
 466   = case cc of
 467           AllCafsCC m g -> (m, g, cc_IS_CAF, True)
 468
 469           AllDictsCC m g _ -> (m, g, cc_IS_DICT, True)
 470
 471           NormalCC (DictCC i) m g is_dupd is_caf
 472             -> (m, g, cc_IS_DICT, externallyVisibleId i)
 473
 474           NormalCC x m g is_dupd is_caf
 475             -> (m, g, do_caf is_caf,
 476                 case x of { UserCC _ -> True; AutoCC i -> externallyVisibleId i})
 477       where
 478         cc_IS_CAF      = SLIT("CC_IS_CAF")
 479         cc_IS_DICT     = SLIT("CC_IS_DICT")
 480         cc_IS_BORING   = SLIT("CC_IS_BORING")
 481
 482         do_caf IsCafCC       = cc_IS_CAF
 483         do_caf IsNotCafCC    = cc_IS_BORING
 484 \end{code}