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(..), IsDictCC(..),
   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, mkDictCC, mkAllCafsCC, mkAllDictsCC,
  17         mkSingletonCCS, cafifyCC, dupifyCC,
  18         isCafCC, isDictCC, 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                           Module, getOccName, occNameFS, pprModule, moduleUserString
  33                         )
  34 import Outputable
  35 import Util             ( thenCmp )
  36 \end{code}
  37
  38 A Cost Centre Stack is something that can be attached to a closure.
  39 This is either:
  40
  41         - the current cost centre stack (CCCS)
  42         - a pre-defined cost centre stack (there are several
  43           pre-defined CCSs, see below).
  44
  45 \begin{code}
  46 data CostCentreStack
  47   = NoCCS
  48
  49   | CurrentCCS          -- Pinned on a let(rec)-bound
  50                         -- thunk/function/constructor, this says that the
  51                         -- cost centre to be attached to the object, when it
  52                         -- is allocated, is whatever is in the
  53                         -- current-cost-centre-stack register.
  54
  55   | SubsumedCCS         -- Cost centre stack for top-level subsumed functions
  56                         -- (CAFs get an AllCafsCC).
  57                         -- Its execution costs get subsumed into the caller.
  58                         -- This guy is *only* ever pinned on static closures,
  59                         -- and is *never* the cost centre for an SCC construct.
  60
  61   | OverheadCCS         -- We charge costs due to the profiling-system
  62                         -- doing its work to "overhead".
  63                         --
  64                         -- Objects whose CCS is "Overhead"
  65                         -- have their *allocation* charged to "overhead",
  66                         -- but have the current CCS put into the object
  67                         -- itself.
  68
  69                         -- For example, if we transform "f g" to "let
  70                         -- g' = g in f g'" (so that something about
  71                         -- profiling works better...), then we charge
  72                         -- the *allocation* of g' to OverheadCCS, but
  73                         -- we put the cost-centre of the call to f
  74                         -- (i.e., current CCS) into the g' object.  When
  75                         -- g' is entered, the CCS of the call
  76                         -- to f will be set.
  77
  78   | DontCareCCS         -- We need a CCS to stick in static closures
  79                         -- (for data), but we *don't* expect them to
  80                         -- accumulate any costs.  But we still need
  81                         -- the placeholder.  This CCS is it.
  82
  83   | SingletonCCS CostCentre
  84                         -- This is primarily for CAF cost centres, which
  85                         -- are attached to top-level thunks right at the
  86                         -- end of STG processing, before code generation.
  87                         -- Hence, a CAF cost centre never appears as the
  88                         -- argument of an _scc_.
  89                         -- Also, we generate these singleton CCSs statically
  90                         -- as part of code generation.
  91
  92   deriving (Eq, Ord)    -- needed for Ord on CLabel
  93 \end{code}
  94
  95 A Cost Centre is the argument of an _scc_ expression.
  96
  97 \begin{code}
  98 type Group = FAST_STRING        -- "Group" that this CC is in; eg directory
  99
 100 data CostCentre
 101   = NoCostCentre        -- Having this constructor avoids having
 102                         -- to use "Maybe CostCentre" all the time.
 103
 104   | NormalCC {
 105                 cc_name :: CcName,              -- Name of the cost centre itself
 106                 cc_mod  :: Module,              -- Name of module defining this CC.
 107                 cc_grp  :: Group,               -- "Group" that this CC is in.
 108                 cc_is_dict :: IsDictCC,         -- see below
 109                 cc_is_dupd :: IsDupdCC,         -- see below
 110                 cc_is_caf  :: IsCafCC           -- see below
 111     }
 112
 113   | AllCafsCC {
 114                 cc_mod  :: Module,              -- Name of module defining this CC.
 115                 cc_grp  :: Group                -- "Group" that this CC is in
 116                         -- Again, one "big" CAF cc per module, where all
 117                         -- CAF costs are attributed unless the user asked for
 118                         -- per-individual-CAF cost attribution.
 119     }
 120
 121   | AllDictsCC {
 122                 cc_mod  :: Module,              -- Name of module defining this CC.
 123                 cc_grp  :: Group,               -- "Group" that this CC is in.
 124                         -- Again, one "big" DICT cc per module, where all
 125                         -- DICT costs are attributed unless the user asked for
 126                         -- per-individual-DICT cost attribution.
 127                 cc_is_dupd :: IsDupdCC
 128     }
 129
 130 type CcName = EncodedFS
 131
 132 data IsDictCC = DictCC | VanillaCC
 133
 134 data IsDupdCC
 135   = OriginalCC  -- This says how the CC is *used*.  Saying that
 136   | DupdCC              -- it is DupdCC doesn't make it a different
 137                         -- CC, just that it a sub-expression which has
 138                         -- been moved ("dupd") into a different scope.
 139                         --
 140                         -- The point about a dupd SCC is that we don't
 141                         -- count entries to it, because it's not the
 142                         -- "original" one.
 143                         --
 144                         -- In the papers, it's called "SCCsub",
 145                         --  i.e. SCCsub CC == SCC DupdCC,
 146                         -- but we are trying to avoid confusion between
 147                         -- "subd" and "subsumed".  So we call the former
 148                         -- "dupd".
 149
 150 data IsCafCC = CafCC | NotCafCC
 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 (SingletonCCS cc)              = isCafCC cc
 187 isCafCCS _                              = False
 188
 189 isDictCCS (SingletonCCS cc)             = isDictCC cc
 190 isDictCCS _                             = 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 -> Group -> CostCentre
 201
 202 mkUserCC cc_name module_name group_name
 203   = NormalCC { cc_name = encodeFS cc_name,
 204                cc_mod =  module_name, cc_grp = group_name,
 205                cc_is_dict = VanillaCC, cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
 206     }
 207
 208 mkDictCC, mkAutoCC :: Id -> Module -> Group -> IsCafCC -> CostCentre
 209
 210 mkDictCC id module_name group_name is_caf
 211   = NormalCC { cc_name = occNameFS (getOccName id),
 212                cc_mod =  module_name, cc_grp = group_name,
 213                cc_is_dict = DictCC, cc_is_dupd = OriginalCC, cc_is_caf = is_caf
 214     }
 215
 216 mkAutoCC id module_name group_name is_caf
 217   = NormalCC { cc_name = occNameFS (getOccName id),
 218                cc_mod =  module_name, cc_grp = group_name,
 219                cc_is_dict = VanillaCC, cc_is_dupd = OriginalCC, cc_is_caf = is_caf
 220     }
 221
 222 mkAllCafsCC  m g          = AllCafsCC  { cc_mod = m, cc_grp = g }
 223 mkAllDictsCC m g is_dupd  = AllDictsCC { cc_mod = m, cc_grp = g,
 224                                          cc_is_dupd = if is_dupd then DupdCC else OriginalCC }
 225
 226 mkSingletonCCS :: CostCentre -> CostCentreStack
 227 mkSingletonCCS cc = SingletonCCS cc
 228
 229 cafifyCC, dupifyCC  :: CostCentre -> CostCentre
 230
 231 cafifyCC cc@(AllDictsCC {}) = cc
 232 cafifyCC cc@(NormalCC {cc_is_caf = is_caf})
 233   = ASSERT(not_a_caf_already is_caf)
 234     cc {cc_is_caf = CafCC}
 235   where
 236     not_a_caf_already CafCC = False
 237     not_a_caf_already _       = True
 238 cafifyCC cc = pprPanic "cafifyCC" (ppr cc)
 239
 240 dupifyCC cc = cc {cc_is_dupd = DupdCC}
 241
 242 isEmptyCC, isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
 243
 244 isEmptyCC (NoCostCentre)                = True
 245 isEmptyCC _                             = False
 246
 247 isCafCC (AllCafsCC {})                   = True
 248 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
 249 isCafCC _                                = False
 250
 251 isDictCC (AllDictsCC {})                  = True
 252 isDictCC (NormalCC {cc_is_dict = DictCC}) = True
 253 isDictCC _                                = False
 254
 255 isDupdCC (AllDictsCC {cc_is_dupd = DupdCC}) = True
 256 isDupdCC (NormalCC   {cc_is_dupd = DupdCC}) = True
 257 isDupdCC _                                   = False
 258
 259 isSccCountCostCentre :: CostCentre -> Bool
 260   -- Is this a cost-centre which records scc counts
 261
 262 #if DEBUG
 263 isSccCountCostCentre NoCostCentre  = panic "isSccCount:NoCostCentre"
 264 #endif
 265 isSccCountCostCentre cc | isCafCC cc  = False
 266                         | isDupdCC cc = False
 267                         | isDictCC cc = True
 268                         | otherwise   = True
 269
 270 sccAbleCostCentre :: CostCentre -> Bool
 271   -- Is this a cost-centre which can be sccd ?
 272
 273 #if DEBUG
 274 sccAbleCostCentre NoCostCentre  = panic "sccAbleCC:NoCostCentre"
 275 #endif
 276 sccAbleCostCentre cc | isCafCC cc = False
 277                      | otherwise  = True
 278
 279 ccFromThisModule :: CostCentre -> Module -> Bool
 280 ccFromThisModule cc m = cc_mod cc == m
 281 \end{code}
 282
 283 \begin{code}
 284 instance Eq CostCentre where
 285         c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
 286
 287 instance Ord CostCentre where
 288         compare = cmpCostCentre
 289
 290 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
 291
 292 cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2}) = m1 `compare` m2
 293 cmpCostCentre (AllDictsCC {cc_mod = m1}) (AllDictsCC {cc_mod = m2}) = m1 `compare` m2
 294
 295 cmpCostCentre (NormalCC {cc_name = n1, cc_mod =  m1, cc_is_caf = c1})
 296               (NormalCC {cc_name = n2, cc_mod =  m2, cc_is_caf = 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` (n1 `compare` n2) `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_caf NotCafCC CafCC     = LT
 313 cmp_caf NotCafCC NotCafCC  = EQ
 314 cmp_caf CafCC    CafCC     = EQ
 315 cmp_caf CafCC    NotCafCC  = GT
 316 \end{code}
 317
 318 -----------------------------------------------------------------------------
 319 Printing Cost Centre Stacks.
 320
 321 There are two ways to print a CCS:
 322
 323         - for debugging output (i.e. -ddump-whatever),
 324         - as a C label
 325
 326 \begin{code}
 327 instance Outputable CostCentreStack where
 328   ppr ccs = case ccs of
 329                 NoCCS           -> ptext SLIT("NO_CCS")
 330                 CurrentCCS      -> ptext SLIT("CCCS")
 331                 OverheadCCS     -> ptext SLIT("CCS_OVERHEAD")
 332                 DontCareCCS     -> ptext SLIT("CCS_DONTZuCARE")
 333                 SubsumedCCS     -> ptext SLIT("CCS_SUBSUMED")
 334                 SingletonCCS cc -> ptext SLIT("CCS_") <> ppr cc
 335
 336 pprCostCentreStackDecl :: CostCentreStack -> SDoc
 337 pprCostCentreStackDecl ccs@(SingletonCCS cc)
 338   = let
 339        is_subsumed = ccSubsumed cc
 340     in
 341     hcat [ ptext SLIT("CCS_DECLARE"), char '(',
 342            ppr ccs,             comma,  -- better be codeStyle
 343            ppCostCentreLbl cc,  comma,
 344            ptext is_subsumed,   comma,
 345            empty,       -- Now always externally visible
 346            text ");"
 347          ]
 348
 349 pprCostCentreStackDecl ccs
 350   = pprPanic "pprCostCentreStackDecl: " (ppr ccs)
 351 \end{code}
 352
 353 -----------------------------------------------------------------------------
 354 Printing Cost Centres.
 355
 356 There are several different ways in which we might want to print a
 357 cost centre:
 358
 359         - the name of the cost centre, for profiling output (a C string)
 360         - the label, i.e. C label for cost centre in .hc file.
 361         - the debugging name, for output in -ddump things
 362         - the interface name, for printing in _scc_ exprs in iface files.
 363
 364 The last 3 are derived from costCentreStr below.  The first is given
 365 by costCentreName.
 366
 367 \begin{code}
 368 instance Outputable CostCentre where
 369   ppr cc = getPprStyle $ \ sty ->
 370            if codeStyle sty
 371            then ppCostCentreLbl cc
 372            else text (costCentreUserName cc)
 373
 374 -- Printing in an interface file or in Core generally
 375 pprCostCentreCore (AllCafsCC {cc_mod = m, cc_grp = g})
 376   = text "__sccC" <+> braces (pprModule m <+> doubleQuotes (ptext g))
 377 pprCostCentreCore (AllDictsCC {cc_mod = m, cc_grp = g, cc_is_dupd = dup})
 378   = text "__sccD" <+> braces (pprModule m <+> doubleQuotes (ptext g) <+> pp_dup dup)
 379 pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, cc_grp = g,
 380                              cc_is_dict = dic, cc_is_caf = caf, cc_is_dupd = dup})
 381   = text "__scc" <+> braces (hsep [
 382         ptext n,
 383         pprModule m,
 384         doubleQuotes (ptext g),
 385         pp_dict dic,
 386         pp_dup dup,
 387         pp_caf caf
 388     ])
 389
 390 pp_dict DictCC = text "__A"
 391 pp_dict other  = empty
 392
 393 pp_dup DupdCC = char '!'
 394 pp_dup other   = empty
 395
 396 pp_caf CafCC = text "__C"
 397 pp_caf other   = empty
 398
 399
 400 -- Printing as a C label
 401 ppCostCentreLbl (NoCostCentre)                       = text "CC_NONE"
 402 ppCostCentreLbl (AllCafsCC  {cc_mod = m})            = text "CC_CAFs_"  <> pprModule m
 403 ppCostCentreLbl (AllDictsCC {cc_mod = m})            = text "CC_DICTs_" <> pprModule m
 404 ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m}) = text "CC_" <> pprModule m <> ptext n
 405
 406 -- This is the name to go in the user-displayed string,
 407 -- recorded in the cost centre declaration
 408 costCentreUserName (NoCostCentre)  = "NO_CC"
 409 costCentreUserName (AllCafsCC {})  = "CAFs_in_..."
 410 costCentreUserName (AllDictsCC {}) = "DICTs_in_..."
 411 costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf})
 412   =  case is_caf of { CafCC -> "CAF:";   _ -> "" } ++ decode (_UNPK_ name)
 413 \end{code}
 414
 415 Cost Centre Declarations
 416
 417 \begin{code}
 418 #ifdef DEBUG
 419 pprCostCentreDecl is_local (NoCostCentre)
 420   = panic "pprCostCentreDecl: no cost centre!"
 421 #endif
 422 pprCostCentreDecl is_local cc
 423   = if is_local then
 424         hcat [
 425             ptext SLIT("CC_DECLARE"),char '(',
 426             cc_ident,                                           comma,
 427             doubleQuotes (text (costCentreUserName cc)),        comma,
 428             doubleQuotes (text (moduleUserString mod_name)),    comma,
 429             doubleQuotes (ptext grp_name),                      comma,
 430             ptext is_subsumed,                                  comma,
 431             empty,      -- Now always externally visible
 432             text ");"]
 433     else
 434         hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ]
 435   where
 436     cc_ident    = ppCostCentreLbl cc
 437     mod_name    = cc_mod cc
 438     grp_name    = cc_grp cc
 439     is_subsumed = ccSubsumed cc
 440
 441 ccSubsumed :: CostCentre -> FAST_STRING         -- subsumed value
 442 ccSubsumed cc | isCafCC  cc = SLIT("CC_IS_CAF")
 443               | isDictCC cc = SLIT("CC_IS_DICT")
 444               | otherwise   = SLIT("CC_IS_BORING")
 445 \end{code}