%
-% (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
+% (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
%
\section[CostCentre]{The @CostCentre@ data type}
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
+IMP_Ubiq(){-uitous-}
+
+import Id ( externallyVisibleId, GenId, SYN_IE(Id) )
+import CStrings ( identToC, stringToC )
+import Name ( showRdr, getOccName, RdrName )
import Pretty ( ppShow, prettyToUn )
+import PprStyle ( PprStyle(..) )
import UniqSet
import Unpretty
import Util
+
+showId = panic "Whoops"
+pprIdInUnfolding = panic "Whoops"
\end{code}
\begin{code}
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
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
-
dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC
dupifyCC (PreludeDictsCC _) = PreludeDictsCC ADupdCC
dupifyCC (NormalCC kind m g is_dupd is_caf)
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
-setToAbleCostCentre OverheadCC = False -- see comments in type defn
-setToAbleCostCentre other = not (isCafCC other || isDictCC other)
+sccAbleCostCentre :: CostCentre -> Bool
+ -- Is this a cost-centre which can be sccd ?
+
+#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
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
+ = _CMP_STRING_ m1 m2 `thenCmp` cmp_kind k1 k2 `thenCmp` cmp_caf c1 c2
cmpCostCentre other_1 other_2
= let
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 (AutoCC i1) (AutoCC i2) = cmp i1 i2
+cmp_kind (DictCC i1) (DictCC i2) = cmp i1 i2
cmp_kind other_1 other_2
= let
tag1 = tag_CcKind other_1
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}
uppCostCentre :: PprStyle -> Bool -> CostCentre -> Unpretty
uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Unpretty
-showCostCentre (PprUnfolding _) print_as_string cc
+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))
= let
prefix_CC = uppPStr SLIT("CC_")
- basic_thing -- (basic_thing, suffix_CAF)
- = do_cc cc
+ basic_thing = do_cc cc
basic_thing_string
= if friendly_sty then basic_thing else stringToC 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 (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_caf is_caf ++ do_kind kind
in
if friendly_sty then
- do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name) ++ is_a_calf)
+ do_dupd is_dupd (basic_kind ++ ('/': _UNPK_ mod_name) ++ ('/': _UNPK_ grp_name))
else
basic_kind
where
+ do_caf IsCafCC = "CAF:"
+ do_caf _ = ""
+
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_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 _ = ""
+ then showRdr sty (getOccName id) -- use occ name
+ else showId sty id -- we really do
---------------
do_dupd ADupdCC str = if friendly_sty then str ++ "/DUPD" else str
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.
= uppCat [uppPStr SLIT("_ALL_DICTS_CC_"), uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)), upp_dupd d]
upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf)
- = ASSERT(isDictCC cc || setToAbleCostCentre cc)
+ = ASSERT(sccAbleCostCentre cc)
uppCat [pp_kind cc_kind, uppStr (show (_UNPK_ m)), uppStr (show (_UNPK_ g)),
upp_dupd is_dupd, pp_caf is_caf]
where
projects / ghc-hetmet.git / blobdiff