X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;ds=sidebyside;f=ghc%2Fcompiler%2Fprofiling%2FCostCentre.lhs;h=d04e25515d1a7128b2fed73e4c17bb155f904735;hb=bff3893a94f6ae180c5c9c039e9ce05e1ceaa531;hp=c74a66b84d8b310cc2cad113a5d55928f154dea9;hpb=f8d1d20eb4779a42e72b6a06c47d6e0f13075bf4;p=ghc-hetmet.git diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index c74a66b..d04e255 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -4,13 +4,11 @@ \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, @@ -28,17 +26,14 @@ module CostCentre ( cmpCostCentre -- used for removing dups in a list ) where -IMP_Ubiq(){-uitous-} +#include "HsVersions.h" -import Id ( externallyVisibleId, GenId, showId, SYN_IE(Id) ) +import Id ( externallyVisibleId, GenId, Id ) import CStrings ( identToC, stringToC ) import Name ( OccName, getOccString, moduleString ) -import PprStyle ( PprStyle(..), codeStyle, ifaceStyle ) -import UniqSet -import Pretty -import Util +import Outputable +import Util ( panic, panic#, assertPanic, thenCmp ) -pprIdInUnfolding = panic "Whoops" \end{code} \begin{code} @@ -151,6 +146,9 @@ preludeDictsCostCentre is_dupd noCostCentreAttached NoCostCentre = True noCostCentreAttached _ = False +isCurrentCostCentre CurrentCC = True +isCurrentCostCentre _ = False + costsAreSubsumed SubsumedCosts = True costsAreSubsumed _ = False @@ -188,13 +186,13 @@ cafifyCC (NormalCC kind m g is_dupd is_caf) where not_a_calf_already IsCafCC = False not_a_calf_already _ = True -cafifyCC cc = panic ("cafifyCC"++(showCostCentre PprDebug False 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 @@ -262,26 +260,26 @@ ccMentionsId other = Nothing \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) and finally the caf flag - = _CMP_STRING_ m1 m2 `thenCmp` cmp_kind k1 k2 `thenCmp` cmp_caf c1 c2 + = (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) @@ -297,30 +295,30 @@ cmpCostCentre other_1 other_2 tag_CC CurrentCC = panic# "tag_CC:SubsumedCosts" -cmp_kind (UserCC n1) (UserCC n2) = _CMP_STRING_ n1 n2 -cmp_kind (AutoCC i1) (AutoCC i2) = cmp i1 i2 -cmp_kind (DictCC i1) (DictCC i2) = cmp 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_ +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 -> Doc -uppCostCentreDecl :: PprStyle -> Bool -> CostCentre -> Doc +showCostCentre :: Bool -> CostCentre -> String +uppCostCentre :: Bool -> CostCentre -> SDoc +uppCostCentreDecl :: Bool -> CostCentre -> SDoc {- PprUnfolding is gone now showCostCentre PprUnfolding print_as_string cc @@ -330,80 +328,93 @@ showCostCentre PprUnfolding print_as_string cc uppShow 80 (upp_cc_uf cc) -} -showCostCentre sty print_as_string cc - = show (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 = empty +uppCostCentre print_as_string NoCostCentre | print_as_string = text "\"NO_CC\"" | otherwise = ptext SLIT("NO_CC") -uppCostCentre sty print_as_string SubsumedCosts +uppCostCentre print_as_string SubsumedCosts | print_as_string = text "\"SUBSUMED\"" | otherwise = ptext SLIT("CC_SUBSUMED") -uppCostCentre sty print_as_string CurrentCC +uppCostCentre print_as_string CurrentCC | print_as_string = text "\"CURRENT_CC\"" | otherwise = ptext SLIT("CCC") -uppCostCentre sty print_as_string OverheadCC +uppCostCentre print_as_string OverheadCC | print_as_string = text "\"OVERHEAD\"" | otherwise = ptext SLIT("CC_OVERHEAD") -uppCostCentre sty print_as_string cc - = let - prefix_CC = ptext SLIT("CC_") - - basic_thing = 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 hcat [char '"', text basic_thing_string, char '"'] - else if friendly_sty then + else if (friendly_sty sty) then text basic_thing else hcat [prefix_CC, identToC (_PK_ basic_thing)] where - friendly_sty = friendly_style sty - - ---------------- - 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_caf is_caf ++ - moduleString mod_name ++ - ('/' : _UNPK_ grp_name) ++ - ('/' : do_kind kind) + 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 - 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 = "CAF:" - do_caf _ = "" + 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, @@ -413,11 +424,8 @@ uppCostCentre sty print_as_string cc 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 - = not (codeStyle sty || ifaceStyle sty) + do_dupd sty ADupdCC str = if (debugStyle sty) then str ++ "/DUPD" else str + do_dupd _ _ str = str \end{code} Printing unfoldings is sufficiently weird that we do it separately. @@ -427,6 +435,7 @@ This should only apply to CostCentres that can be ``set to'' (cf 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) = hsep [ptext SLIT("_PRELUDE_DICTS_CC_"), upp_dupd d] upp_cc_uf (AllDictsCC m g d) @@ -446,23 +455,24 @@ upp_cc_uf cc@(NormalCC cc_kind m g is_dupd is_caf) 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 = pprIdInUnfolding no_in_scopes id - where - no_in_scopes = emptyUniqSet + show_id id = pprIdInUnfolding {-no_in_scopes-} id 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 +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!" @@ -472,16 +482,20 @@ uppCostCentreDecl sty is_local cc hcat [ ptext SLIT("CC_DECLARE"),char '(', upp_ident, comma, - uppCostCentre sty True {-as String!-} cc, comma, + uppCostCentre True {-as String!-} cc, comma, pp_str mod_name, comma, pp_str grp_name, comma, text is_subsumed, comma, - if externally_visible then empty else ptext SLIT("static"), + 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 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 = doubleQuotes (ptext s) @@ -500,7 +514,6 @@ uppCostCentreDecl sty is_local cc 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