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