%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CostCentre]{The @CostCentre@ data type}
\begin{code}
-#include "HsVersions.h"
-
module CostCentre (
CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..),
noCostCentre, subsumedCosts,
useCurrentCostCentre,
- noCostCentreAttached, costsAreSubsumed,
+ noCostCentreAttached, costsAreSubsumed, isCurrentCostCentre,
currentOrSubsumedCosts,
preludeCafsCostCentre, preludeDictsCostCentre,
overheadCostCentre, dontCareCostCentre,
mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC,
- cafifyCC, unCafifyCC, dupifyCC,
+ cafifyCC, dupifyCC,
isCafCC, isDictCC, isDupdCC,
- setToAbleCostCentre,
+ isSccCountCostCentre,
+ sccAbleCostCentre,
ccFromThisModule,
ccMentionsId,
uppCostCentre, uppCostCentreDecl, showCostCentre, -- printing
- cmpCostCentre, -- used for removing dups in a list
-
- Id, Maybe, Unpretty(..), CSeq
+ cmpCostCentre -- used for removing dups in a list
) where
-import CmdLineOpts ( GlobalSwitch(..) )
-import CLabelInfo ( identToC, stringToC )
-import Id ( cmpId, showId, pprIdInUnfolding,
- externallyVisibleId, Id
- )
-import Maybes ( Maybe(..) )
-import Outputable
-import Pretty ( ppShow, prettyToUn )
-import UniqSet
-import Unpretty
-import Util
+#include "HsVersions.h"
+
+import Id ( externallyVisibleId, GenId, Id )
+import CStrings ( identToC, stringToC )
+import Name ( OccName, getOccString, moduleString )
+import Outputable
+import Util ( panic, panic#, assertPanic, thenCmp )
+
\end{code}
\begin{code}
noCostCentreAttached NoCostCentre = True
noCostCentreAttached _ = False
+isCurrentCostCentre CurrentCC = True
+isCurrentCostCentre _ = False
+
costsAreSubsumed SubsumedCosts = True
costsAreSubsumed _ = False
mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre
-mkUserCC cc_name module_name group_name
+mkUserCC cc_name module_name group_name
= NormalCC (UserCC cc_name) module_name group_name
AnOriginalCC IsNotCafCC{-might be changed-}
mkAllDictsCC m g is_dupd
= AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC)
-cafifyCC, unCafifyCC, dupifyCC :: CostCentre -> CostCentre
+cafifyCC, dupifyCC :: CostCentre -> CostCentre
-cafifyCC cc@(AllDictsCC _ _ _) = cc -- ???????? ToDo
-cafifyCC cc@(PreludeDictsCC _) = cc -- ditto
+cafifyCC cc@(AllDictsCC _ _ _) = cc -- ToDo ???
+cafifyCC cc@(PreludeDictsCC _) = cc -- ditto
cafifyCC (NormalCC kind m g is_dupd is_caf)
= ASSERT(not_a_calf_already is_caf)
NormalCC kind m g is_dupd IsCafCC
where
not_a_calf_already IsCafCC = False
not_a_calf_already _ = True
-cafifyCC cc = panic ("cafifyCC"++(showCostCentre PprDebug False cc))
-
--- WDP 95/07: pretty dodgy
-unCafifyCC (NormalCC kind m g is_dupd IsCafCC) = NormalCC kind m g is_dupd IsNotCafCC
-unCafifyCC (AllCafsCC _ _) = CurrentCC
-unCafifyCC PreludeCafsCC = CurrentCC
-unCafifyCC (AllDictsCC _ _ _) = CurrentCC
-unCafifyCC (PreludeDictsCC _) = CurrentCC
-unCafifyCC other_cc = other_cc
+cafifyCC cc = panic ("cafifyCC"++(showCostCentre False cc))
dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC
dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC
dupifyCC (NormalCC kind m g is_dupd is_caf)
= NormalCC kind m g ADupdCC is_caf
-dupifyCC cc = panic ("dupifyCC"++(showCostCentre PprDebug False cc))
+dupifyCC cc = panic ("dupifyCC"++(showCostCentre False cc))
isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool
isDupdCC (NormalCC _ _ _ ADupdCC _) = True
isDupdCC _ = False
-setToAbleCostCentre :: CostCentre -> Bool
- -- Is this a cost-centre to which CCC might reasonably
- -- be set? setToAbleCostCentre is allowed to panic on
- -- "nonsense" cases, too...
+isSccCountCostCentre :: CostCentre -> Bool
+ -- Is this a cost-centre which records scc counts
#if DEBUG
-setToAbleCostCentre NoCostCentre = panic "setToAbleCC:NoCostCentre"
-setToAbleCostCentre SubsumedCosts = panic "setToAbleCC:SubsumedCosts"
-setToAbleCostCentre CurrentCC = panic "setToAbleCC:CurrentCC"
-setToAbleCostCentre DontCareCC = panic "setToAbleCC:DontCareCC"
+isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre"
+isSccCountCostCentre SubsumedCosts = panic "isSccCount:SubsumedCosts"
+isSccCountCostCentre CurrentCC = panic "isSccCount:CurrentCC"
+isSccCountCostCentre DontCareCC = panic "isSccCount:DontCareCC"
#endif
+isSccCountCostCentre OverheadCC = False
+isSccCountCostCentre cc | isCafCC cc = False
+ | isDupdCC cc = False
+ | isDictCC cc = True
+ | otherwise = True
+
+sccAbleCostCentre :: CostCentre -> Bool
+ -- Is this a cost-centre which can be sccd ?
-setToAbleCostCentre OverheadCC = False -- see comments in type defn
-setToAbleCostCentre other = not (isCafCC other || isDictCC other)
+#if DEBUG
+sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre"
+sccAbleCostCentre SubsumedCosts = panic "sccAbleCC:SubsumedCosts"
+sccAbleCostCentre CurrentCC = panic "sccAbleCC:CurrentCC"
+sccAbleCostCentre DontCareCC = panic "sccAbleCC:DontCareCC"
+#endif
+sccAbleCostCentre OverheadCC = False
+sccAbleCostCentre cc | isCafCC cc = False
+ | otherwise = True
ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool
\end{code}
\begin{code}
-cmpCostCentre :: CostCentre -> CostCentre -> TAG_
+cmpCostCentre :: CostCentre -> CostCentre -> Ordering
-cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = _CMP_STRING_ m1 m2
-cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = _CMP_STRING_ m1 m2
-cmpCostCentre PreludeCafsCC PreludeCafsCC = EQ_
-cmpCostCentre (PreludeDictsCC _) (PreludeDictsCC _) = EQ_
-cmpCostCentre OverheadCC OverheadCC = EQ_
-cmpCostCentre DontCareCC DontCareCC = EQ_
+cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = m1 `compare` m2
+cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = m1 `compare` m2
+cmpCostCentre PreludeCafsCC PreludeCafsCC = EQ
+cmpCostCentre (PreludeDictsCC _) (PreludeDictsCC _) = EQ
+cmpCostCentre OverheadCC OverheadCC = EQ
+cmpCostCentre DontCareCC DontCareCC = EQ
cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2)
-- first key is module name, then we use "kinds" (which include
- -- names)
- = case (_CMP_STRING_ m1 m2) of
- LT_ -> LT_
- EQ_ -> cmp_kind k1 k2
- GT__ -> GT_
+ -- names) and finally the caf flag
+ = (m1 `compare` m2) `thenCmp` (k1 `cmp_kind` k2) `thenCmp` (c1 `cmp_caf` c2)
cmpCostCentre other_1 other_2
= let
tag1 = tag_CC other_1
tag2 = tag_CC other_2
in
- if tag1 _LT_ tag2 then LT_ else GT_
+ if tag1 _LT_ tag2 then LT else GT
where
tag_CC (NormalCC _ _ _ _ _) = (ILIT(1) :: FAST_INT)
tag_CC (AllCafsCC _ _) = ILIT(2)
tag_CC DontCareCC = ILIT(7)
-- some BUG avoidance here...
- tag_CC NoCostCentre = case (panic "tag_CC:NoCostCentre") of { c -> tag_CC c }
- tag_CC SubsumedCosts = case (panic "tag_CC:SubsumedCosts") of { c -> tag_CC c }
- tag_CC CurrentCC = case (panic "tag_CC:SubsumedCosts") of { c -> tag_CC c }
+ tag_CC NoCostCentre = panic# "tag_CC:NoCostCentre"
+ tag_CC SubsumedCosts = panic# "tag_CC:SubsumedCosts"
+ tag_CC CurrentCC = panic# "tag_CC:SubsumedCosts"
-cmp_kind (UserCC n1) (UserCC n2) = _CMP_STRING_ n1 n2
-cmp_kind (AutoCC i1) (AutoCC i2) = cmpId i1 i2
-cmp_kind (DictCC i1) (DictCC i2) = cmpId i1 i2
+cmp_kind (UserCC n1) (UserCC n2) = n1 `compare` n2
+cmp_kind (AutoCC i1) (AutoCC i2) = i1 `compare` i2
+cmp_kind (DictCC i1) (DictCC i2) = i1 `compare` i2
cmp_kind other_1 other_2
= let
tag1 = tag_CcKind other_1
tag2 = tag_CcKind other_2
in
- if tag1 _LT_ tag2 then LT_ else GT_
+ if tag1 _LT_ tag2 then LT else GT
where
tag_CcKind (UserCC _) = (ILIT(1) :: FAST_INT)
tag_CcKind (AutoCC _) = ILIT(2)
tag_CcKind (DictCC _) = ILIT(3)
+
+cmp_caf IsNotCafCC IsCafCC = LT
+cmp_caf IsNotCafCC IsNotCafCC = EQ
+cmp_caf IsCafCC IsCafCC = EQ
+cmp_caf IsCafCC IsNotCafCC = GT
\end{code}
\begin{code}
-showCostCentre :: PprStyle -> Bool -> CostCentre -> String
-uppCostCentre :: PprStyle -> Bool -> CostCentre -> Unpretty
-uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty
+showCostCentre :: Bool -> CostCentre -> String
+uppCostCentre :: Bool -> CostCentre -> SDoc
+uppCostCentreDecl :: Bool -> CostCentre -> SDoc
-showCostCentre (PprUnfolding _) print_as_string cc
+{- PprUnfolding is gone now
+showCostCentre PprUnfolding print_as_string cc
= ASSERT(not print_as_string) -- we never "print as string w/ Unfolding"
ASSERT(not (noCostCentreAttached cc))
ASSERT(not (currentOrSubsumedCosts cc))
uppShow 80 (upp_cc_uf cc)
+-}
-showCostCentre sty print_as_string cc
- = uppShow 80 (uppCostCentre sty print_as_string cc)
+showCostCentre print_as_string cc
+ = showSDoc (uppCostCentre print_as_string cc)
-uppCostCentre sty print_as_string NoCostCentre
- | friendly_style sty = uppNil
- | print_as_string = uppStr "\"NO_CC\""
- | otherwise = uppPStr SLIT("NO_CC")
+uppCostCentre print_as_string NoCostCentre
+ | print_as_string = text "\"NO_CC\""
+ | otherwise = ptext SLIT("NO_CC")
-uppCostCentre sty print_as_string SubsumedCosts
- | print_as_string = uppStr "\"SUBSUMED\""
- | otherwise = uppPStr SLIT("CC_SUBSUMED")
+uppCostCentre print_as_string SubsumedCosts
+ | print_as_string = text "\"SUBSUMED\""
+ | otherwise = ptext SLIT("CC_SUBSUMED")
-uppCostCentre sty print_as_string CurrentCC
- | print_as_string = uppStr "\"CURRENT_CC\""
- | otherwise = uppPStr SLIT("CCC")
+uppCostCentre print_as_string CurrentCC
+ | print_as_string = text "\"CURRENT_CC\""
+ | otherwise = ptext SLIT("CCC")
-uppCostCentre sty print_as_string OverheadCC
- | print_as_string = uppStr "\"OVERHEAD\""
- | otherwise = uppPStr SLIT("CC_OVERHEAD")
-
-uppCostCentre sty print_as_string cc
- = let
- prefix_CC = uppPStr SLIT("CC_")
+uppCostCentre print_as_string OverheadCC
+ | print_as_string = text "\"OVERHEAD\""
+ | otherwise = ptext SLIT("CC_OVERHEAD")
- basic_thing -- (basic_thing, suffix_CAF)
- = do_cc cc
-
- basic_thing_string
- = if friendly_sty then basic_thing else stringToC basic_thing
+uppCostCentre print_as_string cc
+ = getPprStyle $ \ sty ->
+ let
+ prefix_CC = ptext SLIT("CC_")
+ basic_thing = do_cc sty cc
+ basic_thing_string = stringToC basic_thing
in
if print_as_string then
- uppBesides [uppChar '"', uppStr basic_thing_string, uppChar '"']
+ hcat [char '"', text basic_thing_string, char '"']
- else if friendly_sty then
- uppStr basic_thing
+ else if (friendly_sty sty) then
+ text basic_thing
else
- uppBesides [prefix_CC,
- prettyToUn (identToC (_PK_ basic_thing))]
+ hcat [prefix_CC, identToC (_PK_ basic_thing)]
where
- friendly_sty = friendly_style sty
-
- add_module_name_maybe m str
- = if print_as_string then str else (str ++ ('.' : m))
-
- ----------------
- do_cc OverheadCC = "OVERHEAD"
- do_cc DontCareCC = "DONT_CARE"
- do_cc (AllCafsCC m _) = if print_as_string
- then "CAFs_in_..."
- else "CAFs." ++ _UNPK_ m
- do_cc (AllDictsCC m _ d) = do_dupd d (
- if print_as_string
- then "DICTs_in_..."
- else "DICTs." ++ _UNPK_ m)
- do_cc PreludeCafsCC = if print_as_string
- then "CAFs_in_..."
- else "CAFs"
- do_cc (PreludeDictsCC d) = do_dupd d (
- if print_as_string
- then "DICTs_in_..."
- else "DICTs")
-
- do_cc (NormalCC kind mod_name grp_name is_dupd is_caf)
+ friendly_sty sty = userStyle sty || debugStyle sty -- i.e. probably for human consumption
+
+ do_cc sty DontCareCC = "DONT_CARE"
+ do_cc sty (AllCafsCC m _) = if print_as_string
+ then "CAFs_in_..."
+ else "CAFs." ++ _UNPK_ m
+ do_cc sty (AllDictsCC m _ d) = do_dupd sty d (
+ if print_as_string
+ then "DICTs_in_..."
+ else "DICTs." ++ _UNPK_ m)
+ do_cc sty PreludeCafsCC = if print_as_string
+ then "CAFs_in_..."
+ else "CAFs"
+ do_cc sty (PreludeDictsCC d) = do_dupd sty d (
+ if print_as_string
+ then "DICTs_in_..."
+ else "DICTs")
+
+ do_cc sty (NormalCC kind mod_name grp_name is_dupd is_caf)
= let
- basic_kind = do_kind kind
- is_a_calf = do_calved is_caf
+ basic_kind = do_kind kind
+ module_kind = do_caf is_caf (moduleString mod_name ++ '/':
+ basic_kind)
+ grp_str = []
+ {- TODO: re-instate this once interface file lexer
+ handles groups.
+ grp_str =
+ if (_NULL_ grp_name) then
+ []
+ else
+ '/' : (_UNPK_ grp_name)
+ -}
+ full_kind = do_caf is_caf
+ (moduleString mod_name ++
+ grp_str ++ ('/' : basic_kind))
in
- if friendly_sty then
- do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name) ++ is_a_calf)
- else
- basic_kind
+ if (friendly_sty sty) then
+ do_dupd sty is_dupd full_kind
+ else if codeStyle sty && print_as_string then
+ {-
+ drop the module name when printing
+ out SCC label in CC declaration
+ -}
+ basic_kind
+ else
+ module_kind
where
+ do_caf IsCafCC ls = "CAF:" ++ ls
+ do_caf _ ls = ls
+
do_kind (UserCC name) = _UNPK_ name
- do_kind (AutoCC id) = do_id id ++ (if friendly_sty then "/AUTO" else "")
- do_kind (DictCC id) = do_id id ++ (if friendly_sty then "/DICT" else "")
+ do_kind (AutoCC id) = do_id id ++ (if (debugStyle sty) then "/AUTO" else "")
+ do_kind (DictCC id) = do_id id ++ (if (debugStyle sty) then "/DICT" else "")
+ {-
+ do_id is only applied in a (not print_as_string) context for local ids,
+ hence using the occurrence name is enough.
+ -}
do_id :: Id -> String
- do_id id
- = if print_as_string
- then _UNPK_ (getOccurrenceName id) -- don't want module in the name
- else showId sty id -- we really do
-
- do_calved IsCafCC = "/CAF"
- do_calved _ = ""
+ do_id id = getOccString id
---------------
- do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str
- do_dupd _ str = str
-
-friendly_style sty -- i.e., probably for human consumption
- = case sty of
- PprForUser -> True
- PprDebug -> True
- PprShowAll -> True
- _ -> False
+ do_dupd sty ADupdCC str = if (friendly_sty sty) then str ++ "/DUPD" else str
+ do_dupd _ _ str = str
\end{code}
Printing unfoldings is sufficiently weird that we do it separately.
This should only apply to CostCentres that can be ``set to'' (cf
-@setToAbleCostCentre@). That excludes CAFs and
+@sccAbleCostCentre@). That excludes CAFs and
`overhead'---which are added at the very end---but includes dictionaries.
Dict \tr{_scc_}s may cross module boundaries to show ``scope'' info;
even if we won't ultimately do a \tr{SET_CCC} from it.
\begin{code}
+{- UNUSED
upp_cc_uf (PreludeDictsCC d)
- = uppCat [uppPStr SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d]
+ = hsep [ptext SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d]
upp_cc_uf (AllDictsCC m g d)
- = uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), upp_dupd d]
+ = hsep [ptext SLIT("_ALL_DICTS_CC_"),
+ char '"',ptext m,char '"',
+ char '"',ptext g,char '"',
+ upp_dupd d]
upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf)
- = ASSERT(isDictCC cc || setToAbleCostCentre cc)
- uppCat [pp_kind cc_kind, uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)),
+ = ASSERT(sccAbleCostCentre cc)
+ hsep [pp_kind cc_kind,
+ char '"', ptext m, char '"',
+ char '"', ptext g, char '"',
upp_dupd is_dupd, pp_caf is_caf]
where
- pp_kind (UserCC name) = uppBeside (uppPStr SLIT("_USER_CC_ ")) (uppStr (show (_UNPK_ name)))
- pp_kind (AutoCC id) = uppBeside (uppPStr SLIT("_AUTO_CC_ ")) (show_id id)
- pp_kind (DictCC id) = uppBeside (uppPStr SLIT("_DICT_CC_ ")) (show_id id)
+ pp_kind (UserCC name) = hcat [ptext SLIT("_USER_CC_ "), char '"', ptext name, char '"']
+ pp_kind (AutoCC id) = (<>) (ptext SLIT("_AUTO_CC_ ")) (show_id id)
+ pp_kind (DictCC id) = (<>) (ptext SLIT("_DICT_CC_ ")) (show_id id)
- show_id id = prettyToUn (pprIdInUnfolding no_in_scopes id)
- where
- no_in_scopes = emptyUniqSet
+ show_id id = pprIdInUnfolding {-no_in_scopes-} id
- pp_caf IsCafCC = uppPStr SLIT("_CAF_CC_")
- pp_caf IsNotCafCC = uppPStr SLIT("_N_")
+ pp_caf IsCafCC = ptext SLIT("_CAF_CC_")
+ pp_caf IsNotCafCC = ptext SLIT("_N_")
#ifdef DEBUG
-upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre PprDebug True other))
+upp_cc_uf other = panic ("upp_cc_uf:"++(showCostCentre True other))
#endif
-upp_dupd AnOriginalCC = uppPStr SLIT("_N_")
-upp_dupd ADupdCC = uppPStr SLIT("_DUPD_CC_")
+pprIdInUnfolding = panic "Whoops"
+
+upp_dupd AnOriginalCC = ptext SLIT("_N_")
+upp_dupd ADupdCC = ptext SLIT("_D_")
+-}
\end{code}
\begin{code}
-uppCostCentreDecl sty is_local cc
+uppCostCentreDecl is_local cc
#ifdef DEBUG
| noCostCentreAttached cc || currentOrSubsumedCosts cc
= panic "uppCostCentreDecl: no cost centre!"
| otherwise
#endif
= if is_local then
- uppBesides [
- uppStr "CC_DECLARE(",
- upp_ident, uppComma,
- uppCostCentre sty True {-as String!-} cc, uppComma,
- pp_str mod_name, uppComma,
- pp_str grp_name, uppComma,
- uppStr is_subsumed, uppComma,
- if externally_visible then uppNil else uppPStr SLIT("static"),
- uppStr ");"]
+ hcat [
+ ptext SLIT("CC_DECLARE"),char '(',
+ upp_ident, comma,
+ uppCostCentre True {-as String!-} cc, comma,
+ pp_str mod_name, comma,
+ pp_str grp_name, comma,
+ text is_subsumed, comma,
+ if externally_visible {- || all_toplev_ids_visible -}
+ -- all_toplev stuff removed SLPJ Sept 97;
+ -- not sure this is right.
+ then empty
+ else ptext SLIT("static"),
+ text ");"]
else
- uppBesides [ uppStr "CC_EXTERN(", upp_ident, uppStr ");" ]
+ hcat [ ptext SLIT("CC_EXTERN"),char '(', upp_ident, text ");" ]
where
- upp_ident = uppCostCentre sty False{-as identifier!-} cc
+ upp_ident = uppCostCentre False{-as identifier!-} cc
- pp_str s = uppBeside (uppPStr (_CONS_ '"' s)) (uppChar '"')
- pp_char c = uppBeside (uppPStr (_CONS_ '\'' c)) (uppChar '\'')
+ pp_str s = doubleQuotes (ptext s)
(mod_name, grp_name, is_subsumed, externally_visible)
= case cc of
where
cc_IS_CAF = "CC_IS_CAF"
cc_IS_DICT = "CC_IS_DICT"
- cc_IS_SUBSUMED = "CC_IS_SUBSUMED"
cc_IS_BORING = "CC_IS_BORING"
do_caf IsCafCC = cc_IS_CAF
projects / ghc-hetmet.git / blobdiff