[project @ 1996-01-08 20:28:12 by partain]
[ghc.git] / ghc / compiler / profiling / CostCentre.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
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
29         Id, Maybe, Unpretty(..), CSeq
30     ) where
31
32 import CmdLineOpts      ( GlobalSwitch(..) )
33 import CLabelInfo       ( identToC, stringToC )
34 import Id               ( cmpId, showId, pprIdInUnfolding,
35                           externallyVisibleId, Id
36                         )
37 import Maybes           ( Maybe(..) )
38 import Outputable
39 import Pretty           ( ppShow, prettyToUn )
40 import UniqSet
41 import Unpretty
42 import Util
43 \end{code}
44
45 \begin{code}
46 data CostCentre
47   = NoCostCentre        -- Having this constructor avoids having
48                         -- to use "Maybe CostCentre" all the time.
49
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.
53                 IsDupdCC -- see below
54                 IsCafCC  -- see below
55
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.
62
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.
68
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.
74
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.
80                 IsDupdCC -- see below
81
82   | OverheadCC          -- We charge costs due to the profiling-system
83                         -- doing its work to "overhead".
84                         --
85                         -- Objects whose cost-centre is "Overhead"
86                         -- have their *allocation* charged to "overhead",
87                         -- but have the current CC put into the object
88                         -- itself.
89                         --
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
97                         -- to f will be set.
98
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
108
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.
113
114 data CcKind
115   = UserCC  FAST_STRING -- Supplied by user: String is the cc name
116   | AutoCC  Id          -- CC -auto-magically inserted for that Id
117   | DictCC  Id
118
119 data IsDupdCC
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
128                         -- "dupd".
129
130 data IsCafCC
131   = IsCafCC
132   | IsNotCafCC
133 \end{code}
134
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.
139
140 SIMON: Maybe later...
141
142 \begin{code}
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)
151
152 noCostCentreAttached NoCostCentre  = True
153 noCostCentreAttached _             = False
154
155 costsAreSubsumed SubsumedCosts  = True
156 costsAreSubsumed _              = False
157
158 currentOrSubsumedCosts SubsumedCosts    = True
159 currentOrSubsumedCosts CurrentCC        = True
160 currentOrSubsumedCosts _                = False
161
162 mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
163
164 mkUserCC cc_name module_name group_name 
165   = NormalCC (UserCC cc_name) module_name group_name
166              AnOriginalCC IsNotCafCC{-might be changed-}
167
168 mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre
169
170 mkDictCC id module_name group_name is_caf
171   = NormalCC (DictCC id) module_name group_name
172              AnOriginalCC is_caf
173
174 mkAutoCC id module_name group_name is_caf
175   = NormalCC (AutoCC id) module_name group_name
176              AnOriginalCC is_caf
177
178 mkAllCafsCC  m g   = AllCafsCC  m g
179 mkAllDictsCC m g is_dupd
180   = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC)
181
182 cafifyCC, unCafifyCC, dupifyCC  :: CostCentre -> CostCentre
183
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
189   where
190     not_a_calf_already IsCafCC = False
191     not_a_calf_already _       = True
192 cafifyCC cc = panic ("cafifyCC"++(showCostCentre PprDebug False cc))
193
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
201
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))
207
208 isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
209
210 isCafCC (AllCafsCC _ _)            = True
211 isCafCC PreludeCafsCC              = True
212 isCafCC (NormalCC _ _ _ _ IsCafCC) = True
213 isCafCC _                          = False
214
215 isDictCC (AllDictsCC _ _ _)             = True
216 isDictCC (PreludeDictsCC _)             = True
217 isDictCC (NormalCC (DictCC _) _ _ _ _)  = True
218 isDictCC _                              = False
219
220 isDupdCC (AllDictsCC _ _ ADupdCC)   = True
221 isDupdCC (PreludeDictsCC ADupdCC)   = True
222 isDupdCC (NormalCC _ _ _ ADupdCC _) = True
223 isDupdCC _                          = False
224
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...
229
230 #if DEBUG
231 setToAbleCostCentre NoCostCentre    = panic "setToAbleCC:NoCostCentre"
232 setToAbleCostCentre SubsumedCosts   = panic "setToAbleCC:SubsumedCosts"
233 setToAbleCostCentre CurrentCC       = panic "setToAbleCC:CurrentCC"
234 setToAbleCostCentre DontCareCC      = panic "setToAbleCC:DontCareCC"
235 #endif
236
237 setToAbleCostCentre OverheadCC      = False -- see comments in type defn
238 setToAbleCostCentre other           = not (isCafCC other || isDictCC other)
239
240 ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool
241
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!
250 \end{code}
251
252 \begin{code}
253 ccMentionsId :: CostCentre -> Maybe Id
254
255 ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id
256 ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id
257 ccMentionsId other                          = Nothing
258 \end{code}
259
260 \begin{code}
261 cmpCostCentre :: CostCentre -> CostCentre -> TAG_
262
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_
269
270 cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2)
271     -- first key is module name, then we use "kinds" (which include
272     -- names)
273   = case (_CMP_STRING_ m1 m2) of
274       LT_  -> LT_
275       EQ_  -> cmp_kind k1 k2
276       GT__ -> GT_
277
278 cmpCostCentre other_1 other_2
279   = let
280         tag1 = tag_CC other_1
281         tag2 = tag_CC other_2
282     in
283     if tag1 _LT_ tag2 then LT_ else GT_
284   where
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)
292
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 }
297
298
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
303   = let
304         tag1 = tag_CcKind other_1
305         tag2 = tag_CcKind other_2
306     in
307     if tag1 _LT_ tag2 then LT_ else GT_
308   where
309     tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT)
310     tag_CcKind (AutoCC _) = ILIT(2)
311     tag_CcKind (DictCC _) = ILIT(3)
312 \end{code}
313
314 \begin{code}
315 showCostCentre    :: PprStyle -> Bool -> CostCentre -> String
316 uppCostCentre     :: PprStyle -> Bool -> CostCentre -> Unpretty
317 uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty
318
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)
324
325 showCostCentre sty print_as_string cc
326   = uppShow 80 (uppCostCentre sty print_as_string cc)
327
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")
332
333 uppCostCentre sty print_as_string SubsumedCosts
334   | print_as_string     = uppStr "\"SUBSUMED\""
335   | otherwise           = uppPStr SLIT("CC_SUBSUMED")
336
337 uppCostCentre sty print_as_string CurrentCC
338   | print_as_string     = uppStr "\"CURRENT_CC\""
339   | otherwise           = uppPStr SLIT("CCC")
340
341 uppCostCentre sty print_as_string OverheadCC
342   | print_as_string     = uppStr "\"OVERHEAD\""
343   | otherwise           = uppPStr SLIT("CC_OVERHEAD")
344
345 uppCostCentre sty print_as_string cc
346   = let
347         prefix_CC = uppPStr SLIT("CC_")
348
349         basic_thing -- (basic_thing, suffix_CAF)
350           = do_cc cc
351
352         basic_thing_string
353           = if friendly_sty then basic_thing else stringToC basic_thing
354     in
355     if print_as_string then
356         uppBesides [uppChar '"', uppStr basic_thing_string, uppChar '"']
357
358     else if friendly_sty then
359         uppStr basic_thing
360     else
361         uppBesides [prefix_CC,
362                     prettyToUn (identToC (_PK_ basic_thing))]
363   where
364     friendly_sty = friendly_style sty
365
366     add_module_name_maybe m str
367       = if print_as_string then str else (str ++ ('.' : m))
368
369     ----------------
370     do_cc OverheadCC         = "OVERHEAD"
371     do_cc DontCareCC         = "DONT_CARE"
372     do_cc (AllCafsCC  m _)   = if print_as_string
373                                then "CAFs_in_..."
374                                else "CAFs." ++ _UNPK_ m
375     do_cc (AllDictsCC m _ d) = do_dupd d (
376                                if print_as_string
377                                then "DICTs_in_..."
378                                else "DICTs." ++ _UNPK_ m)
379     do_cc PreludeCafsCC      = if print_as_string
380                                then "CAFs_in_..."
381                                else "CAFs"
382     do_cc (PreludeDictsCC d) = do_dupd d (
383                                if print_as_string
384                                then "DICTs_in_..."
385                                else "DICTs")
386
387     do_cc (NormalCC kind mod_name grp_name is_dupd is_caf)
388       = let
389             basic_kind = do_kind kind
390             is_a_calf  = do_calved is_caf
391         in
392         if friendly_sty then
393             do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name) ++ is_a_calf)
394         else
395             basic_kind
396       where
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 "")
400
401         do_id :: Id -> String
402         do_id id
403           = if print_as_string
404             then _UNPK_ (getOccurrenceName id) -- don't want module in the name
405             else showId sty id        -- we really do
406
407         do_calved IsCafCC = "/CAF"
408         do_calved _       = ""
409
410     ---------------
411     do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str
412     do_dupd _       str = str
413
414 friendly_style sty -- i.e., probably for human consumption
415   = case sty of
416       PprForUser -> True
417       PprDebug   -> True
418       PprShowAll -> True
419       _          -> False
420 \end{code}
421
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.
428 \begin{code}
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]
433
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]
438   where
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)
442
443     show_id id = prettyToUn (pprIdInUnfolding no_in_scopes id)
444         where
445           no_in_scopes = emptyUniqSet
446
447     pp_caf IsCafCC    = uppPStr SLIT("_CAF_CC_")
448     pp_caf IsNotCafCC = uppPStr SLIT("_N_")
449
450 #ifdef DEBUG
451 upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other))
452 #endif
453
454 upp_dupd AnOriginalCC = uppPStr SLIT("_N_")
455 upp_dupd ADupdCC      = uppPStr SLIT("_DUPD_CC_")
456 \end{code}
457
458 \begin{code}
459 uppCostCentreDecl sty is_local cc
460 #ifdef DEBUG
461   | noCostCentreAttached cc || currentOrSubsumedCosts cc
462   = panic "uppCostCentreDecl: no cost centre!"
463   | otherwise
464 #endif
465   = if is_local then
466         uppBesides [
467             uppStr "CC_DECLARE(",
468             upp_ident, uppComma,
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"),
474             uppStr ");"]
475     else
476         uppBesides [ uppStr "CC_EXTERN(", upp_ident, uppStr ");" ]
477   where
478     upp_ident = uppCostCentre sty False{-as identifier!-} cc
479
480     pp_str s  = uppBeside (uppPStr (_CONS_ '"'  s))  (uppChar '"')
481     pp_char c = uppBeside (uppPStr (_CONS_ '\'' c)) (uppChar '\'')
482
483     (mod_name, grp_name, is_subsumed, externally_visible)
484       = case cc of
485           AllCafsCC m g -> (m, g, cc_IS_CAF, True)
486
487           AllDictsCC m g _ -> (m, g, cc_IS_DICT, True)
488
489           NormalCC (DictCC i) m g is_dupd is_caf
490             -> (m, g, cc_IS_DICT, externallyVisibleId i)
491
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})
495       where
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"
500
501         do_caf IsCafCC       = cc_IS_CAF
502         do_caf IsNotCafCC    = cc_IS_BORING
503 \end{code}