ghc/compiler/profiling/CostCentre.lhs

   1 %
   2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
   3 %
   4 \section[CostCentre]{The @CostCentre@ data type}
   5
   6 \begin{code}
   7 #include "HsVersions.h"
   8
   9 module CostCentre (
  10         CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..),
  11         noCostCentre, subsumedCosts,
  12         useCurrentCostCentre,
  13         noCostCentreAttached, costsAreSubsumed,
  14         currentOrSubsumedCosts,
  15         preludeCafsCostCentre, preludeDictsCostCentre,
  16         overheadCostCentre, dontCareCostCentre,
  17
  18         mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC,
  19         cafifyCC, dupifyCC,
  20         isCafCC, isDictCC, isDupdCC,
  21         isSccCountCostCentre,
  22         sccAbleCostCentre,
  23         ccFromThisModule,
  24         ccMentionsId,
  25
  26         uppCostCentre, uppCostCentreDecl, showCostCentre, -- printing
  27
  28         cmpCostCentre   -- used for removing dups in a list
  29     ) where
  30
  31 IMP_Ubiq(){-uitous-}
  32
  33 import Id               ( externallyVisibleId, GenId, showId, SYN_IE(Id) )
  34 import CStrings         ( identToC, stringToC )
  35 import Name             ( OccName, getOccString, moduleString )
  36 import Pretty           ( ppShow, prettyToUn )
  37 import PprStyle         ( PprStyle(..) )
  38 import UniqSet
  39 import Unpretty
  40 import Util
  41
  42 pprIdInUnfolding = panic "Whoops"
  43 \end{code}
  44
  45 \begin{code}
  46 data CostCentre
  47   = NoCostCentre        -- Having this constructor avoids having
  48                         -- to use "Maybe CostCentre" all the time.
  49
  50   | NormalCC    CcKind   -- CcKind will include a cost-centre name
  51                 FAST_STRING      -- Name of module defining this CC.
  52                 FAST_STRING   -- "Group" that this CC is in.
  53                 IsDupdCC -- see below
  54                 IsCafCC  -- see below
  55
  56   | CurrentCC           -- Pinned on a let(rec)-bound thunk/function/constructor,
  57                         -- this says that the cost centre to be attached to
  58                         -- the object, when it is allocated, is whatever is in the
  59                         -- current-cost-centre register.
  60                         -- This guy is *never* the cost centre for an SCC construct,
  61                         -- and is only used for *local* (non-top-level) definitions.
  62
  63   | SubsumedCosts       -- Cost centre for top-level subsumed functions
  64                         -- (CAFs get an AllCafsCC).
  65                         -- Its execution costs get subsumed into the caller.
  66                         -- This guy is *only* ever pinned on static closures,
  67                         -- and is *never* the cost centre for an SCC construct.
  68
  69   | AllCafsCC   FAST_STRING     -- Ditto for CAFs.
  70                 FAST_STRING  -- We record module and group names.
  71                         -- Again, one "big" CAF cc per module, where all
  72                         -- CAF costs are attributed unless the user asked for
  73                         -- per-individual-CAF cost attribution.
  74
  75   | AllDictsCC  FAST_STRING     -- Ditto for dictionaries.
  76                 FAST_STRING  -- We record module and group names.
  77                         -- Again, one "big" DICT cc per module, where all
  78                         -- DICT costs are attributed unless the user asked for
  79                         -- per-individual-DICT cost attribution.
  80                 IsDupdCC -- see below
  81
  82   | OverheadCC          -- We charge costs due to the profiling-system
  83                         -- doing its work to "overhead".
  84                         --
  85                         -- Objects whose cost-centre is "Overhead"
  86                         -- have their *allocation* charged to "overhead",
  87                         -- but have the current CC put into the object
  88                         -- itself.
  89                         --
  90                         -- For example, if we transform "f g" to "let
  91                         -- g' = g in f g'" (so that something about
  92                         -- profiling works better...), then we charge
  93                         -- the *allocation* of g' to OverheadCC, but
  94                         -- we put the cost-centre of the call to f
  95                         -- (i.e., current CC) into the g' object.  When
  96                         -- g' is entered, the cost-centre of the call
  97                         -- to f will be set.
  98
  99   | PreludeCafsCC       -- In compiling the prelude, we do sometimes
 100   | PreludeDictsCC      -- need a CC to blame; i.e., when there's a CAF,
 101                         -- or other costs that really shouldn't be
 102                         -- subsumed/blamed-on-the-caller.  These costs
 103                         -- should be *small*.  We treat PreludeCafsCC
 104                         -- as if it were shorthand for
 105                         -- (AllCafsCC <PreludeSomething> _).  Analogously
 106                         -- for PreludeDictsCC...
 107         IsDupdCC        -- see below/above
 108
 109   | DontCareCC          -- We need a cost-centre to stick in static closures
 110                         -- (for data), but we *don't* expect them to
 111                         -- accumulate any costs.  But we still need
 112                         -- the placeholder.  This CC is it.
 113
 114 data CcKind
 115   = UserCC  FAST_STRING -- Supplied by user: String is the cc name
 116   | AutoCC  Id          -- CC -auto-magically inserted for that Id
 117   | DictCC  Id
 118
 119 data IsDupdCC
 120   = AnOriginalCC        -- This says how the CC is *used*.  Saying that
 121   | ADupdCC             -- it is ADupdCC doesn't make it a different
 122                         -- CC, just that it a sub-expression which has
 123                         -- been moved ("dupd") into a different scope.
 124                         -- In the papers, it's called "SCCsub",
 125                         --  i.e. SCCsub CC == SCC ADupdCC,
 126                         -- but we are trying to avoid confusion between
 127                         -- "subd" and "subsumed".  So we call the former
 128                         -- "dupd".
 129
 130 data IsCafCC
 131   = IsCafCC
 132   | IsNotCafCC
 133 \end{code}
 134
 135 WILL: Would there be any merit to recording ``I am now using a
 136 cost-centre from another module''?  I don't know if this would help a
 137 user; it might be interesting to us to know how much computation is
 138 being moved across module boundaries.
 139
 140 SIMON: Maybe later...
 141
 142 \begin{code}
 143 noCostCentre  = NoCostCentre
 144 subsumedCosts = SubsumedCosts
 145 useCurrentCostCentre = CurrentCC
 146 overheadCostCentre = OverheadCC
 147 preludeCafsCostCentre = PreludeCafsCC
 148 dontCareCostCentre = DontCareCC
 149 preludeDictsCostCentre is_dupd
 150   = PreludeDictsCC (if is_dupd then ADupdCC else AnOriginalCC)
 151
 152 noCostCentreAttached NoCostCentre  = True
 153 noCostCentreAttached _             = False
 154
 155 costsAreSubsumed SubsumedCosts  = True
 156 costsAreSubsumed _              = False
 157
 158 currentOrSubsumedCosts SubsumedCosts    = True
 159 currentOrSubsumedCosts CurrentCC        = True
 160 currentOrSubsumedCosts _                = False
 161
 162 mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
 163
 164 mkUserCC cc_name module_name group_name
 165   = NormalCC (UserCC cc_name) module_name group_name
 166              AnOriginalCC IsNotCafCC{-might be changed-}
 167
 168 mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre
 169
 170 mkDictCC id module_name group_name is_caf
 171   = NormalCC (DictCC id) module_name group_name
 172              AnOriginalCC is_caf
 173
 174 mkAutoCC id module_name group_name is_caf
 175   = NormalCC (AutoCC id) module_name group_name
 176              AnOriginalCC is_caf
 177
 178 mkAllCafsCC  m g   = AllCafsCC  m g
 179 mkAllDictsCC m g is_dupd
 180   = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC)
 181
 182 cafifyCC, dupifyCC  :: CostCentre -> CostCentre
 183
 184 cafifyCC cc@(AllDictsCC _ _ _) = cc -- ToDo ???
 185 cafifyCC cc@(PreludeDictsCC _) = cc --    ditto
 186 cafifyCC (NormalCC kind m g is_dupd is_caf)
 187   = ASSERT(not_a_calf_already is_caf)
 188     NormalCC kind m g is_dupd IsCafCC
 189   where
 190     not_a_calf_already IsCafCC = False
 191     not_a_calf_already _       = True
 192 cafifyCC cc = panic ("cafifyCC"++(showCostCentre PprDebug False cc))
 193
 194 dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC
 195 dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC
 196 dupifyCC (NormalCC kind m g is_dupd is_caf)
 197   = NormalCC kind m g ADupdCC is_caf
 198 dupifyCC cc = panic ("dupifyCC"++(showCostCentre PprDebug False cc))
 199
 200 isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
 201
 202 isCafCC (AllCafsCC _ _)            = True
 203 isCafCC PreludeCafsCC              = True
 204 isCafCC (NormalCC _ _ _ _ IsCafCC) = True
 205 isCafCC _                          = False
 206
 207 isDictCC (AllDictsCC _ _ _)             = True
 208 isDictCC (PreludeDictsCC _)             = True
 209 isDictCC (NormalCC (DictCC _) _ _ _ _)  = True
 210 isDictCC _                              = False
 211
 212 isDupdCC (AllDictsCC _ _ ADupdCC)   = True
 213 isDupdCC (PreludeDictsCC ADupdCC)   = True
 214 isDupdCC (NormalCC _ _ _ ADupdCC _) = True
 215 isDupdCC _                          = False
 216
 217 isSccCountCostCentre :: CostCentre -> Bool
 218   -- Is this a cost-centre which records scc counts
 219
 220 #if DEBUG
 221 isSccCountCostCentre NoCostCentre  = panic "isSccCount:NoCostCentre"
 222 isSccCountCostCentre SubsumedCosts = panic "isSccCount:SubsumedCosts"
 223 isSccCountCostCentre CurrentCC     = panic "isSccCount:CurrentCC"
 224 isSccCountCostCentre DontCareCC    = panic "isSccCount:DontCareCC"
 225 #endif
 226 isSccCountCostCentre OverheadCC       = False
 227 isSccCountCostCentre cc | isCafCC cc  = False
 228                         | isDupdCC cc = False
 229                         | isDictCC cc = True
 230                         | otherwise   = True
 231
 232 sccAbleCostCentre :: CostCentre -> Bool
 233   -- Is this a cost-centre which can be sccd ?
 234
 235 #if DEBUG
 236 sccAbleCostCentre NoCostCentre  = panic "sccAbleCC:NoCostCentre"
 237 sccAbleCostCentre SubsumedCosts = panic "sccAbleCC:SubsumedCosts"
 238 sccAbleCostCentre CurrentCC     = panic "sccAbleCC:CurrentCC"
 239 sccAbleCostCentre DontCareCC    = panic "sccAbleCC:DontCareCC"
 240 #endif
 241 sccAbleCostCentre OverheadCC      = False
 242 sccAbleCostCentre cc | isCafCC cc = False
 243                      | otherwise  = True
 244
 245 ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool
 246
 247 ccFromThisModule (NormalCC _ m _ _ _) mod_name = m == mod_name
 248 ccFromThisModule (AllCafsCC  m _)     mod_name = m == mod_name
 249 ccFromThisModule (AllDictsCC m _ _)   mod_name = m == mod_name
 250 ccFromThisModule PreludeCafsCC        _        = False
 251 ccFromThisModule (PreludeDictsCC _)   _        = False
 252 ccFromThisModule OverheadCC           _        = False
 253 ccFromThisModule DontCareCC           _        = False
 254   -- shouldn't ask about any others!
 255 \end{code}
 256
 257 \begin{code}
 258 ccMentionsId :: CostCentre -> Maybe Id
 259
 260 ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id
 261 ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id
 262 ccMentionsId other                          = Nothing
 263 \end{code}
 264
 265 \begin{code}
 266 cmpCostCentre :: CostCentre -> CostCentre -> TAG_
 267
 268 cmpCostCentre (AllCafsCC  m1 _)   (AllCafsCC  m2 _)   = _CMP_STRING_ m1 m2
 269 cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = _CMP_STRING_ m1 m2
 270 cmpCostCentre PreludeCafsCC       PreludeCafsCC       = EQ_
 271 cmpCostCentre (PreludeDictsCC _)  (PreludeDictsCC _)  = EQ_
 272 cmpCostCentre OverheadCC          OverheadCC          = EQ_
 273 cmpCostCentre DontCareCC          DontCareCC          = EQ_
 274
 275 cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2)
 276     -- first key is module name, then we use "kinds" (which include
 277     -- names) and finally the caf flag
 278   = _CMP_STRING_ m1 m2 `thenCmp` cmp_kind k1 k2 `thenCmp` cmp_caf c1 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     tag_CC (AllDictsCC _ _ _)   = ILIT(3)
 290     tag_CC PreludeCafsCC        = ILIT(4)
 291     tag_CC (PreludeDictsCC _)   = ILIT(5)
 292     tag_CC OverheadCC           = ILIT(6)
 293     tag_CC DontCareCC           = ILIT(7)
 294
 295     -- some BUG avoidance here...
 296     tag_CC NoCostCentre  = panic# "tag_CC:NoCostCentre"
 297     tag_CC SubsumedCosts = panic# "tag_CC:SubsumedCosts"
 298     tag_CC CurrentCC     = panic# "tag_CC:SubsumedCosts"
 299
 300
 301 cmp_kind (UserCC n1) (UserCC n2) = _CMP_STRING_ n1 n2
 302 cmp_kind (AutoCC i1) (AutoCC i2) = cmp i1 i2
 303 cmp_kind (DictCC i1) (DictCC i2) = cmp i1 i2
 304 cmp_kind other_1     other_2
 305   = let
 306         tag1 = tag_CcKind other_1
 307         tag2 = tag_CcKind other_2
 308     in
 309     if tag1 _LT_ tag2 then LT_ else GT_
 310   where
 311     tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT)
 312     tag_CcKind (AutoCC _) = ILIT(2)
 313     tag_CcKind (DictCC _) = ILIT(3)
 314
 315 cmp_caf IsNotCafCC IsCafCC     = LT_
 316 cmp_caf IsNotCafCC IsNotCafCC  = EQ_
 317 cmp_caf IsCafCC    IsCafCC     = EQ_
 318 cmp_caf IsCafCC    IsNotCafCC  = GT_
 319 \end{code}
 320
 321 \begin{code}
 322 showCostCentre    :: PprStyle -> Bool -> CostCentre -> String
 323 uppCostCentre     :: PprStyle -> Bool -> CostCentre -> Unpretty
 324 uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty
 325
 326 showCostCentre PprUnfolding print_as_string cc
 327   = ASSERT(not print_as_string) -- we never "print as string w/ Unfolding"
 328     ASSERT(not (noCostCentreAttached cc))
 329     ASSERT(not (currentOrSubsumedCosts cc))
 330     uppShow 80 (upp_cc_uf cc)
 331
 332 showCostCentre sty print_as_string cc
 333   = uppShow 80 (uppCostCentre sty print_as_string cc)
 334
 335 uppCostCentre sty print_as_string NoCostCentre
 336   | friendly_style sty  = uppNil
 337   | print_as_string     = uppStr "\"NO_CC\""
 338   | otherwise           = uppPStr SLIT("NO_CC")
 339
 340 uppCostCentre sty print_as_string SubsumedCosts
 341   | print_as_string     = uppStr "\"SUBSUMED\""
 342   | otherwise           = uppPStr SLIT("CC_SUBSUMED")
 343
 344 uppCostCentre sty print_as_string CurrentCC
 345   | print_as_string     = uppStr "\"CURRENT_CC\""
 346   | otherwise           = uppPStr SLIT("CCC")
 347
 348 uppCostCentre sty print_as_string OverheadCC
 349   | print_as_string     = uppStr "\"OVERHEAD\""
 350   | otherwise           = uppPStr SLIT("CC_OVERHEAD")
 351
 352 uppCostCentre sty print_as_string cc
 353   = let
 354         prefix_CC = uppPStr SLIT("CC_")
 355
 356         basic_thing = do_cc cc
 357
 358         basic_thing_string
 359           = if friendly_sty then basic_thing else stringToC basic_thing
 360     in
 361     if print_as_string then
 362         uppBesides [uppChar '"', uppStr basic_thing_string, uppChar '"']
 363
 364     else if friendly_sty then
 365         uppStr basic_thing
 366     else
 367         uppBesides [prefix_CC,
 368                     prettyToUn (identToC (_PK_ basic_thing))]
 369   where
 370     friendly_sty = friendly_style sty
 371
 372     ----------------
 373     do_cc DontCareCC         = "DONT_CARE"
 374     do_cc (AllCafsCC  m _)   = if print_as_string
 375                                then "CAFs_in_..."
 376                                else "CAFs." ++ _UNPK_ m
 377     do_cc (AllDictsCC m _ d) = do_dupd d (
 378                                if print_as_string
 379                                then "DICTs_in_..."
 380                                else "DICTs." ++ _UNPK_ m)
 381     do_cc PreludeCafsCC      = if print_as_string
 382                                then "CAFs_in_..."
 383                                else "CAFs"
 384     do_cc (PreludeDictsCC d) = do_dupd d (
 385                                if print_as_string
 386                                then "DICTs_in_..."
 387                                else "DICTs")
 388
 389     do_cc (NormalCC kind mod_name grp_name is_dupd is_caf)
 390       = let
 391             basic_kind = do_caf is_caf ++ do_kind kind
 392         in
 393         if friendly_sty then
 394             do_dupd is_dupd (basic_kind ++ ('/': moduleString mod_name) ++ ('/': _UNPK_ grp_name))
 395         else
 396             basic_kind
 397       where
 398         do_caf IsCafCC = "CAF:"
 399         do_caf _       = ""
 400
 401         do_kind (UserCC name) = _UNPK_ name
 402         do_kind (AutoCC id)   = do_id id ++ (if friendly_sty then "/AUTO" else "")
 403         do_kind (DictCC id)   = do_id id ++ (if friendly_sty then "/DICT" else "")
 404
 405         do_id :: Id -> String
 406         do_id id
 407           = if print_as_string
 408             then  getOccString id               -- use occ name
 409             else showId sty id                  -- we really do
 410
 411     ---------------
 412     do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str
 413     do_dupd _       str = str
 414
 415 friendly_style sty -- i.e., probably for human consumption
 416   = case sty of
 417       PprForUser -> True
 418       PprDebug   -> True
 419       PprShowAll -> True
 420       _          -> False
 421 \end{code}
 422
 423 Printing unfoldings is sufficiently weird that we do it separately.
 424 This should only apply to CostCentres that can be ``set to'' (cf
 425 @sccAbleCostCentre@).  That excludes CAFs and
 426 `overhead'---which are added at the very end---but includes dictionaries.
 427 Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info;
 428 even if we won't ultimately do a \tr{SET_CCC} from it.
 429 \begin{code}
 430 upp_cc_uf (PreludeDictsCC d)
 431   = uppCat [uppPStr SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d]
 432 upp_cc_uf (AllDictsCC m g d)
 433   = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"),
 434             uppChar '"',uppPStr m,uppChar '"',
 435             uppChar '"',uppPStr g,uppChar '"',
 436             upp_dupd d]
 437
 438 upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf)
 439   = ASSERT(sccAbleCostCentre cc)
 440     uppCat [pp_kind cc_kind,
 441             uppChar '"', uppPStr m, uppChar '"',
 442             uppChar '"', uppPStr g, uppChar '"',
 443             upp_dupd is_dupd, pp_caf is_caf]
 444   where
 445     pp_kind (UserCC name) = uppBesides [uppPStr SLIT("_USER_CC_ "), uppChar '"', uppPStr name, uppChar '"']
 446     pp_kind (AutoCC id)   = uppBeside (uppPStr SLIT("_AUTO_CC_ ")) (show_id id)
 447     pp_kind (DictCC id)   = uppBeside (uppPStr SLIT("_DICT_CC_ ")) (show_id id)
 448
 449     show_id id = prettyToUn (pprIdInUnfolding no_in_scopes id)
 450         where
 451           no_in_scopes = emptyUniqSet
 452
 453     pp_caf IsCafCC    = uppPStr SLIT("_CAF_CC_")
 454     pp_caf IsNotCafCC = uppPStr SLIT("_N_")
 455
 456 #ifdef DEBUG
 457 upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other))
 458 #endif
 459
 460 upp_dupd AnOriginalCC = uppPStr SLIT("_N_")
 461 upp_dupd ADupdCC      = uppPStr SLIT("_D_")
 462 \end{code}
 463
 464 \begin{code}
 465 uppCostCentreDecl sty is_local cc
 466 #ifdef DEBUG
 467   | noCostCentreAttached cc || currentOrSubsumedCosts cc
 468   = panic "uppCostCentreDecl: no cost centre!"
 469   | otherwise
 470 #endif
 471   = if is_local then
 472         uppBesides [
 473             uppPStr SLIT("CC_DECLARE"),uppChar '(',
 474             upp_ident, uppComma,
 475             uppCostCentre sty True {-as String!-} cc, uppComma,
 476             pp_str mod_name, uppComma,
 477             pp_str grp_name, uppComma,
 478             uppStr is_subsumed, uppComma,
 479             if externally_visible then uppNil else uppPStr SLIT("static"),
 480             uppStr ");"]
 481     else
 482         uppBesides [ uppPStr SLIT("CC_EXTERN"),uppChar '(', upp_ident, uppStr ");" ]
 483   where
 484     upp_ident = uppCostCentre sty False{-as identifier!-} cc
 485
 486     pp_str s  = uppBesides [uppChar '"',uppPStr s, uppChar '"' ]
 487     pp_char c = uppBesides [uppChar '\'', uppPStr c, uppChar '\'']
 488
 489     (mod_name, grp_name, is_subsumed, externally_visible)
 490       = case cc of
 491           AllCafsCC m g -> (m, g, cc_IS_CAF, True)
 492
 493           AllDictsCC m g _ -> (m, g, cc_IS_DICT, True)
 494
 495           NormalCC (DictCC i) m g is_dupd is_caf
 496             -> (m, g, cc_IS_DICT, externallyVisibleId i)
 497
 498           NormalCC x m g is_dupd is_caf
 499             -> (m, g, do_caf is_caf,
 500                 case x of { UserCC _ -> True; AutoCC i -> externallyVisibleId i})
 501       where
 502         cc_IS_CAF      = "CC_IS_CAF"
 503         cc_IS_DICT     = "CC_IS_DICT"
 504         cc_IS_SUBSUMED = "CC_IS_SUBSUMED"
 505         cc_IS_BORING   = "CC_IS_BORING"
 506
 507         do_caf IsCafCC       = cc_IS_CAF
 508         do_caf IsNotCafCC    = cc_IS_BORING
 509 \end{code}