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