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, setCurrentCCS, overheadCCS, dontCareCCS,
  13         noCostCentre, noCCAttached,
  14         noCCSAttached, isCurrentCCS,  isSetCurrentCCS, 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, pprModule, moduleUserString )
  35 import Outputable
  36 import Util             ( thenCmp )
  37 \end{code}
  38
  39 A Cost Centre Stack is something that can be attached to a closure.
  40 This is either:
  41
  42         - the current cost centre stack (CCCS)
  43         - a pre-defined cost centre stack (there are several
  44           pre-defined CCSs, see below).
  45
  46 \begin{code}
  47 data CostCentreStack
  48   = NoCCS
  49
  50   | CurrentCCS          -- Pinned on a let(rec)-bound
  51                         -- thunk/function/constructor, this says that the
  52                         -- cost centre to be attached to the object, when it
  53                         -- is allocated, is whatever is in the
  54                         -- current-cost-centre-stack register.
  55
  56   | SetCurrentCCS       -- Special cost centre for non-top-level functions
  57                         -- which is always *set* rather than possibly
  58                         -- appended to the current CCS.
  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 type Group = FAST_STRING        -- "Group" that this CC is in; eg directory
 104
 105 data CostCentre
 106   = NoCostCentre        -- Having this constructor avoids having
 107                         -- to use "Maybe CostCentre" all the time.
 108
 109   | NormalCC {
 110                 cc_name :: CcName,              -- Name of the cost centre itself
 111                 cc_mod  :: Module,              -- Name of module defining this CC.
 112                 cc_grp  :: Group,               -- "Group" that this CC is in.
 113                 cc_is_dupd :: IsDupdCC,         -- see below
 114                 cc_is_caf  :: IsCafCC           -- see below
 115     }
 116
 117   | AllCafsCC {
 118                 cc_mod  :: Module,              -- Name of module defining this CC.
 119                 cc_grp  :: Group                -- "Group" that this CC is in
 120                         -- Again, one "big" CAF cc per module, where all
 121                         -- CAF costs are attributed unless the user asked for
 122                         -- per-individual-CAF cost attribution.
 123     }
 124
 125 type CcName = EncodedFS
 126
 127 data IsDupdCC
 128   = OriginalCC  -- This says how the CC is *used*.  Saying that
 129   | DupdCC              -- it is DupdCC doesn't make it a different
 130                         -- CC, just that it a sub-expression which has
 131                         -- been moved ("dupd") into a different scope.
 132                         --
 133                         -- The point about a dupd SCC is that we don't
 134                         -- count entries to it, because it's not the
 135                         -- "original" one.
 136                         --
 137                         -- In the papers, it's called "SCCsub",
 138                         --  i.e. SCCsub CC == SCC DupdCC,
 139                         -- but we are trying to avoid confusion between
 140                         -- "subd" and "subsumed".  So we call the former
 141                         -- "dupd".
 142
 143 data IsCafCC = CafCC | NotCafCC
 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 setCurrentCCS           = SetCurrentCCS
 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 isSetCurrentCCS SetCurrentCCS           = True
 178 isSetCurrentCCS _                       = False
 179
 180 isSubsumedCCS SubsumedCCS               = True
 181 isSubsumedCCS _                         = False
 182
 183 isCafCCS (SingletonCCS cc)              = isCafCC cc
 184 isCafCCS _                              = False
 185
 186 currentOrSubsumedCCS SubsumedCCS        = True
 187 currentOrSubsumedCCS CurrentCCS         = True
 188 currentOrSubsumedCCS SetCurrentCCS      = True
 189 currentOrSubsumedCCS _                  = False
 190 \end{code}
 191
 192 Building cost centres
 193
 194 \begin{code}
 195 mkUserCC :: UserFS -> Module -> Group -> CostCentre
 196
 197 mkUserCC cc_name module_name group_name
 198   = NormalCC { cc_name = encodeFS cc_name,
 199                cc_mod =  module_name, cc_grp = group_name,
 200                cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
 201     }
 202
 203 mkAutoCC :: Id -> Module -> Group -> IsCafCC -> CostCentre
 204
 205 mkAutoCC id module_name group_name is_caf
 206   = NormalCC { cc_name = occNameFS (getOccName id),
 207                cc_mod =  module_name, cc_grp = group_name,
 208                cc_is_dupd = OriginalCC, cc_is_caf = is_caf
 209     }
 210
 211 mkAllCafsCC  m g          = AllCafsCC  { cc_mod = m, cc_grp = g }
 212
 213 mkSingletonCCS :: CostCentre -> CostCentreStack
 214 mkSingletonCCS cc = SingletonCCS cc
 215
 216 cafifyCC, dupifyCC  :: CostCentre -> CostCentre
 217
 218 cafifyCC cc@(NormalCC {cc_is_caf = is_caf})
 219   = ASSERT(not_a_caf_already is_caf)
 220     cc {cc_is_caf = CafCC}
 221   where
 222     not_a_caf_already CafCC = False
 223     not_a_caf_already _       = True
 224 cafifyCC cc = pprPanic "cafifyCC" (ppr cc)
 225
 226 dupifyCC cc = cc {cc_is_dupd = DupdCC}
 227
 228 isEmptyCC, isCafCC, isDupdCC :: CostCentre -> Bool
 229
 230 isEmptyCC (NoCostCentre)                = True
 231 isEmptyCC _                             = False
 232
 233 isCafCC (AllCafsCC {})                   = True
 234 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
 235 isCafCC _                                = False
 236
 237 isDupdCC (NormalCC   {cc_is_dupd = DupdCC}) = True
 238 isDupdCC _                                   = False
 239
 240 isSccCountCostCentre :: CostCentre -> Bool
 241   -- Is this a cost-centre which records scc counts
 242
 243 #if DEBUG
 244 isSccCountCostCentre NoCostCentre  = panic "isSccCount:NoCostCentre"
 245 #endif
 246 isSccCountCostCentre cc | isCafCC cc  = False
 247                         | isDupdCC cc = False
 248                         | otherwise   = True
 249
 250 sccAbleCostCentre :: CostCentre -> Bool
 251   -- Is this a cost-centre which can be sccd ?
 252
 253 #if DEBUG
 254 sccAbleCostCentre NoCostCentre  = panic "sccAbleCC:NoCostCentre"
 255 #endif
 256 sccAbleCostCentre cc | isCafCC cc = False
 257                      | otherwise  = True
 258
 259 ccFromThisModule :: CostCentre -> Module -> Bool
 260 ccFromThisModule cc m = cc_mod cc == m
 261 \end{code}
 262
 263 \begin{code}
 264 instance Eq CostCentre where
 265         c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
 266
 267 instance Ord CostCentre where
 268         compare = cmpCostCentre
 269
 270 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
 271
 272 cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2}) = m1 `compare` m2
 273
 274 cmpCostCentre (NormalCC {cc_name = n1, cc_mod =  m1, cc_is_caf = c1})
 275               (NormalCC {cc_name = n2, cc_mod =  m2, cc_is_caf = c2})
 276     -- first key is module name, then we use "kinds" (which include
 277     -- names) and finally the caf flag
 278   = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
 279
 280 cmpCostCentre other_1 other_2
 281   = let
 282         tag1 = tag_CC other_1
 283         tag2 = tag_CC other_2
 284     in
 285     if tag1 _LT_ tag2 then LT else GT
 286   where
 287     tag_CC (NormalCC   {}) = (ILIT(1) :: FAST_INT)
 288     tag_CC (AllCafsCC  {}) = ILIT(2)
 289
 290 cmp_caf NotCafCC CafCC     = LT
 291 cmp_caf NotCafCC NotCafCC  = EQ
 292 cmp_caf CafCC    CafCC     = EQ
 293 cmp_caf CafCC    NotCafCC  = GT
 294 \end{code}
 295
 296 -----------------------------------------------------------------------------
 297 Printing Cost Centre Stacks.
 298
 299 There are two ways to print a CCS:
 300
 301         - for debugging output (i.e. -ddump-whatever),
 302         - as a C label
 303
 304 \begin{code}
 305 instance Outputable CostCentreStack where
 306   ppr ccs = case ccs of
 307                 NoCCS           -> ptext SLIT("NO_CCS")
 308                 CurrentCCS      -> ptext SLIT("CCCS")
 309                 SetCurrentCCS   -> ptext SLIT("SetCCCS")
 310                 OverheadCCS     -> ptext SLIT("CCS_OVERHEAD")
 311                 DontCareCCS     -> ptext SLIT("CCS_DONTZuCARE")
 312                 SubsumedCCS     -> ptext SLIT("CCS_SUBSUMED")
 313                 SingletonCCS cc -> ptext SLIT("CCS_") <> ppr cc
 314
 315 pprCostCentreStackDecl :: CostCentreStack -> SDoc
 316 pprCostCentreStackDecl ccs@(SingletonCCS cc)
 317   = let
 318        is_subsumed = ccSubsumed cc
 319     in
 320     hcat [ ptext SLIT("CCS_DECLARE"), char '(',
 321            ppr ccs,             comma,  -- better be codeStyle
 322            ppCostCentreLbl cc,  comma,
 323            ptext is_subsumed,   comma,
 324            empty,       -- Now always externally visible
 325            text ");"
 326          ]
 327
 328 pprCostCentreStackDecl ccs
 329   = pprPanic "pprCostCentreStackDecl: " (ppr ccs)
 330 \end{code}
 331
 332 -----------------------------------------------------------------------------
 333 Printing Cost Centres.
 334
 335 There are several different ways in which we might want to print a
 336 cost centre:
 337
 338         - the name of the cost centre, for profiling output (a C string)
 339         - the label, i.e. C label for cost centre in .hc file.
 340         - the debugging name, for output in -ddump things
 341         - the interface name, for printing in _scc_ exprs in iface files.
 342
 343 The last 3 are derived from costCentreStr below.  The first is given
 344 by costCentreName.
 345
 346 \begin{code}
 347 instance Outputable CostCentre where
 348   ppr cc = getPprStyle $ \ sty ->
 349            if codeStyle sty
 350            then ppCostCentreLbl cc
 351            else text (costCentreUserName cc)
 352
 353 -- Printing in an interface file or in Core generally
 354 pprCostCentreCore (AllCafsCC {cc_mod = m, cc_grp = g})
 355   = text "__sccC" <+> braces (pprModule m <+> doubleQuotes (ptext g))
 356 pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, cc_grp = g,
 357                              cc_is_caf = caf, cc_is_dupd = dup})
 358   = text "__scc" <+> braces (hsep [
 359         ptext n,
 360         pprModule m,
 361         doubleQuotes (ptext g),
 362         pp_dup dup,
 363         pp_caf caf
 364     ])
 365
 366 pp_dup DupdCC = char '!'
 367 pp_dup other   = empty
 368
 369 pp_caf CafCC = text "__C"
 370 pp_caf other   = empty
 371
 372
 373 -- Printing as a C label
 374 ppCostCentreLbl (NoCostCentre)                       = text "CC_NONE"
 375 ppCostCentreLbl (AllCafsCC  {cc_mod = m})            = text "CC_CAFs_"  <> pprModule m
 376 ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m}) = text "CC_" <> pprModule m <> ptext n
 377
 378 -- This is the name to go in the user-displayed string,
 379 -- recorded in the cost centre declaration
 380 costCentreUserName (NoCostCentre)  = "NO_CC"
 381 costCentreUserName (AllCafsCC {})  = "CAFs_in_..."
 382 costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf})
 383   =  case is_caf of { CafCC -> "CAF:";   _ -> "" } ++ decode (_UNPK_ name)
 384 \end{code}
 385
 386 Cost Centre Declarations
 387
 388 \begin{code}
 389 #ifdef DEBUG
 390 pprCostCentreDecl is_local (NoCostCentre)
 391   = panic "pprCostCentreDecl: no cost centre!"
 392 #endif
 393 pprCostCentreDecl is_local cc
 394   = if is_local then
 395         hcat [
 396             ptext SLIT("CC_DECLARE"),char '(',
 397             cc_ident,                                           comma,
 398             doubleQuotes (text (costCentreUserName cc)),        comma,
 399             doubleQuotes (text (moduleUserString mod_name)),    comma,
 400             doubleQuotes (ptext grp_name),                      comma,
 401             ptext is_subsumed,                                  comma,
 402             empty,      -- Now always externally visible
 403             text ");"]
 404     else
 405         hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ]
 406   where
 407     cc_ident    = ppCostCentreLbl cc
 408     mod_name    = cc_mod cc
 409     grp_name    = cc_grp cc
 410     is_subsumed = ccSubsumed cc
 411
 412 ccSubsumed :: CostCentre -> FAST_STRING         -- subsumed value
 413 ccSubsumed cc | isCafCC  cc = SLIT("CC_IS_CAF")
 414               | otherwise   = SLIT("CC_IS_BORING")
 415 \end{code}