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