2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
4 \section[CostCentre]{The @CostCentre@ data type}
8 CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..),
9 noCostCentre, subsumedCosts,
11 noCostCentreAttached, costsAreSubsumed, isCurrentCostCentre,
12 currentOrSubsumedCosts,
13 preludeCafsCostCentre, preludeDictsCostCentre,
14 overheadCostCentre, dontCareCostCentre,
16 mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC,
18 isCafCC, isDictCC, isDupdCC,
24 uppCostCentre, uppCostCentreDecl, showCostCentre, -- printing
26 cmpCostCentre -- used for removing dups in a list
29 #include "HsVersions.h"
31 import Id ( externallyVisibleId, GenId, Id )
32 import CStrings ( identToC, stringToC )
33 import Name ( OccName, getOccString, moduleString )
35 import Util ( panic, panic#, assertPanic, thenCmp )
41 = NoCostCentre -- Having this constructor avoids having
42 -- to use "Maybe CostCentre" all the time.
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.
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.
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.
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.
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.
76 | OverheadCC -- We charge costs due to the profiling-system
77 -- doing its work to "overhead".
79 -- Objects whose cost-centre is "Overhead"
80 -- have their *allocation* charged to "overhead",
81 -- but have the current CC put into the object
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
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
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.
109 = UserCC FAST_STRING -- Supplied by user: String is the cc name
110 | AutoCC Id -- CC -auto-magically inserted for that Id
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
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.
134 SIMON: Maybe later...
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)
146 noCostCentreAttached NoCostCentre = True
147 noCostCentreAttached _ = False
149 isCurrentCostCentre CurrentCC = True
150 isCurrentCostCentre _ = False
152 costsAreSubsumed SubsumedCosts = True
153 costsAreSubsumed _ = False
155 currentOrSubsumedCosts SubsumedCosts = True
156 currentOrSubsumedCosts CurrentCC = True
157 currentOrSubsumedCosts _ = False
159 mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
161 mkUserCC cc_name module_name group_name
162 = NormalCC (UserCC cc_name) module_name group_name
163 AnOriginalCC IsNotCafCC{-might be changed-}
165 mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre
167 mkDictCC id module_name group_name is_caf
168 = NormalCC (DictCC id) module_name group_name
171 mkAutoCC id module_name group_name is_caf
172 = NormalCC (AutoCC id) module_name group_name
175 mkAllCafsCC m g = AllCafsCC m g
176 mkAllDictsCC m g is_dupd
177 = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC)
179 cafifyCC, dupifyCC :: CostCentre -> CostCentre
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
187 not_a_calf_already IsCafCC = False
188 not_a_calf_already _ = True
189 cafifyCC cc = panic ("cafifyCC"++(showCostCentre False cc))
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))
197 isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
199 isCafCC (AllCafsCC _ _) = True
200 isCafCC PreludeCafsCC = True
201 isCafCC (NormalCC _ _ _ _ IsCafCC) = True
204 isDictCC (AllDictsCC _ _ _) = True
205 isDictCC (PreludeDictsCC _) = True
206 isDictCC (NormalCC (DictCC _) _ _ _ _) = True
209 isDupdCC (AllDictsCC _ _ ADupdCC) = True
210 isDupdCC (PreludeDictsCC ADupdCC) = True
211 isDupdCC (NormalCC _ _ _ ADupdCC _) = True
214 isSccCountCostCentre :: CostCentre -> Bool
215 -- Is this a cost-centre which records scc counts
218 isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre"
219 isSccCountCostCentre SubsumedCosts = panic "isSccCount:SubsumedCosts"
220 isSccCountCostCentre CurrentCC = panic "isSccCount:CurrentCC"
221 isSccCountCostCentre DontCareCC = panic "isSccCount:DontCareCC"
223 isSccCountCostCentre OverheadCC = False
224 isSccCountCostCentre cc | isCafCC cc = False
225 | isDupdCC cc = False
229 sccAbleCostCentre :: CostCentre -> Bool
230 -- Is this a cost-centre which can be sccd ?
233 sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre"
234 sccAbleCostCentre SubsumedCosts = panic "sccAbleCC:SubsumedCosts"
235 sccAbleCostCentre CurrentCC = panic "sccAbleCC:CurrentCC"
236 sccAbleCostCentre DontCareCC = panic "sccAbleCC:DontCareCC"
238 sccAbleCostCentre OverheadCC = False
239 sccAbleCostCentre cc | isCafCC cc = False
242 ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool
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!
255 ccMentionsId :: CostCentre -> Maybe Id
257 ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id
258 ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id
259 ccMentionsId other = Nothing
263 cmpCostCentre :: CostCentre -> CostCentre -> Ordering
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
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)
277 cmpCostCentre other_1 other_2
279 tag1 = tag_CC other_1
280 tag2 = tag_CC other_2
282 if tag1 _LT_ tag2 then LT else GT
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)
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"
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
303 tag1 = tag_CcKind other_1
304 tag2 = tag_CcKind other_2
306 if tag1 _LT_ tag2 then LT else GT
308 tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT)
309 tag_CcKind (AutoCC _) = ILIT(2)
310 tag_CcKind (DictCC _) = ILIT(3)
312 cmp_caf IsNotCafCC IsCafCC = LT
313 cmp_caf IsNotCafCC IsNotCafCC = EQ
314 cmp_caf IsCafCC IsCafCC = EQ
315 cmp_caf IsCafCC IsNotCafCC = GT
319 showCostCentre :: Bool -> CostCentre -> String
320 uppCostCentre :: Bool -> CostCentre -> SDoc
321 uppCostCentreDecl :: Bool -> CostCentre -> SDoc
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)
331 showCostCentre print_as_string cc
332 = showSDoc (uppCostCentre print_as_string cc)
334 uppCostCentre print_as_string NoCostCentre
335 | print_as_string = text "\"NO_CC\""
336 | otherwise = ptext SLIT("NO_CC")
338 uppCostCentre print_as_string SubsumedCosts
339 | print_as_string = text "\"SUBSUMED\""
340 | otherwise = ptext SLIT("CC_SUBSUMED")
342 uppCostCentre print_as_string CurrentCC
343 | print_as_string = text "\"CURRENT_CC\""
344 | otherwise = ptext SLIT("CCC")
346 uppCostCentre print_as_string OverheadCC
347 | print_as_string = text "\"OVERHEAD\""
348 | otherwise = ptext SLIT("CC_OVERHEAD")
350 uppCostCentre print_as_string cc
351 = getPprStyle $ \ sty ->
353 prefix_CC = ptext SLIT("CC_")
354 basic_thing = do_cc sty cc
355 basic_thing_string = stringToC basic_thing
357 if print_as_string then
358 hcat [char '"', text basic_thing_string, char '"']
360 else if (friendly_sty sty) then
363 hcat [prefix_CC, identToC (_PK_ basic_thing)]
365 friendly_sty sty = userStyle sty || debugStyle sty -- i.e. probably for human consumption
367 do_cc sty DontCareCC = "DONT_CARE"
368 do_cc sty (AllCafsCC m _) = if print_as_string
370 else "CAFs." ++ _UNPK_ m
371 do_cc sty (AllDictsCC m _ d) = do_dupd sty d (
374 else "DICTs." ++ _UNPK_ m)
375 do_cc sty PreludeCafsCC = if print_as_string
378 do_cc sty (PreludeDictsCC d) = do_dupd sty d (
383 do_cc sty (NormalCC kind mod_name grp_name is_dupd is_caf)
385 basic_kind = do_kind kind
386 module_kind = do_caf is_caf (moduleString mod_name ++ '/':
389 {- TODO: re-instate this once interface file lexer
392 if (_NULL_ grp_name) then
395 '/' : (_UNPK_ grp_name)
397 full_kind = do_caf is_caf
398 (moduleString mod_name ++
399 grp_str ++ ('/' : basic_kind))
401 if (friendly_sty sty) then
402 do_dupd sty is_dupd full_kind
403 else if codeStyle sty && print_as_string then
405 drop the module name when printing
406 out SCC label in CC declaration
412 do_caf IsCafCC ls = "CAF:" ++ ls
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 "")
420 do_id is only applied in a (not print_as_string) context for local ids,
421 hence using the occurrence name is enough.
423 do_id :: Id -> String
424 do_id id = getOccString id
427 do_dupd sty ADupdCC str = if (debugStyle sty) then str ++ "/DUPD" else str
428 do_dupd _ _ str = str
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.
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 '"',
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]
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)
458 show_id id = pprIdInUnfolding {-no_in_scopes-} id
460 pp_caf IsCafCC = ptext SLIT("_CAF_CC_")
461 pp_caf IsNotCafCC = ptext SLIT("_N_")
464 upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre True other))
467 pprIdInUnfolding = panic "Whoops"
469 upp_dupd AnOriginalCC = ptext SLIT("_N_")
470 upp_dupd ADupdCC = ptext SLIT("_D_")
475 uppCostCentreDecl is_local cc
477 | noCostCentreAttached cc || currentOrSubsumedCosts cc
478 = panic "uppCostCentreDecl: no cost centre!"
483 ptext SLIT("CC_DECLARE"),char '(',
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.
493 else ptext SLIT("static"),
496 hcat [ ptext SLIT("CC_EXTERN"),char '(', upp_ident, text ");" ]
498 upp_ident = uppCostCentre False{-as identifier!-} cc
500 pp_str s = doubleQuotes (ptext s)
502 (mod_name, grp_name, is_subsumed, externally_visible)
504 AllCafsCC m g -> (m, g, cc_IS_CAF, True)
506 AllDictsCC m g _ -> (m, g, cc_IS_DICT, True)
508 NormalCC (DictCC i) m g is_dupd is_caf
509 -> (m, g, cc_IS_DICT, externallyVisibleId i)
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})
515 cc_IS_CAF = "CC_IS_CAF"
516 cc_IS_DICT = "CC_IS_DICT"
517 cc_IS_BORING = "CC_IS_BORING"
519 do_caf IsCafCC = cc_IS_CAF
520 do_caf IsNotCafCC = cc_IS_BORING