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, isCurrentCostCentre,
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, showId, SYN_IE(Id) )
34 import CStrings ( identToC, stringToC )
35 import Name ( OccName, getOccString, moduleString, nameString )
36 import Outputable ( PprStyle(..), codeStyle, ifaceStyle )
38 import Util ( panic, panic#, assertPanic, cmpPString, thenCmp, Ord3(..) )
39 import CmdLineOpts ( all_toplev_ids_visible )
41 pprIdInUnfolding = panic "Whoops"
46 = NoCostCentre -- Having this constructor avoids having
47 -- to use "Maybe CostCentre" all the time.
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.
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.
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.
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.
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.
81 | OverheadCC -- We charge costs due to the profiling-system
82 -- doing its work to "overhead".
84 -- Objects whose cost-centre is "Overhead"
85 -- have their *allocation* charged to "overhead",
86 -- but have the current CC put into the object
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
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
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.
114 = UserCC FAST_STRING -- Supplied by user: String is the cc name
115 | AutoCC Id -- CC -auto-magically inserted for that Id
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
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.
139 SIMON: Maybe later...
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)
151 noCostCentreAttached NoCostCentre = True
152 noCostCentreAttached _ = False
154 isCurrentCostCentre CurrentCC = True
155 isCurrentCostCentre _ = False
157 costsAreSubsumed SubsumedCosts = True
158 costsAreSubsumed _ = False
160 currentOrSubsumedCosts SubsumedCosts = True
161 currentOrSubsumedCosts CurrentCC = True
162 currentOrSubsumedCosts _ = False
164 mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
166 mkUserCC cc_name module_name group_name
167 = NormalCC (UserCC cc_name) module_name group_name
168 AnOriginalCC IsNotCafCC{-might be changed-}
170 mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre
172 mkDictCC id module_name group_name is_caf
173 = NormalCC (DictCC id) module_name group_name
176 mkAutoCC id module_name group_name is_caf
177 = NormalCC (AutoCC id) module_name group_name
180 mkAllCafsCC m g = AllCafsCC m g
181 mkAllDictsCC m g is_dupd
182 = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC)
184 cafifyCC, dupifyCC :: CostCentre -> CostCentre
186 cafifyCC cc@(AllDictsCC _ _ _) = cc -- ToDo ???
187 cafifyCC cc@(PreludeDictsCC _) = cc -- ditto
188 cafifyCC (NormalCC kind m g is_dupd is_caf)
189 = ASSERT(not_a_calf_already is_caf)
190 NormalCC kind m g is_dupd IsCafCC
192 not_a_calf_already IsCafCC = False
193 not_a_calf_already _ = True
194 cafifyCC cc = panic ("cafifyCC"++(showCostCentre PprDebug False cc))
196 dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC
197 dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC
198 dupifyCC (NormalCC kind m g is_dupd is_caf)
199 = NormalCC kind m g ADupdCC is_caf
200 dupifyCC cc = panic ("dupifyCC"++(showCostCentre PprDebug False cc))
202 isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
204 isCafCC (AllCafsCC _ _) = True
205 isCafCC PreludeCafsCC = True
206 isCafCC (NormalCC _ _ _ _ IsCafCC) = True
209 isDictCC (AllDictsCC _ _ _) = True
210 isDictCC (PreludeDictsCC _) = True
211 isDictCC (NormalCC (DictCC _) _ _ _ _) = True
214 isDupdCC (AllDictsCC _ _ ADupdCC) = True
215 isDupdCC (PreludeDictsCC ADupdCC) = True
216 isDupdCC (NormalCC _ _ _ ADupdCC _) = True
219 isSccCountCostCentre :: CostCentre -> Bool
220 -- Is this a cost-centre which records scc counts
223 isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre"
224 isSccCountCostCentre SubsumedCosts = panic "isSccCount:SubsumedCosts"
225 isSccCountCostCentre CurrentCC = panic "isSccCount:CurrentCC"
226 isSccCountCostCentre DontCareCC = panic "isSccCount:DontCareCC"
228 isSccCountCostCentre OverheadCC = False
229 isSccCountCostCentre cc | isCafCC cc = False
230 | isDupdCC cc = False
234 sccAbleCostCentre :: CostCentre -> Bool
235 -- Is this a cost-centre which can be sccd ?
238 sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre"
239 sccAbleCostCentre SubsumedCosts = panic "sccAbleCC:SubsumedCosts"
240 sccAbleCostCentre CurrentCC = panic "sccAbleCC:CurrentCC"
241 sccAbleCostCentre DontCareCC = panic "sccAbleCC:DontCareCC"
243 sccAbleCostCentre OverheadCC = False
244 sccAbleCostCentre cc | isCafCC cc = False
247 ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool
249 ccFromThisModule (NormalCC _ m _ _ _) mod_name = m == mod_name
250 ccFromThisModule (AllCafsCC m _) mod_name = m == mod_name
251 ccFromThisModule (AllDictsCC m _ _) mod_name = m == mod_name
252 ccFromThisModule PreludeCafsCC _ = False
253 ccFromThisModule (PreludeDictsCC _) _ = False
254 ccFromThisModule OverheadCC _ = False
255 ccFromThisModule DontCareCC _ = False
256 -- shouldn't ask about any others!
260 ccMentionsId :: CostCentre -> Maybe Id
262 ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id
263 ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id
264 ccMentionsId other = Nothing
268 cmpCostCentre :: CostCentre -> CostCentre -> TAG_
270 cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = _CMP_STRING_ m1 m2
271 cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = _CMP_STRING_ m1 m2
272 cmpCostCentre PreludeCafsCC PreludeCafsCC = EQ_
273 cmpCostCentre (PreludeDictsCC _) (PreludeDictsCC _) = EQ_
274 cmpCostCentre OverheadCC OverheadCC = EQ_
275 cmpCostCentre DontCareCC DontCareCC = EQ_
277 cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2)
278 -- first key is module name, then we use "kinds" (which include
279 -- names) and finally the caf flag
280 = _CMP_STRING_ m1 m2 `thenCmp` cmp_kind k1 k2 `thenCmp` cmp_caf c1 c2
282 cmpCostCentre other_1 other_2
284 tag1 = tag_CC other_1
285 tag2 = tag_CC other_2
287 if tag1 _LT_ tag2 then LT_ else GT_
289 tag_CC (NormalCC _ _ _ _ _) = (ILIT(1) :: FAST_INT)
290 tag_CC (AllCafsCC _ _) = ILIT(2)
291 tag_CC (AllDictsCC _ _ _) = ILIT(3)
292 tag_CC PreludeCafsCC = ILIT(4)
293 tag_CC (PreludeDictsCC _) = ILIT(5)
294 tag_CC OverheadCC = ILIT(6)
295 tag_CC DontCareCC = ILIT(7)
297 -- some BUG avoidance here...
298 tag_CC NoCostCentre = panic# "tag_CC:NoCostCentre"
299 tag_CC SubsumedCosts = panic# "tag_CC:SubsumedCosts"
300 tag_CC CurrentCC = panic# "tag_CC:SubsumedCosts"
303 cmp_kind (UserCC n1) (UserCC n2) = _CMP_STRING_ n1 n2
304 cmp_kind (AutoCC i1) (AutoCC i2) = cmp i1 i2
305 cmp_kind (DictCC i1) (DictCC i2) = cmp i1 i2
306 cmp_kind other_1 other_2
308 tag1 = tag_CcKind other_1
309 tag2 = tag_CcKind other_2
311 if tag1 _LT_ tag2 then LT_ else GT_
313 tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT)
314 tag_CcKind (AutoCC _) = ILIT(2)
315 tag_CcKind (DictCC _) = ILIT(3)
317 cmp_caf IsNotCafCC IsCafCC = LT_
318 cmp_caf IsNotCafCC IsNotCafCC = EQ_
319 cmp_caf IsCafCC IsCafCC = EQ_
320 cmp_caf IsCafCC IsNotCafCC = GT_
324 showCostCentre :: PprStyle -> Bool -> CostCentre -> String
325 uppCostCentre :: PprStyle -> Bool -> CostCentre -> Doc
326 uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Doc
328 {- PprUnfolding is gone now
329 showCostCentre PprUnfolding print_as_string cc
330 = ASSERT(not print_as_string) -- we never "print as string w/ Unfolding"
331 ASSERT(not (noCostCentreAttached cc))
332 ASSERT(not (currentOrSubsumedCosts cc))
333 uppShow 80 (upp_cc_uf cc)
336 showCostCentre sty print_as_string cc
337 = show (uppCostCentre sty print_as_string cc)
339 uppCostCentre sty print_as_string NoCostCentre
340 | friendly_style sty = empty
341 | print_as_string = text "\"NO_CC\""
342 | otherwise = ptext SLIT("NO_CC")
344 uppCostCentre sty print_as_string SubsumedCosts
345 | print_as_string = text "\"SUBSUMED\""
346 | otherwise = ptext SLIT("CC_SUBSUMED")
348 uppCostCentre sty print_as_string CurrentCC
349 | print_as_string = text "\"CURRENT_CC\""
350 | otherwise = ptext SLIT("CCC")
352 uppCostCentre sty print_as_string OverheadCC
353 | print_as_string = text "\"OVERHEAD\""
354 | otherwise = ptext SLIT("CC_OVERHEAD")
356 uppCostCentre sty print_as_string cc
358 prefix_CC = ptext SLIT("CC_")
360 basic_thing = do_cc cc
363 = if friendly_sty then basic_thing else stringToC basic_thing
365 if print_as_string then
366 hcat [char '"', text basic_thing_string, char '"']
368 else if friendly_sty then
371 hcat [prefix_CC, identToC (_PK_ basic_thing)]
373 friendly_sty = friendly_style sty
376 do_cc DontCareCC = "DONT_CARE"
377 do_cc (AllCafsCC m _) = if print_as_string
379 else "CAFs." ++ _UNPK_ m
380 do_cc (AllDictsCC m _ d) = do_dupd d (
383 else "DICTs." ++ _UNPK_ m)
384 do_cc PreludeCafsCC = if print_as_string
387 do_cc (PreludeDictsCC d) = do_dupd d (
392 do_cc (NormalCC kind mod_name grp_name is_dupd is_caf)
394 basic_kind = do_kind kind
395 module_kind = do_caf is_caf (moduleString mod_name ++ '/':
397 grp_str = if (_NULL_ grp_name) then mod_name else grp_name
398 full_kind = do_caf is_caf
399 (moduleString mod_name ++
400 ('/' : _UNPK_ grp_str) ++
404 do_dupd is_dupd full_kind
408 do_caf IsCafCC ls = "CAF:" ++ ls
411 do_kind (UserCC name) = _UNPK_ name
412 do_kind (AutoCC id) = do_id id ++ (if friendly_sty then "/AUTO" else "")
413 do_kind (DictCC id) = do_id id ++ (if friendly_sty then "/DICT" else "")
416 do_id is only applied in a (not print_as_string) context for local ids,
417 hence using the occurrence name is enough.
419 do_id :: Id -> String
420 do_id id = getOccString id
423 do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str
426 friendly_style sty -- i.e., probably for human consumption
433 friendly_style sty -- i.e., probably for human consumption
434 = not (codeStyle sty || ifaceStyle sty)
438 Printing unfoldings is sufficiently weird that we do it separately.
439 This should only apply to CostCentres that can be ``set to'' (cf
440 @sccAbleCostCentre@). That excludes CAFs and
441 `overhead'---which are added at the very end---but includes dictionaries.
442 Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info;
443 even if we won't ultimately do a \tr{SET_CCC} from it.
445 upp_cc_uf (PreludeDictsCC d)
446 = hsep [ptext SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d]
447 upp_cc_uf (AllDictsCC m g d)
448 = hsep [ptext SLIT("_ALL_DICTS_CC_"),
449 char '"',ptext m,char '"',
450 char '"',ptext g,char '"',
453 upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf)
454 = ASSERT(sccAbleCostCentre cc)
455 hsep [pp_kind cc_kind,
456 char '"', ptext m, char '"',
457 char '"', ptext g, char '"',
458 upp_dupd is_dupd, pp_caf is_caf]
460 pp_kind (UserCC name) = hcat [ptext SLIT("_USER_CC_ "), char '"', ptext name, char '"']
461 pp_kind (AutoCC id) = (<>) (ptext SLIT("_AUTO_CC_ ")) (show_id id)
462 pp_kind (DictCC id) = (<>) (ptext SLIT("_DICT_CC_ ")) (show_id id)
464 show_id id = pprIdInUnfolding {-no_in_scopes-} id
466 pp_caf IsCafCC = ptext SLIT("_CAF_CC_")
467 pp_caf IsNotCafCC = ptext SLIT("_N_")
470 upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other))
473 upp_dupd AnOriginalCC = ptext SLIT("_N_")
474 upp_dupd ADupdCC = ptext SLIT("_D_")
478 uppCostCentreDecl sty is_local cc
480 | noCostCentreAttached cc || currentOrSubsumedCosts cc
481 = panic "uppCostCentreDecl: no cost centre!"
486 ptext SLIT("CC_DECLARE"),char '(',
488 uppCostCentre sty True {-as String!-} cc, comma,
489 pp_str mod_name, comma,
490 pp_str grp_name, comma,
491 text is_subsumed, comma,
492 if externally_visible || all_toplev_ids_visible then empty else ptext SLIT("static"),
495 hcat [ ptext SLIT("CC_EXTERN"),char '(', upp_ident, text ");" ]
497 upp_ident = uppCostCentre sty False{-as identifier!-} cc
499 pp_str s = doubleQuotes (ptext s)
501 (mod_name, grp_name, is_subsumed, externally_visible)
503 AllCafsCC m g -> (m, g, cc_IS_CAF, True)
505 AllDictsCC m g _ -> (m, g, cc_IS_DICT, True)
507 NormalCC (DictCC i) m g is_dupd is_caf
508 -> (m, g, cc_IS_DICT, externallyVisibleId i)
510 NormalCC x m g is_dupd is_caf
511 -> (m, g, do_caf is_caf,
512 case x of { UserCC _ -> True; AutoCC i -> externallyVisibleId i})
514 cc_IS_CAF = "CC_IS_CAF"
515 cc_IS_DICT = "CC_IS_DICT"
516 cc_IS_SUBSUMED = "CC_IS_SUBSUMED"
517 cc_IS_BORING = "CC_IS_BORING"
519 do_caf IsCafCC = cc_IS_CAF
520 do_caf IsNotCafCC = cc_IS_BORING