2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
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,
20 isCafCC, isDictCC, isDupdCC,
26 uppCostCentre, uppCostCentreDecl, showCostCentre, -- printing
28 cmpCostCentre -- used for removing dups in a list
33 import Id ( externallyVisibleId, GenId, SYN_IE(Id) )
34 import CStrings ( identToC, stringToC )
35 import Name ( OccName, getOccString, moduleString )
36 import Pretty ( ppShow, prettyToUn )
37 import PprStyle ( PprStyle(..) )
42 showId = panic "Whoops"
43 pprIdInUnfolding = panic "Whoops"
48 = NoCostCentre -- Having this constructor avoids having
49 -- to use "Maybe CostCentre" all the time.
51 | NormalCC CcKind -- CcKind will include a cost-centre name
52 FAST_STRING -- Name of module defining this CC.
53 FAST_STRING -- "Group" that this CC is in.
57 | CurrentCC -- Pinned on a let(rec)-bound thunk/function/constructor,
58 -- this says that the cost centre to be attached to
59 -- the object, when it is allocated, is whatever is in the
60 -- current-cost-centre register.
61 -- This guy is *never* the cost centre for an SCC construct,
62 -- and is only used for *local* (non-top-level) definitions.
64 | SubsumedCosts -- Cost centre for top-level subsumed functions
65 -- (CAFs get an AllCafsCC).
66 -- Its execution costs get subsumed into the caller.
67 -- This guy is *only* ever pinned on static closures,
68 -- and is *never* the cost centre for an SCC construct.
70 | AllCafsCC FAST_STRING -- Ditto for CAFs.
71 FAST_STRING -- We record module and group names.
72 -- Again, one "big" CAF cc per module, where all
73 -- CAF costs are attributed unless the user asked for
74 -- per-individual-CAF cost attribution.
76 | AllDictsCC FAST_STRING -- Ditto for dictionaries.
77 FAST_STRING -- We record module and group names.
78 -- Again, one "big" DICT cc per module, where all
79 -- DICT costs are attributed unless the user asked for
80 -- per-individual-DICT cost attribution.
83 | OverheadCC -- We charge costs due to the profiling-system
84 -- doing its work to "overhead".
86 -- Objects whose cost-centre is "Overhead"
87 -- have their *allocation* charged to "overhead",
88 -- but have the current CC put into the object
91 -- For example, if we transform "f g" to "let
92 -- g' = g in f g'" (so that something about
93 -- profiling works better...), then we charge
94 -- the *allocation* of g' to OverheadCC, but
95 -- we put the cost-centre of the call to f
96 -- (i.e., current CC) into the g' object. When
97 -- g' is entered, the cost-centre of the call
100 | PreludeCafsCC -- In compiling the prelude, we do sometimes
101 | PreludeDictsCC -- need a CC to blame; i.e., when there's a CAF,
102 -- or other costs that really shouldn't be
103 -- subsumed/blamed-on-the-caller. These costs
104 -- should be *small*. We treat PreludeCafsCC
105 -- as if it were shorthand for
106 -- (AllCafsCC <PreludeSomething> _). Analogously
107 -- for PreludeDictsCC...
108 IsDupdCC -- see below/above
110 | DontCareCC -- We need a cost-centre to stick in static closures
111 -- (for data), but we *don't* expect them to
112 -- accumulate any costs. But we still need
113 -- the placeholder. This CC is it.
116 = UserCC FAST_STRING -- Supplied by user: String is the cc name
117 | AutoCC Id -- CC -auto-magically inserted for that Id
121 = AnOriginalCC -- This says how the CC is *used*. Saying that
122 | ADupdCC -- it is ADupdCC doesn't make it a different
123 -- CC, just that it a sub-expression which has
124 -- been moved ("dupd") into a different scope.
125 -- In the papers, it's called "SCCsub",
126 -- i.e. SCCsub CC == SCC ADupdCC,
127 -- but we are trying to avoid confusion between
128 -- "subd" and "subsumed". So we call the former
136 WILL: Would there be any merit to recording ``I am now using a
137 cost-centre from another module''? I don't know if this would help a
138 user; it might be interesting to us to know how much computation is
139 being moved across module boundaries.
141 SIMON: Maybe later...
144 noCostCentre = NoCostCentre
145 subsumedCosts = SubsumedCosts
146 useCurrentCostCentre = CurrentCC
147 overheadCostCentre = OverheadCC
148 preludeCafsCostCentre = PreludeCafsCC
149 dontCareCostCentre = DontCareCC
150 preludeDictsCostCentre is_dupd
151 = PreludeDictsCC (if is_dupd then ADupdCC else AnOriginalCC)
153 noCostCentreAttached NoCostCentre = True
154 noCostCentreAttached _ = False
156 costsAreSubsumed SubsumedCosts = True
157 costsAreSubsumed _ = False
159 currentOrSubsumedCosts SubsumedCosts = True
160 currentOrSubsumedCosts CurrentCC = True
161 currentOrSubsumedCosts _ = False
163 mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
165 mkUserCC cc_name module_name group_name
166 = NormalCC (UserCC cc_name) module_name group_name
167 AnOriginalCC IsNotCafCC{-might be changed-}
169 mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre
171 mkDictCC id module_name group_name is_caf
172 = NormalCC (DictCC id) module_name group_name
175 mkAutoCC id module_name group_name is_caf
176 = NormalCC (AutoCC id) module_name group_name
179 mkAllCafsCC m g = AllCafsCC m g
180 mkAllDictsCC m g is_dupd
181 = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC)
183 cafifyCC, dupifyCC :: CostCentre -> CostCentre
185 cafifyCC cc@(AllDictsCC _ _ _) = cc -- ToDo ???
186 cafifyCC cc@(PreludeDictsCC _) = cc -- ditto
187 cafifyCC (NormalCC kind m g is_dupd is_caf)
188 = ASSERT(not_a_calf_already is_caf)
189 NormalCC kind m g is_dupd IsCafCC
191 not_a_calf_already IsCafCC = False
192 not_a_calf_already _ = True
193 cafifyCC cc = panic ("cafifyCC"++(showCostCentre PprDebug False cc))
195 dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC
196 dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC
197 dupifyCC (NormalCC kind m g is_dupd is_caf)
198 = NormalCC kind m g ADupdCC is_caf
199 dupifyCC cc = panic ("dupifyCC"++(showCostCentre PprDebug False cc))
201 isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
203 isCafCC (AllCafsCC _ _) = True
204 isCafCC PreludeCafsCC = True
205 isCafCC (NormalCC _ _ _ _ IsCafCC) = True
208 isDictCC (AllDictsCC _ _ _) = True
209 isDictCC (PreludeDictsCC _) = True
210 isDictCC (NormalCC (DictCC _) _ _ _ _) = True
213 isDupdCC (AllDictsCC _ _ ADupdCC) = True
214 isDupdCC (PreludeDictsCC ADupdCC) = True
215 isDupdCC (NormalCC _ _ _ ADupdCC _) = True
218 isSccCountCostCentre :: CostCentre -> Bool
219 -- Is this a cost-centre which records scc counts
222 isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre"
223 isSccCountCostCentre SubsumedCosts = panic "isSccCount:SubsumedCosts"
224 isSccCountCostCentre CurrentCC = panic "isSccCount:CurrentCC"
225 isSccCountCostCentre DontCareCC = panic "isSccCount:DontCareCC"
227 isSccCountCostCentre OverheadCC = False
228 isSccCountCostCentre cc | isCafCC cc = False
229 | isDupdCC cc = False
233 sccAbleCostCentre :: CostCentre -> Bool
234 -- Is this a cost-centre which can be sccd ?
237 sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre"
238 sccAbleCostCentre SubsumedCosts = panic "sccAbleCC:SubsumedCosts"
239 sccAbleCostCentre CurrentCC = panic "sccAbleCC:CurrentCC"
240 sccAbleCostCentre DontCareCC = panic "sccAbleCC:DontCareCC"
242 sccAbleCostCentre OverheadCC = False
243 sccAbleCostCentre cc | isCafCC cc = False
246 ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool
248 ccFromThisModule (NormalCC _ m _ _ _) mod_name = m == mod_name
249 ccFromThisModule (AllCafsCC m _) mod_name = m == mod_name
250 ccFromThisModule (AllDictsCC m _ _) mod_name = m == mod_name
251 ccFromThisModule PreludeCafsCC _ = False
252 ccFromThisModule (PreludeDictsCC _) _ = False
253 ccFromThisModule OverheadCC _ = False
254 ccFromThisModule DontCareCC _ = False
255 -- shouldn't ask about any others!
259 ccMentionsId :: CostCentre -> Maybe Id
261 ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id
262 ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id
263 ccMentionsId other = Nothing
267 cmpCostCentre :: CostCentre -> CostCentre -> TAG_
269 cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = _CMP_STRING_ m1 m2
270 cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = _CMP_STRING_ m1 m2
271 cmpCostCentre PreludeCafsCC PreludeCafsCC = EQ_
272 cmpCostCentre (PreludeDictsCC _) (PreludeDictsCC _) = EQ_
273 cmpCostCentre OverheadCC OverheadCC = EQ_
274 cmpCostCentre DontCareCC DontCareCC = EQ_
276 cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2)
277 -- first key is module name, then we use "kinds" (which include
278 -- names) and finally the caf flag
279 = _CMP_STRING_ m1 m2 `thenCmp` cmp_kind k1 k2 `thenCmp` cmp_caf c1 c2
281 cmpCostCentre other_1 other_2
283 tag1 = tag_CC other_1
284 tag2 = tag_CC other_2
286 if tag1 _LT_ tag2 then LT_ else GT_
288 tag_CC (NormalCC _ _ _ _ _) = (ILIT(1) :: FAST_INT)
289 tag_CC (AllCafsCC _ _) = ILIT(2)
290 tag_CC (AllDictsCC _ _ _) = ILIT(3)
291 tag_CC PreludeCafsCC = ILIT(4)
292 tag_CC (PreludeDictsCC _) = ILIT(5)
293 tag_CC OverheadCC = ILIT(6)
294 tag_CC DontCareCC = ILIT(7)
296 -- some BUG avoidance here...
297 tag_CC NoCostCentre = panic# "tag_CC:NoCostCentre"
298 tag_CC SubsumedCosts = panic# "tag_CC:SubsumedCosts"
299 tag_CC CurrentCC = panic# "tag_CC:SubsumedCosts"
302 cmp_kind (UserCC n1) (UserCC n2) = _CMP_STRING_ n1 n2
303 cmp_kind (AutoCC i1) (AutoCC i2) = cmp i1 i2
304 cmp_kind (DictCC i1) (DictCC i2) = cmp i1 i2
305 cmp_kind other_1 other_2
307 tag1 = tag_CcKind other_1
308 tag2 = tag_CcKind other_2
310 if tag1 _LT_ tag2 then LT_ else GT_
312 tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT)
313 tag_CcKind (AutoCC _) = ILIT(2)
314 tag_CcKind (DictCC _) = ILIT(3)
316 cmp_caf IsNotCafCC IsCafCC = LT_
317 cmp_caf IsNotCafCC IsNotCafCC = EQ_
318 cmp_caf IsCafCC IsCafCC = EQ_
319 cmp_caf IsCafCC IsNotCafCC = GT_
323 showCostCentre :: PprStyle -> Bool -> CostCentre -> String
324 uppCostCentre :: PprStyle -> Bool -> CostCentre -> Unpretty
325 uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty
327 showCostCentre PprUnfolding print_as_string cc
328 = ASSERT(not print_as_string) -- we never "print as string w/ Unfolding"
329 ASSERT(not (noCostCentreAttached cc))
330 ASSERT(not (currentOrSubsumedCosts cc))
331 uppShow 80 (upp_cc_uf cc)
333 showCostCentre sty print_as_string cc
334 = uppShow 80 (uppCostCentre sty print_as_string cc)
336 uppCostCentre sty print_as_string NoCostCentre
337 | friendly_style sty = uppNil
338 | print_as_string = uppStr "\"NO_CC\""
339 | otherwise = uppPStr SLIT("NO_CC")
341 uppCostCentre sty print_as_string SubsumedCosts
342 | print_as_string = uppStr "\"SUBSUMED\""
343 | otherwise = uppPStr SLIT("CC_SUBSUMED")
345 uppCostCentre sty print_as_string CurrentCC
346 | print_as_string = uppStr "\"CURRENT_CC\""
347 | otherwise = uppPStr SLIT("CCC")
349 uppCostCentre sty print_as_string OverheadCC
350 | print_as_string = uppStr "\"OVERHEAD\""
351 | otherwise = uppPStr SLIT("CC_OVERHEAD")
353 uppCostCentre sty print_as_string cc
355 prefix_CC = uppPStr SLIT("CC_")
357 basic_thing = do_cc cc
360 = if friendly_sty then basic_thing else stringToC basic_thing
362 if print_as_string then
363 uppBesides [uppChar '"', uppStr basic_thing_string, uppChar '"']
365 else if friendly_sty then
368 uppBesides [prefix_CC,
369 prettyToUn (identToC (_PK_ basic_thing))]
371 friendly_sty = friendly_style sty
374 do_cc OverheadCC = "OVERHEAD"
375 do_cc DontCareCC = "DONT_CARE"
376 do_cc (AllCafsCC m _) = if print_as_string
378 else "CAFs." ++ _UNPK_ m
379 do_cc (AllDictsCC m _ d) = do_dupd d (
382 else "DICTs." ++ _UNPK_ m)
383 do_cc PreludeCafsCC = if print_as_string
386 do_cc (PreludeDictsCC d) = do_dupd d (
391 do_cc (NormalCC kind mod_name grp_name is_dupd is_caf)
393 basic_kind = do_caf is_caf ++ do_kind kind
396 do_dupd is_dupd (basic_kind ++ ('/': moduleString mod_name) ++ ('/': _UNPK_ grp_name))
400 do_caf IsCafCC = "CAF:"
403 do_kind (UserCC name) = _UNPK_ name
404 do_kind (AutoCC id) = do_id id ++ (if friendly_sty then "/AUTO" else "")
405 do_kind (DictCC id) = do_id id ++ (if friendly_sty then "/DICT" else "")
407 do_id :: Id -> String
410 then getOccString id -- use occ name
411 else showId sty id -- we really do
414 do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str
417 friendly_style sty -- i.e., probably for human consumption
425 Printing unfoldings is sufficiently weird that we do it separately.
426 This should only apply to CostCentres that can be ``set to'' (cf
427 @sccAbleCostCentre@). That excludes CAFs and
428 `overhead'---which are added at the very end---but includes dictionaries.
429 Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info;
430 even if we won't ultimately do a \tr{SET_CCC} from it.
432 upp_cc_uf (PreludeDictsCC d)
433 = uppCat [uppPStr SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d]
434 upp_cc_uf (AllDictsCC m g d)
435 = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), upp_dupd d]
437 upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf)
438 = ASSERT(sccAbleCostCentre cc)
439 uppCat [pp_kind cc_kind, uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)),
440 upp_dupd is_dupd, pp_caf is_caf]
442 pp_kind (UserCC name) = uppBeside (uppPStr SLIT("_USER_CC_ ")) (uppStr (show (_UNPK_ name)))
443 pp_kind (AutoCC id) = uppBeside (uppPStr SLIT("_AUTO_CC_ ")) (show_id id)
444 pp_kind (DictCC id) = uppBeside (uppPStr SLIT("_DICT_CC_ ")) (show_id id)
446 show_id id = prettyToUn (pprIdInUnfolding no_in_scopes id)
448 no_in_scopes = emptyUniqSet
450 pp_caf IsCafCC = uppPStr SLIT("_CAF_CC_")
451 pp_caf IsNotCafCC = uppPStr SLIT("_N_")
454 upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other))
457 upp_dupd AnOriginalCC = uppPStr SLIT("_N_")
458 upp_dupd ADupdCC = uppPStr SLIT("_DUPD_CC_")
462 uppCostCentreDecl sty is_local cc
464 | noCostCentreAttached cc || currentOrSubsumedCosts cc
465 = panic "uppCostCentreDecl: no cost centre!"
470 uppStr "CC_DECLARE(",
472 uppCostCentre sty True {-as String!-} cc, uppComma,
473 pp_str mod_name, uppComma,
474 pp_str grp_name, uppComma,
475 uppStr is_subsumed, uppComma,
476 if externally_visible then uppNil else uppPStr SLIT("static"),
479 uppBesides [ uppStr "CC_EXTERN(", upp_ident, uppStr ");" ]
481 upp_ident = uppCostCentre sty False{-as identifier!-} cc
483 pp_str s = uppBeside (uppPStr (_CONS_ '"' s)) (uppChar '"')
484 pp_char c = uppBeside (uppPStr (_CONS_ '\'' c)) (uppChar '\'')
486 (mod_name, grp_name, is_subsumed, externally_visible)
488 AllCafsCC m g -> (m, g, cc_IS_CAF, True)
490 AllDictsCC m g _ -> (m, g, cc_IS_DICT, True)
492 NormalCC (DictCC i) m g is_dupd is_caf
493 -> (m, g, cc_IS_DICT, externallyVisibleId i)
495 NormalCC x m g is_dupd is_caf
496 -> (m, g, do_caf is_caf,
497 case x of { UserCC _ -> True; AutoCC i -> externallyVisibleId i})
499 cc_IS_CAF = "CC_IS_CAF"
500 cc_IS_DICT = "CC_IS_DICT"
501 cc_IS_SUBSUMED = "CC_IS_SUBSUMED"
502 cc_IS_BORING = "CC_IS_BORING"
504 do_caf IsCafCC = cc_IS_CAF
505 do_caf IsNotCafCC = cc_IS_BORING