2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[CostCentre]{The @CostCentre@ data type}
7 #include "HsVersions.h"
10 CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..),
11 noCostCentre, subsumedCosts,
13 noCostCentreAttached, costsAreSubsumed,
14 currentOrSubsumedCosts,
15 preludeCafsCostCentre, preludeDictsCostCentre,
16 overheadCostCentre, dontCareCostCentre,
18 mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC,
19 cafifyCC, unCafifyCC, dupifyCC,
20 isCafCC, isDictCC, isDupdCC,
25 uppCostCentre, uppCostCentreDecl, showCostCentre, -- printing
27 cmpCostCentre, -- used for removing dups in a list
29 Id, Maybe, Unpretty(..), CSeq
32 import CmdLineOpts ( GlobalSwitch(..) )
33 import CLabelInfo ( identToC, stringToC )
34 import Id ( cmpId, showId, pprIdInUnfolding,
35 externallyVisibleId, Id
37 import Maybes ( Maybe(..) )
39 import Pretty ( ppShow, prettyToUn )
47 = NoCostCentre -- Having this constructor avoids having
48 -- to use "Maybe CostCentre" all the time.
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.
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.
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.
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.
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.
82 | OverheadCC -- We charge costs due to the profiling-system
83 -- doing its work to "overhead".
85 -- Objects whose cost-centre is "Overhead"
86 -- have their *allocation* charged to "overhead",
87 -- but have the current CC put into the object
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
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
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.
115 = UserCC FAST_STRING -- Supplied by user: String is the cc name
116 | AutoCC Id -- CC -auto-magically inserted for that Id
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
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.
140 SIMON: Maybe later...
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)
152 noCostCentreAttached NoCostCentre = True
153 noCostCentreAttached _ = False
155 costsAreSubsumed SubsumedCosts = True
156 costsAreSubsumed _ = False
158 currentOrSubsumedCosts SubsumedCosts = True
159 currentOrSubsumedCosts CurrentCC = True
160 currentOrSubsumedCosts _ = False
162 mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
164 mkUserCC cc_name module_name group_name
165 = NormalCC (UserCC cc_name) module_name group_name
166 AnOriginalCC IsNotCafCC{-might be changed-}
168 mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre
170 mkDictCC id module_name group_name is_caf
171 = NormalCC (DictCC id) module_name group_name
174 mkAutoCC id module_name group_name is_caf
175 = NormalCC (AutoCC id) module_name group_name
178 mkAllCafsCC m g = AllCafsCC m g
179 mkAllDictsCC m g is_dupd
180 = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC)
182 cafifyCC, unCafifyCC, dupifyCC :: CostCentre -> CostCentre
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
190 not_a_calf_already IsCafCC = False
191 not_a_calf_already _ = True
192 cafifyCC cc = panic ("cafifyCC"++(showCostCentre PprDebug False cc))
194 -- WDP 95/07: pretty dodgy
195 unCafifyCC (NormalCC kind m g is_dupd IsCafCC) = NormalCC kind m g is_dupd IsNotCafCC
196 unCafifyCC (AllCafsCC _ _) = CurrentCC
197 unCafifyCC PreludeCafsCC = CurrentCC
198 unCafifyCC (AllDictsCC _ _ _) = CurrentCC
199 unCafifyCC (PreludeDictsCC _) = CurrentCC
200 unCafifyCC other_cc = other_cc
202 dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC
203 dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC
204 dupifyCC (NormalCC kind m g is_dupd is_caf)
205 = NormalCC kind m g ADupdCC is_caf
206 dupifyCC cc = panic ("dupifyCC"++(showCostCentre PprDebug False cc))
208 isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
210 isCafCC (AllCafsCC _ _) = True
211 isCafCC PreludeCafsCC = True
212 isCafCC (NormalCC _ _ _ _ IsCafCC) = True
215 isDictCC (AllDictsCC _ _ _) = True
216 isDictCC (PreludeDictsCC _) = True
217 isDictCC (NormalCC (DictCC _) _ _ _ _) = True
220 isDupdCC (AllDictsCC _ _ ADupdCC) = True
221 isDupdCC (PreludeDictsCC ADupdCC) = True
222 isDupdCC (NormalCC _ _ _ ADupdCC _) = True
225 setToAbleCostCentre :: CostCentre -> Bool
226 -- Is this a cost-centre to which CCC might reasonably
227 -- be set? setToAbleCostCentre is allowed to panic on
228 -- "nonsense" cases, too...
231 setToAbleCostCentre NoCostCentre = panic "setToAbleCC:NoCostCentre"
232 setToAbleCostCentre SubsumedCosts = panic "setToAbleCC:SubsumedCosts"
233 setToAbleCostCentre CurrentCC = panic "setToAbleCC:CurrentCC"
234 setToAbleCostCentre DontCareCC = panic "setToAbleCC:DontCareCC"
237 setToAbleCostCentre OverheadCC = False -- see comments in type defn
238 setToAbleCostCentre other = not (isCafCC other || isDictCC other)
240 ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool
242 ccFromThisModule (NormalCC _ m _ _ _) mod_name = m == mod_name
243 ccFromThisModule (AllCafsCC m _) mod_name = m == mod_name
244 ccFromThisModule (AllDictsCC m _ _) mod_name = m == mod_name
245 ccFromThisModule PreludeCafsCC _ = False
246 ccFromThisModule (PreludeDictsCC _) _ = False
247 ccFromThisModule OverheadCC _ = False
248 ccFromThisModule DontCareCC _ = False
249 -- shouldn't ask about any others!
253 ccMentionsId :: CostCentre -> Maybe Id
255 ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id
256 ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id
257 ccMentionsId other = Nothing
261 cmpCostCentre :: CostCentre -> CostCentre -> TAG_
263 cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = _CMP_STRING_ m1 m2
264 cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = _CMP_STRING_ m1 m2
265 cmpCostCentre PreludeCafsCC PreludeCafsCC = EQ_
266 cmpCostCentre (PreludeDictsCC _) (PreludeDictsCC _) = EQ_
267 cmpCostCentre OverheadCC OverheadCC = EQ_
268 cmpCostCentre DontCareCC DontCareCC = EQ_
270 cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2)
271 -- first key is module name, then we use "kinds" (which include
273 = case (_CMP_STRING_ m1 m2) of
275 EQ_ -> cmp_kind k1 k2
278 cmpCostCentre other_1 other_2
280 tag1 = tag_CC other_1
281 tag2 = tag_CC other_2
283 if tag1 _LT_ tag2 then LT_ else GT_
285 tag_CC (NormalCC _ _ _ _ _) = (ILIT(1) :: FAST_INT)
286 tag_CC (AllCafsCC _ _) = ILIT(2)
287 tag_CC (AllDictsCC _ _ _) = ILIT(3)
288 tag_CC PreludeCafsCC = ILIT(4)
289 tag_CC (PreludeDictsCC _) = ILIT(5)
290 tag_CC OverheadCC = ILIT(6)
291 tag_CC DontCareCC = ILIT(7)
293 -- some BUG avoidance here...
294 tag_CC NoCostCentre = case (panic "tag_CC:NoCostCentre") of { c -> tag_CC c }
295 tag_CC SubsumedCosts = case (panic "tag_CC:SubsumedCosts") of { c -> tag_CC c }
296 tag_CC CurrentCC = case (panic "tag_CC:SubsumedCosts") of { c -> tag_CC c }
299 cmp_kind (UserCC n1) (UserCC n2) = _CMP_STRING_ n1 n2
300 cmp_kind (AutoCC i1) (AutoCC i2) = cmpId i1 i2
301 cmp_kind (DictCC i1) (DictCC i2) = cmpId i1 i2
302 cmp_kind other_1 other_2
304 tag1 = tag_CcKind other_1
305 tag2 = tag_CcKind other_2
307 if tag1 _LT_ tag2 then LT_ else GT_
309 tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT)
310 tag_CcKind (AutoCC _) = ILIT(2)
311 tag_CcKind (DictCC _) = ILIT(3)
315 showCostCentre :: PprStyle -> Bool -> CostCentre -> String
316 uppCostCentre :: PprStyle -> Bool -> CostCentre -> Unpretty
317 uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty
319 showCostCentre (PprUnfolding _) print_as_string cc
320 = ASSERT(not print_as_string) -- we never "print as string w/ Unfolding"
321 ASSERT(not (noCostCentreAttached cc))
322 ASSERT(not (currentOrSubsumedCosts cc))
323 uppShow 80 (upp_cc_uf cc)
325 showCostCentre sty print_as_string cc
326 = uppShow 80 (uppCostCentre sty print_as_string cc)
328 uppCostCentre sty print_as_string NoCostCentre
329 | friendly_style sty = uppNil
330 | print_as_string = uppStr "\"NO_CC\""
331 | otherwise = uppPStr SLIT("NO_CC")
333 uppCostCentre sty print_as_string SubsumedCosts
334 | print_as_string = uppStr "\"SUBSUMED\""
335 | otherwise = uppPStr SLIT("CC_SUBSUMED")
337 uppCostCentre sty print_as_string CurrentCC
338 | print_as_string = uppStr "\"CURRENT_CC\""
339 | otherwise = uppPStr SLIT("CCC")
341 uppCostCentre sty print_as_string OverheadCC
342 | print_as_string = uppStr "\"OVERHEAD\""
343 | otherwise = uppPStr SLIT("CC_OVERHEAD")
345 uppCostCentre sty print_as_string cc
347 prefix_CC = uppPStr SLIT("CC_")
349 basic_thing -- (basic_thing, suffix_CAF)
353 = if friendly_sty then basic_thing else stringToC basic_thing
355 if print_as_string then
356 uppBesides [uppChar '"', uppStr basic_thing_string, uppChar '"']
358 else if friendly_sty then
361 uppBesides [prefix_CC,
362 prettyToUn (identToC (_PK_ basic_thing))]
364 friendly_sty = friendly_style sty
366 add_module_name_maybe m str
367 = if print_as_string then str else (str ++ ('.' : m))
370 do_cc OverheadCC = "OVERHEAD"
371 do_cc DontCareCC = "DONT_CARE"
372 do_cc (AllCafsCC m _) = if print_as_string
374 else "CAFs." ++ _UNPK_ m
375 do_cc (AllDictsCC m _ d) = do_dupd d (
378 else "DICTs." ++ _UNPK_ m)
379 do_cc PreludeCafsCC = if print_as_string
382 do_cc (PreludeDictsCC d) = do_dupd d (
387 do_cc (NormalCC kind mod_name grp_name is_dupd is_caf)
389 basic_kind = do_kind kind
390 is_a_calf = do_calved is_caf
393 do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name) ++ is_a_calf)
397 do_kind (UserCC name) = _UNPK_ name
398 do_kind (AutoCC id) = do_id id ++ (if friendly_sty then "/AUTO" else "")
399 do_kind (DictCC id) = do_id id ++ (if friendly_sty then "/DICT" else "")
401 do_id :: Id -> String
404 then _UNPK_ (getOccurrenceName id) -- don't want module in the name
405 else showId sty id -- we really do
407 do_calved IsCafCC = "/CAF"
411 do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str
414 friendly_style sty -- i.e., probably for human consumption
422 Printing unfoldings is sufficiently weird that we do it separately.
423 This should only apply to CostCentres that can be ``set to'' (cf
424 @setToAbleCostCentre@). That excludes CAFs and
425 `overhead'---which are added at the very end---but includes dictionaries.
426 Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info;
427 even if we won't ultimately do a \tr{SET_CCC} from it.
429 upp_cc_uf (PreludeDictsCC d)
430 = uppCat [uppPStr SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d]
431 upp_cc_uf (AllDictsCC m g d)
432 = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), upp_dupd d]
434 upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf)
435 = ASSERT(isDictCC cc || setToAbleCostCentre cc)
436 uppCat [pp_kind cc_kind, uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)),
437 upp_dupd is_dupd, pp_caf is_caf]
439 pp_kind (UserCC name) = uppBeside (uppPStr SLIT("_USER_CC_ ")) (uppStr (show (_UNPK_ name)))
440 pp_kind (AutoCC id) = uppBeside (uppPStr SLIT("_AUTO_CC_ ")) (show_id id)
441 pp_kind (DictCC id) = uppBeside (uppPStr SLIT("_DICT_CC_ ")) (show_id id)
443 show_id id = prettyToUn (pprIdInUnfolding no_in_scopes id)
445 no_in_scopes = emptyUniqSet
447 pp_caf IsCafCC = uppPStr SLIT("_CAF_CC_")
448 pp_caf IsNotCafCC = uppPStr SLIT("_N_")
451 upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other))
454 upp_dupd AnOriginalCC = uppPStr SLIT("_N_")
455 upp_dupd ADupdCC = uppPStr SLIT("_DUPD_CC_")
459 uppCostCentreDecl sty is_local cc
461 | noCostCentreAttached cc || currentOrSubsumedCosts cc
462 = panic "uppCostCentreDecl: no cost centre!"
467 uppStr "CC_DECLARE(",
469 uppCostCentre sty True {-as String!-} cc, uppComma,
470 pp_str mod_name, uppComma,
471 pp_str grp_name, uppComma,
472 uppStr is_subsumed, uppComma,
473 if externally_visible then uppNil else uppPStr SLIT("static"),
476 uppBesides [ uppStr "CC_EXTERN(", upp_ident, uppStr ");" ]
478 upp_ident = uppCostCentre sty False{-as identifier!-} cc
480 pp_str s = uppBeside (uppPStr (_CONS_ '"' s)) (uppChar '"')
481 pp_char c = uppBeside (uppPStr (_CONS_ '\'' c)) (uppChar '\'')
483 (mod_name, grp_name, is_subsumed, externally_visible)
485 AllCafsCC m g -> (m, g, cc_IS_CAF, True)
487 AllDictsCC m g _ -> (m, g, cc_IS_DICT, True)
489 NormalCC (DictCC i) m g is_dupd is_caf
490 -> (m, g, cc_IS_DICT, externallyVisibleId i)
492 NormalCC x m g is_dupd is_caf
493 -> (m, g, do_caf is_caf,
494 case x of { UserCC _ -> True; AutoCC i -> externallyVisibleId i})
496 cc_IS_CAF = "CC_IS_CAF"
497 cc_IS_DICT = "CC_IS_DICT"
498 cc_IS_SUBSUMED = "CC_IS_SUBSUMED"
499 cc_IS_BORING = "CC_IS_BORING"
501 do_caf IsCafCC = cc_IS_CAF
502 do_caf IsNotCafCC = cc_IS_BORING