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 {-# OPTIONS -fno-warn-incomplete-patterns #-}
   8 -- The above warning supression flag is a temporary kludge.
   9 -- While working on this module you are encouraged to remove it and fix
  10 -- any warnings in the module. See
  11 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
  12 -- for details
  13
  14 module CostCentre (
  15         CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..),
  16                 -- All abstract except to friend: ParseIface.y
  17
  18         CostCentreStack,
  19         CollectedCCs,
  20         noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
  21         noCostCentre, noCCAttached,
  22         noCCSAttached, isCurrentCCS,  isSubsumedCCS, currentOrSubsumedCCS,
  23         isDerivedFromCurrentCCS, maybeSingletonCCS,
  24         decomposeCCS,
  25
  26         mkUserCC, mkAutoCC, mkAllCafsCC,
  27         mkSingletonCCS, dupifyCC, pushCCOnCCS,
  28         isCafCCS, isCafCC,
  29         isSccCountCostCentre,
  30         sccAbleCostCentre,
  31         ccFromThisModule,
  32
  33         pprCostCentreCore,
  34         costCentreUserName,
  35
  36         cmpCostCentre   -- used for removing dups in a list
  37     ) where
  38
  39 #include "HsVersions.h"
  40
  41 import Var              ( Id )
  42 import Name
  43 import Module           ( Module )
  44 import Outputable
  45 import FastTypes
  46 import FastString
  47 import Util             ( thenCmp )
  48 \end{code}
  49
  50 A Cost Centre Stack is something that can be attached to a closure.
  51 This is either:
  52
  53         - the current cost centre stack (CCCS)
  54         - a pre-defined cost centre stack (there are several
  55           pre-defined CCSs, see below).
  56
  57 \begin{code}
  58 data CostCentreStack
  59   = NoCCS
  60
  61   | CurrentCCS          -- Pinned on a let(rec)-bound
  62                         -- thunk/function/constructor, this says that the
  63                         -- cost centre to be attached to the object, when it
  64                         -- is allocated, is whatever is in the
  65                         -- current-cost-centre-stack register.
  66
  67   | SubsumedCCS         -- Cost centre stack for top-level subsumed functions
  68                         -- (CAFs get an AllCafsCC).
  69                         -- Its execution costs get subsumed into the caller.
  70                         -- This guy is *only* ever pinned on static closures,
  71                         -- and is *never* the cost centre for an SCC construct.
  72
  73   | OverheadCCS         -- We charge costs due to the profiling-system
  74                         -- doing its work to "overhead".
  75                         --
  76                         -- Objects whose CCS is "Overhead"
  77                         -- have their *allocation* charged to "overhead",
  78                         -- but have the current CCS put into the object
  79                         -- itself.
  80
  81                         -- For example, if we transform "f g" to "let
  82                         -- g' = g in f g'" (so that something about
  83                         -- profiling works better...), then we charge
  84                         -- the *allocation* of g' to OverheadCCS, but
  85                         -- we put the cost-centre of the call to f
  86                         -- (i.e., current CCS) into the g' object.  When
  87                         -- g' is entered, the CCS of the call
  88                         -- to f will be set.
  89
  90   | DontCareCCS         -- We need a CCS to stick in static closures
  91                         -- (for data), but we *don't* expect them to
  92                         -- accumulate any costs.  But we still need
  93                         -- the placeholder.  This CCS is it.
  94
  95   | PushCC CostCentre CostCentreStack
  96                 -- These are used during code generation as the CCSs
  97                 -- attached to closures.  A PushCC never appears as
  98                 -- the argument to an _scc_.
  99                 --
 100                 -- The tail (2nd argument) is either NoCCS, indicating
 101                 -- a staticly allocated CCS, or CurrentCCS indicating
 102                 -- a dynamically created CCS.  We only support
 103                 -- statically allocated *singleton* CCSs at the
 104                 -- moment, for the purposes of initialising the CCS
 105                 -- field of a CAF.
 106
 107   deriving (Eq, Ord)    -- needed for Ord on CLabel
 108 \end{code}
 109
 110 A Cost Centre is the argument of an _scc_ expression.
 111
 112 \begin{code}
 113 data CostCentre
 114   = NoCostCentre        -- Having this constructor avoids having
 115                         -- to use "Maybe CostCentre" all the time.
 116
 117   | NormalCC {
 118                 cc_name :: CcName,      -- Name of the cost centre itself
 119                 cc_mod  :: Module,      -- Name of module defining this CC.
 120                 cc_is_dupd :: IsDupdCC, -- see below
 121                 cc_is_caf  :: IsCafCC   -- see below
 122     }
 123
 124   | AllCafsCC {
 125                 cc_mod  :: Module       -- Name of module defining this CC.
 126     }
 127
 128 type CcName = FastString
 129
 130 data IsDupdCC
 131   = OriginalCC  -- This says how the CC is *used*.  Saying that
 132   | DupdCC              -- it is DupdCC doesn't make it a different
 133                         -- CC, just that it a sub-expression which has
 134                         -- been moved ("dupd") into a different scope.
 135                         --
 136                         -- The point about a dupd SCC is that we don't
 137                         -- count entries to it, because it's not the
 138                         -- "original" one.
 139                         --
 140                         -- In the papers, it's called "SCCsub",
 141                         --  i.e. SCCsub CC == SCC DupdCC,
 142                         -- but we are trying to avoid confusion between
 143                         -- "subd" and "subsumed".  So we call the former
 144                         -- "dupd".
 145
 146 data IsCafCC = CafCC | NotCafCC
 147
 148 -- synonym for triple which describes the cost centre info in the generated
 149 -- code for a module.
 150 type CollectedCCs
 151   = ( [CostCentre]       -- local cost-centres that need to be decl'd
 152     , [CostCentre]       -- "extern" cost-centres
 153     , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks
 154     )
 155 \end{code}
 156
 157 WILL: Would there be any merit to recording ``I am now using a
 158 cost-centre from another module''?  I don't know if this would help a
 159 user; it might be interesting to us to know how much computation is
 160 being moved across module boundaries.
 161
 162 SIMON: Maybe later...
 163
 164 \begin{code}
 165 noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS :: CostCentreStack
 166
 167 noCCS                   = NoCCS
 168 subsumedCCS             = SubsumedCCS
 169 currentCCS              = CurrentCCS
 170 overheadCCS             = OverheadCCS
 171 dontCareCCS             = DontCareCCS
 172
 173 noCostCentre :: CostCentre
 174 noCostCentre            = NoCostCentre
 175 \end{code}
 176
 177 Predicates on Cost-Centre Stacks
 178
 179 \begin{code}
 180 noCCSAttached :: CostCentreStack -> Bool
 181 noCCSAttached NoCCS                     = True
 182 noCCSAttached _                         = False
 183
 184 noCCAttached :: CostCentre -> Bool
 185 noCCAttached NoCostCentre               = True
 186 noCCAttached _                          = False
 187
 188 isCurrentCCS :: CostCentreStack -> Bool
 189 isCurrentCCS CurrentCCS                 = True
 190 isCurrentCCS _                          = False
 191
 192 isSubsumedCCS :: CostCentreStack -> Bool
 193 isSubsumedCCS SubsumedCCS               = True
 194 isSubsumedCCS _                         = False
 195
 196 isCafCCS :: CostCentreStack -> Bool
 197 isCafCCS (PushCC cc NoCCS)              = isCafCC cc
 198 isCafCCS _                              = False
 199
 200 isDerivedFromCurrentCCS :: CostCentreStack -> Bool
 201 isDerivedFromCurrentCCS CurrentCCS      = True
 202 isDerivedFromCurrentCCS (PushCC _ ccs)  = isDerivedFromCurrentCCS ccs
 203 isDerivedFromCurrentCCS _               = False
 204
 205 currentOrSubsumedCCS :: CostCentreStack -> Bool
 206 currentOrSubsumedCCS SubsumedCCS        = True
 207 currentOrSubsumedCCS CurrentCCS         = True
 208 currentOrSubsumedCCS _                  = False
 209
 210 maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
 211 maybeSingletonCCS (PushCC cc NoCCS)     = Just cc
 212 maybeSingletonCCS _                     = Nothing
 213 \end{code}
 214
 215 Building cost centres
 216
 217 \begin{code}
 218 mkUserCC :: FastString -> Module -> CostCentre
 219 mkUserCC cc_name mod
 220   = NormalCC { cc_name = cc_name, cc_mod =  mod,
 221                cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
 222     }
 223
 224 mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
 225 mkAutoCC id mod is_caf
 226   = NormalCC { cc_name = str, cc_mod =  mod,
 227                cc_is_dupd = OriginalCC, cc_is_caf = is_caf
 228     }
 229   where
 230         name = getName id
 231         -- beware: we might be making an auto CC for a compiler-generated
 232         -- thing (like a CAF when -caf-all is on), so include the uniq.
 233         -- See bug #249, tests prof001, prof002
 234         str | isSystemName name = mkFastString (showSDoc (ppr name))
 235             | otherwise         = occNameFS (getOccName id)
 236
 237 mkAllCafsCC :: Module -> CostCentre
 238 mkAllCafsCC m = AllCafsCC  { cc_mod = m }
 239
 240
 241
 242 mkSingletonCCS :: CostCentre -> CostCentreStack
 243 mkSingletonCCS cc = pushCCOnCCS cc NoCCS
 244
 245 pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
 246 pushCCOnCCS = PushCC
 247
 248 dupifyCC :: CostCentre -> CostCentre
 249 dupifyCC cc = cc {cc_is_dupd = DupdCC}
 250
 251 isCafCC, isDupdCC :: CostCentre -> Bool
 252
 253 isCafCC (AllCafsCC {})                   = True
 254 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
 255 isCafCC _                                = False
 256
 257 isDupdCC (NormalCC   {cc_is_dupd = DupdCC}) = True
 258 isDupdCC _                                   = False
 259
 260 isSccCountCostCentre :: CostCentre -> Bool
 261   -- Is this a cost-centre which records scc counts
 262
 263 #if DEBUG
 264 isSccCountCostCentre NoCostCentre  = panic "isSccCount:NoCostCentre"
 265 #endif
 266 isSccCountCostCentre cc | isCafCC cc  = False
 267                         | isDupdCC cc = False
 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
 294 cmpCostCentre (NormalCC {cc_name = n1, cc_mod =  m1, cc_is_caf = c1})
 295               (NormalCC {cc_name = n2, cc_mod =  m2, cc_is_caf = c2})
 296     -- first key is module name, then we use "kinds" (which include
 297     -- names) and finally the caf flag
 298   = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
 299
 300 cmpCostCentre other_1 other_2
 301   = let
 302         tag1 = tag_CC other_1
 303         tag2 = tag_CC other_2
 304     in
 305     if tag1 <# tag2 then LT else GT
 306   where
 307     tag_CC (NormalCC   {}) = _ILIT(1)
 308     tag_CC (AllCafsCC  {}) = _ILIT(2)
 309
 310 -- TODO: swap order of IsCafCC, add deriving Ord
 311 cmp_caf :: IsCafCC -> IsCafCC -> Ordering
 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
 317 decomposeCCS :: CostCentreStack -> ([CostCentre],CostCentreStack)
 318 decomposeCCS (PushCC cc ccs) = (cc:more, ccs')
 319   where (more,ccs') = decomposeCCS ccs
 320 decomposeCCS ccs = ([],ccs)
 321 \end{code}
 322
 323 -----------------------------------------------------------------------------
 324 Printing Cost Centre Stacks.
 325
 326 The outputable instance for CostCentreStack prints the CCS as a C
 327 expression.
 328
 329 NOTE: Not all cost centres are suitable for using in a static
 330 initializer.  In particular, the PushCC forms where the tail is CCCS
 331 may only be used in inline C code because they expand to a
 332 non-constant C expression.
 333
 334 \begin{code}
 335 instance Outputable CostCentreStack where
 336   ppr NoCCS             = ptext SLIT("NO_CCS")
 337   ppr CurrentCCS        = ptext SLIT("CCCS")
 338   ppr OverheadCCS       = ptext SLIT("CCS_OVERHEAD")
 339   ppr DontCareCCS       = ptext SLIT("CCS_DONT_CARE")
 340   ppr SubsumedCCS       = ptext SLIT("CCS_SUBSUMED")
 341   ppr (PushCC cc NoCCS) = ppr cc <> ptext SLIT("_ccs")
 342   ppr (PushCC cc ccs)   = ptext SLIT("PushCostCentre") <>
 343                            parens (ppr ccs <> comma <>
 344                            parens(ptext SLIT("void *")) <> ppr cc)
 345 \end{code}
 346
 347 -----------------------------------------------------------------------------
 348 Printing Cost Centres.
 349
 350 There are several different ways in which we might want to print a
 351 cost centre:
 352
 353         - the name of the cost centre, for profiling output (a C string)
 354         - the label, i.e. C label for cost centre in .hc file.
 355         - the debugging name, for output in -ddump things
 356         - the interface name, for printing in _scc_ exprs in iface files.
 357
 358 The last 3 are derived from costCentreStr below.  The first is given
 359 by costCentreName.
 360
 361 \begin{code}
 362 instance Outputable CostCentre where
 363   ppr cc = getPprStyle $ \ sty ->
 364            if codeStyle sty
 365            then ppCostCentreLbl cc
 366            else text (costCentreUserName cc)
 367
 368 -- Printing in an interface file or in Core generally
 369 pprCostCentreCore :: CostCentre -> SDoc
 370 pprCostCentreCore (AllCafsCC {cc_mod = m})
 371   = text "__sccC" <+> braces (ppr m)
 372 pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
 373                              cc_is_caf = caf, cc_is_dupd = dup})
 374   = text "__scc" <+> braces (hsep [
 375         ftext (zEncodeFS n),
 376         ppr m,
 377         pp_dup dup,
 378         pp_caf caf
 379     ])
 380
 381 pp_dup :: IsDupdCC -> SDoc
 382 pp_dup DupdCC = char '!'
 383 pp_dup _      = empty
 384
 385 pp_caf :: IsCafCC -> SDoc
 386 pp_caf CafCC = text "__C"
 387 pp_caf _     = empty
 388
 389 -- Printing as a C label
 390 ppCostCentreLbl :: CostCentre -> SDoc
 391 ppCostCentreLbl (NoCostCentre)            = text "NONE_cc"
 392 ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"
 393 ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf})
 394   = ppr m <> char '_' <> ftext (zEncodeFS n) <>
 395         text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
 396
 397 -- This is the name to go in the user-displayed string,
 398 -- recorded in the cost centre declaration
 399 costCentreUserName :: CostCentre -> String
 400 costCentreUserName (NoCostCentre)  = "NO_CC"
 401 costCentreUserName (AllCafsCC {})  = "CAF"
 402 costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf})
 403   =  case is_caf of { CafCC -> "CAF:";   _ -> "" } ++ unpackFS name
 404 \end{code}