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         CollectedCCs,
  13         noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS,
  14         noCostCentre, noCCAttached,
  15         noCCSAttached, isCurrentCCS,  isSubsumedCCS, currentOrSubsumedCCS,
  16         isDerivedFromCurrentCCS, maybeSingletonCCS,
  17         decomposeCCS,
  18
  19         mkUserCC, mkAutoCC, mkAllCafsCC,
  20         mkSingletonCCS, dupifyCC, pushCCOnCCS,
  21         isCafCCS, isCafCC,
  22         isSccCountCostCentre,
  23         sccAbleCostCentre,
  24         ccFromThisModule,
  25
  26         pprCostCentreCore,
  27         costCentreUserName,
  28
  29         cmpCostCentre   -- used for removing dups in a list
  30     ) where
  31
  32 #include "HsVersions.h"
  33
  34 import Var              ( Id )
  35 import Name
  36 import Module           ( Module )
  37 import Outputable
  38 import FastTypes
  39 import FastString
  40 import Util             ( thenCmp )
  41 \end{code}
  42
  43 A Cost Centre Stack is something that can be attached to a closure.
  44 This is either:
  45
  46         - the current cost centre stack (CCCS)
  47         - a pre-defined cost centre stack (there are several
  48           pre-defined CCSs, see below).
  49
  50 \begin{code}
  51 data CostCentreStack
  52   = NoCCS
  53
  54   | CurrentCCS          -- Pinned on a let(rec)-bound
  55                         -- thunk/function/constructor, this says that the
  56                         -- cost centre to be attached to the object, when it
  57                         -- is allocated, is whatever is in the
  58                         -- current-cost-centre-stack register.
  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   | PushCC CostCentre CostCentreStack
  89                 -- These are used during code generation as the CCSs
  90                 -- attached to closures.  A PushCC never appears as
  91                 -- the argument to an _scc_.
  92                 --
  93                 -- The tail (2nd argument) is either NoCCS, indicating
  94                 -- a staticly allocated CCS, or CurrentCCS indicating
  95                 -- a dynamically created CCS.  We only support
  96                 -- statically allocated *singleton* CCSs at the
  97                 -- moment, for the purposes of initialising the CCS
  98                 -- field of a CAF.
  99
 100   deriving (Eq, Ord)    -- needed for Ord on CLabel
 101 \end{code}
 102
 103 A Cost Centre is the argument of an _scc_ expression.
 104
 105 \begin{code}
 106 data CostCentre
 107   = NoCostCentre        -- Having this constructor avoids having
 108                         -- to use "Maybe CostCentre" all the time.
 109
 110   | NormalCC {
 111                 cc_name :: CcName,      -- Name of the cost centre itself
 112                 cc_mod  :: Module,      -- Name of module defining this CC.
 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     }
 120
 121 type CcName = FastString
 122
 123 data IsDupdCC
 124   = OriginalCC  -- This says how the CC is *used*.  Saying that
 125   | DupdCC              -- it is DupdCC doesn't make it a different
 126                         -- CC, just that it a sub-expression which has
 127                         -- been moved ("dupd") into a different scope.
 128                         --
 129                         -- The point about a dupd SCC is that we don't
 130                         -- count entries to it, because it's not the
 131                         -- "original" one.
 132                         --
 133                         -- In the papers, it's called "SCCsub",
 134                         --  i.e. SCCsub CC == SCC DupdCC,
 135                         -- but we are trying to avoid confusion between
 136                         -- "subd" and "subsumed".  So we call the former
 137                         -- "dupd".
 138
 139 data IsCafCC = CafCC | NotCafCC
 140
 141 -- synonym for triple which describes the cost centre info in the generated
 142 -- code for a module.
 143 type CollectedCCs
 144   = ( [CostCentre]       -- local cost-centres that need to be decl'd
 145     , [CostCentre]       -- "extern" cost-centres
 146     , [CostCentreStack]  -- pre-defined "singleton" cost centre stacks
 147     )
 148 \end{code}
 149
 150 WILL: Would there be any merit to recording ``I am now using a
 151 cost-centre from another module''?  I don't know if this would help a
 152 user; it might be interesting to us to know how much computation is
 153 being moved across module boundaries.
 154
 155 SIMON: Maybe later...
 156
 157 \begin{code}
 158
 159 noCCS                   = NoCCS
 160 subsumedCCS             = SubsumedCCS
 161 currentCCS              = CurrentCCS
 162 overheadCCS             = OverheadCCS
 163 dontCareCCS             = DontCareCCS
 164
 165 noCostCentre            = NoCostCentre
 166 \end{code}
 167
 168 Predicates on Cost-Centre Stacks
 169
 170 \begin{code}
 171 noCCSAttached NoCCS                     = True
 172 noCCSAttached _                         = False
 173
 174 noCCAttached NoCostCentre               = True
 175 noCCAttached _                          = False
 176
 177 isCurrentCCS CurrentCCS                 = True
 178 isCurrentCCS _                          = False
 179
 180 isSubsumedCCS SubsumedCCS               = True
 181 isSubsumedCCS _                         = False
 182
 183 isCafCCS (PushCC cc NoCCS)              = isCafCC cc
 184 isCafCCS _                              = False
 185
 186 isDerivedFromCurrentCCS CurrentCCS      = True
 187 isDerivedFromCurrentCCS (PushCC _ ccs)  = isDerivedFromCurrentCCS ccs
 188 isDerivedFromCurrentCCS _               = False
 189
 190 currentOrSubsumedCCS SubsumedCCS        = True
 191 currentOrSubsumedCCS CurrentCCS         = True
 192 currentOrSubsumedCCS _                  = False
 193
 194 maybeSingletonCCS (PushCC cc NoCCS)     = Just cc
 195 maybeSingletonCCS _                     = Nothing
 196 \end{code}
 197
 198 Building cost centres
 199
 200 \begin{code}
 201 mkUserCC :: FastString -> Module -> CostCentre
 202 mkUserCC cc_name mod
 203   = NormalCC { cc_name = cc_name, cc_mod =  mod,
 204                cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-}
 205     }
 206
 207 mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre
 208 mkAutoCC id mod is_caf
 209   = NormalCC { cc_name = str, cc_mod =  mod,
 210                cc_is_dupd = OriginalCC, cc_is_caf = is_caf
 211     }
 212   where
 213         name = getName id
 214         -- beware: we might be making an auto CC for a compiler-generated
 215         -- thing (like a CAF when -caf-all is on), so include the uniq.
 216         -- See bug #249, tests prof001, prof002
 217         str | isSystemName name = mkFastString (showSDoc (ppr name))
 218             | otherwise         = occNameFS (getOccName id)
 219
 220 mkAllCafsCC m = AllCafsCC  { cc_mod = m }
 221
 222
 223
 224 mkSingletonCCS :: CostCentre -> CostCentreStack
 225 mkSingletonCCS cc = pushCCOnCCS cc NoCCS
 226
 227 pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
 228 pushCCOnCCS = PushCC
 229
 230 dupifyCC cc = cc {cc_is_dupd = DupdCC}
 231
 232 isCafCC, isDupdCC :: CostCentre -> Bool
 233
 234 isCafCC (AllCafsCC {})                   = True
 235 isCafCC (NormalCC {cc_is_caf = CafCC}) = True
 236 isCafCC _                                = False
 237
 238 isDupdCC (NormalCC   {cc_is_dupd = DupdCC}) = True
 239 isDupdCC _                                   = False
 240
 241 isSccCountCostCentre :: CostCentre -> Bool
 242   -- Is this a cost-centre which records scc counts
 243
 244 #if DEBUG
 245 isSccCountCostCentre NoCostCentre  = panic "isSccCount:NoCostCentre"
 246 #endif
 247 isSccCountCostCentre cc | isCafCC cc  = False
 248                         | isDupdCC cc = False
 249                         | otherwise   = True
 250
 251 sccAbleCostCentre :: CostCentre -> Bool
 252   -- Is this a cost-centre which can be sccd ?
 253
 254 #if DEBUG
 255 sccAbleCostCentre NoCostCentre  = panic "sccAbleCC:NoCostCentre"
 256 #endif
 257 sccAbleCostCentre cc | isCafCC cc = False
 258                      | otherwise  = True
 259
 260 ccFromThisModule :: CostCentre -> Module -> Bool
 261 ccFromThisModule cc m = cc_mod cc == m
 262 \end{code}
 263
 264 \begin{code}
 265 instance Eq CostCentre where
 266         c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
 267
 268 instance Ord CostCentre where
 269         compare = cmpCostCentre
 270
 271 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
 272
 273 cmpCostCentre (AllCafsCC  {cc_mod = m1}) (AllCafsCC  {cc_mod = m2}) = m1 `compare` m2
 274
 275 cmpCostCentre (NormalCC {cc_name = n1, cc_mod =  m1, cc_is_caf = c1})
 276               (NormalCC {cc_name = n2, cc_mod =  m2, cc_is_caf = c2})
 277     -- first key is module name, then we use "kinds" (which include
 278     -- names) and finally the caf flag
 279   = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (c1 `cmp_caf` c2)
 280
 281 cmpCostCentre other_1 other_2
 282   = let
 283         tag1 = tag_CC other_1
 284         tag2 = tag_CC other_2
 285     in
 286     if tag1 <# tag2 then LT else GT
 287   where
 288     tag_CC (NormalCC   {}) = (_ILIT 1 :: FastInt)
 289     tag_CC (AllCafsCC  {}) = _ILIT 2
 290
 291 cmp_caf NotCafCC CafCC     = LT
 292 cmp_caf NotCafCC NotCafCC  = EQ
 293 cmp_caf CafCC    CafCC     = EQ
 294 cmp_caf CafCC    NotCafCC  = GT
 295
 296 decomposeCCS :: CostCentreStack -> ([CostCentre],CostCentreStack)
 297 decomposeCCS (PushCC cc ccs) = (cc:more, ccs')
 298   where (more,ccs') = decomposeCCS ccs
 299 decomposeCCS ccs = ([],ccs)
 300 \end{code}
 301
 302 -----------------------------------------------------------------------------
 303 Printing Cost Centre Stacks.
 304
 305 The outputable instance for CostCentreStack prints the CCS as a C
 306 expression.
 307
 308 NOTE: Not all cost centres are suitable for using in a static
 309 initializer.  In particular, the PushCC forms where the tail is CCCS
 310 may only be used in inline C code because they expand to a
 311 non-constant C expression.
 312
 313 \begin{code}
 314 instance Outputable CostCentreStack where
 315   ppr NoCCS             = ptext SLIT("NO_CCS")
 316   ppr CurrentCCS        = ptext SLIT("CCCS")
 317   ppr OverheadCCS       = ptext SLIT("CCS_OVERHEAD")
 318   ppr DontCareCCS       = ptext SLIT("CCS_DONT_CARE")
 319   ppr SubsumedCCS       = ptext SLIT("CCS_SUBSUMED")
 320   ppr (PushCC cc NoCCS) = ppr cc <> ptext SLIT("_ccs")
 321   ppr (PushCC cc ccs)   = ptext SLIT("PushCostCentre") <>
 322                            parens (ppr ccs <> comma <>
 323                            parens(ptext SLIT("void *")) <> ppr cc)
 324 \end{code}
 325
 326 -----------------------------------------------------------------------------
 327 Printing Cost Centres.
 328
 329 There are several different ways in which we might want to print a
 330 cost centre:
 331
 332         - the name of the cost centre, for profiling output (a C string)
 333         - the label, i.e. C label for cost centre in .hc file.
 334         - the debugging name, for output in -ddump things
 335         - the interface name, for printing in _scc_ exprs in iface files.
 336
 337 The last 3 are derived from costCentreStr below.  The first is given
 338 by costCentreName.
 339
 340 \begin{code}
 341 instance Outputable CostCentre where
 342   ppr cc = getPprStyle $ \ sty ->
 343            if codeStyle sty
 344            then ppCostCentreLbl cc
 345            else text (costCentreUserName cc)
 346
 347 -- Printing in an interface file or in Core generally
 348 pprCostCentreCore (AllCafsCC {cc_mod = m})
 349   = text "__sccC" <+> braces (ppr m)
 350 pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m,
 351                              cc_is_caf = caf, cc_is_dupd = dup})
 352   = text "__scc" <+> braces (hsep [
 353         ftext (zEncodeFS n),
 354         ppr m,
 355         pp_dup dup,
 356         pp_caf caf
 357     ])
 358
 359 pp_dup DupdCC = char '!'
 360 pp_dup other   = empty
 361
 362 pp_caf CafCC = text "__C"
 363 pp_caf other   = empty
 364
 365 -- Printing as a C label
 366 ppCostCentreLbl (NoCostCentre)            = text "NONE_cc"
 367 ppCostCentreLbl (AllCafsCC  {cc_mod = m}) = ppr m <> text "_CAFs_cc"
 368 ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf})
 369   = ppr m <> char '_' <> ftext (zEncodeFS n) <>
 370         text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc"
 371
 372 -- This is the name to go in the user-displayed string,
 373 -- recorded in the cost centre declaration
 374 costCentreUserName (NoCostCentre)  = "NO_CC"
 375 costCentreUserName (AllCafsCC {})  = "CAF"
 376 costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf})
 377   =  case is_caf of { CafCC -> "CAF:";   _ -> "" } ++ unpackFS name
 378 \end{code}