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