X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprofiling%2FCostCentre.lhs;h=46fd3c362b21a816ef34b136cce37b66e2e5305b;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=0476159b71253784fe1c091aadd91bd45eb65598;hpb=438596897ebbe25a07e1c82085cfbc5bdb00f09e;p=ghc-hetmet.git diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 0476159..46fd3c3 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -5,33 +5,41 @@ \begin{code} module CostCentre ( - CostCentre, CcKind, IsDupdCC{-ToDo:rm-}, IsCafCC(..), + CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..), + -- All abstract except to friend: ParseIface.y + CostCentreStack, + CollectedCCs, noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS, noCostCentre, noCCAttached, noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS, + isDerivedFromCurrentCCS, maybeSingletonCCS, + decomposeCCS, - mkUserCC, mkAutoCC, mkDictCC, mkAllCafsCC, mkAllDictsCC, - mkSingletonCCS, cafifyCC, dupifyCC, - isCafCC, isDictCC, isDupdCC, isEmptyCC, isCafCCS, + mkUserCC, mkAutoCC, mkAllCafsCC, + mkSingletonCCS, dupifyCC, pushCCOnCCS, + isCafCCS, isCafCC, isSccCountCostCentre, sccAbleCostCentre, ccFromThisModule, - ccMentionsId, - pprCostCentreDecl, pprCostCentreStackDecl, + pprCostCentreCore, + costCentreUserName, cmpCostCentre -- used for removing dups in a list ) where #include "HsVersions.h" -import Var ( externallyVisibleId, GenId, Id ) -import CStrings ( identToC, stringToC ) -import Name ( getOccString ) +import Var ( Id ) +import Name ( UserFS, EncodedFS, encodeFS, decode, + getOccName, occNameFS + ) +import Module ( Module, ModuleName, moduleName ) import Outputable -import BasicTypes ( moduleString ) -import Util ( panic, assertPanic, thenCmp ) +import FastTypes +import FastString +import Util ( thenCmp ) \end{code} A Cost Centre Stack is something that can be attached to a closure. @@ -79,14 +87,17 @@ data CostCentreStack -- accumulate any costs. But we still need -- the placeholder. This CCS is it. - | SingletonCCS CostCentre - -- This is primarily for CAF cost centres, which - -- are attached to top-level thunks right at the - -- end of STG processing, before code generation. - -- Hence, a CAF cost centre never appears as the - -- argument of an _scc_. - -- Also, we generate these singleton CCSs statically - -- as part of code generation. + | PushCC CostCentre CostCentreStack + -- These are used during code generation as the CCSs + -- attached to closures. A PushCC never appears as + -- the argument to an _scc_. + -- + -- The tail (2nd argument) is either NoCCS, indicating + -- a staticly allocated CCS, or CurrentCCS indicating + -- a dynamically created CCS. We only support + -- statically allocated *singleton* CCSs at the + -- moment, for the purposes of initialising the CCS + -- field of a CAF. deriving (Eq, Ord) -- needed for Ord on CLabel \end{code} @@ -98,33 +109,22 @@ data CostCentre = NoCostCentre -- Having this constructor avoids having -- to use "Maybe CostCentre" all the time. - | NormalCC CcKind -- CcKind will include a cost-centre name - FAST_STRING -- Name of module defining this CC. - FAST_STRING -- "Group" that this CC is in. - IsDupdCC -- see below - IsCafCC -- see below - - | AllCafsCC FAST_STRING -- Ditto for CAFs. - FAST_STRING -- We record module and group names. - -- Again, one "big" CAF cc per module, where all - -- CAF costs are attributed unless the user asked for - -- per-individual-CAF cost attribution. - - | AllDictsCC FAST_STRING -- Ditto for dictionaries. - FAST_STRING -- We record module and group names. - -- Again, one "big" DICT cc per module, where all - -- DICT costs are attributed unless the user asked for - -- per-individual-DICT cost attribution. - IsDupdCC -- see below - -data CcKind - = UserCC FAST_STRING -- Supplied by user: String is the cc name - | AutoCC Id -- CC -auto-magically inserted for that Id - | DictCC Id + | NormalCC { + cc_name :: CcName, -- Name of the cost centre itself + cc_mod :: ModuleName, -- Name of module defining this CC. + cc_is_dupd :: IsDupdCC, -- see below + cc_is_caf :: IsCafCC -- see below + } + + | AllCafsCC { + cc_mod :: ModuleName -- Name of module defining this CC. + } + +type CcName = EncodedFS data IsDupdCC - = AnOriginalCC -- This says how the CC is *used*. Saying that - | ADupdCC -- it is ADupdCC doesn't make it a different + = OriginalCC -- This says how the CC is *used*. Saying that + | DupdCC -- it is DupdCC doesn't make it a different -- CC, just that it a sub-expression which has -- been moved ("dupd") into a different scope. -- @@ -133,14 +133,20 @@ data IsDupdCC -- "original" one. -- -- In the papers, it's called "SCCsub", - -- i.e. SCCsub CC == SCC ADupdCC, + -- i.e. SCCsub CC == SCC DupdCC, -- but we are trying to avoid confusion between -- "subd" and "subsumed". So we call the former -- "dupd". -data IsCafCC - = IsCafCC - | IsNotCafCC +data IsCafCC = CafCC | NotCafCC + +-- synonym for triple which describes the cost centre info in the generated +-- code for a module. +type CollectedCCs + = ( [CostCentre] -- local cost-centres that need to be decl'd + , [CostCentre] -- "extern" cost-centres + , [CostCentreStack] -- pre-defined "singleton" cost centre stacks + ) \end{code} WILL: Would there be any merit to recording ``I am now using a @@ -176,75 +182,56 @@ isCurrentCCS _ = False isSubsumedCCS SubsumedCCS = True isSubsumedCCS _ = False -isCafCCS (SingletonCCS cc) = isCafCC cc +isCafCCS (PushCC cc NoCCS) = isCafCC cc isCafCCS _ = False -isDictCCS (SingletonCCS cc) = isDictCC cc -isDictCCS _ = False +isDerivedFromCurrentCCS CurrentCCS = True +isDerivedFromCurrentCCS (PushCC _ ccs) = isDerivedFromCurrentCCS ccs +isDerivedFromCurrentCCS _ = False currentOrSubsumedCCS SubsumedCCS = True currentOrSubsumedCCS CurrentCCS = True currentOrSubsumedCCS _ = False + +maybeSingletonCCS (PushCC cc NoCCS) = Just cc +maybeSingletonCCS _ = Nothing \end{code} Building cost centres \begin{code} -mkUserCC :: FAST_STRING -> FAST_STRING -> FAST_STRING -> CostCentre +mkUserCC :: UserFS -> Module -> CostCentre +mkUserCC cc_name mod + = NormalCC { cc_name = encodeFS cc_name, cc_mod = moduleName mod, + cc_is_dupd = OriginalCC, cc_is_caf = NotCafCC {-might be changed-} + } -mkUserCC cc_name module_name group_name - = NormalCC (UserCC cc_name) module_name group_name - AnOriginalCC IsNotCafCC{-might be changed-} +mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre +mkAutoCC id mod is_caf + = NormalCC { cc_name = occNameFS (getOccName id), cc_mod = moduleName mod, + cc_is_dupd = OriginalCC, cc_is_caf = is_caf + } -mkDictCC, mkAutoCC :: Id -> FAST_STRING -> FAST_STRING -> IsCafCC -> CostCentre +mkAllCafsCC m = AllCafsCC { cc_mod = moduleName m } -mkDictCC id module_name group_name is_caf - = NormalCC (DictCC id) module_name group_name - AnOriginalCC is_caf -mkAutoCC id module_name group_name is_caf - = NormalCC (AutoCC id) module_name group_name - AnOriginalCC is_caf - -mkAllCafsCC m g = AllCafsCC m g -mkAllDictsCC m g is_dupd - = AllDictsCC m g (if is_dupd then ADupdCC else AnOriginalCC) mkSingletonCCS :: CostCentre -> CostCentreStack -mkSingletonCCS cc = SingletonCCS cc - -cafifyCC, dupifyCC :: CostCentre -> CostCentre - -cafifyCC cc@(AllDictsCC _ _ _) = cc -- ToDo ??? -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 = pprPanic "cafifyCC" (ppr cc) +mkSingletonCCS cc = pushCCOnCCS cc NoCCS -dupifyCC (AllDictsCC m g _) = AllDictsCC m g ADupdCC -dupifyCC (NormalCC kind m g is_dupd is_caf) - = NormalCC kind m g ADupdCC is_caf -dupifyCC cc = pprPanic "dupifyCC" (ppr cc) +pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack +pushCCOnCCS = PushCC -isEmptyCC, isCafCC, isDictCC, isDupdCC :: CostCentre -> Bool +dupifyCC cc = cc {cc_is_dupd = DupdCC} -isEmptyCC (NoCostCentre) = True -isEmptyCC _ = False +isCafCC, isDupdCC :: CostCentre -> Bool -isCafCC (AllCafsCC _ _) = True -isCafCC (NormalCC _ _ _ _ IsCafCC) = True -isCafCC _ = False +isCafCC (AllCafsCC {}) = True +isCafCC (NormalCC {cc_is_caf = CafCC}) = True +isCafCC _ = False -isDictCC (AllDictsCC _ _ _) = True -isDictCC (NormalCC (DictCC _) _ _ _ _) = True -isDictCC _ = False - -isDupdCC (AllDictsCC _ _ ADupdCC) = True -isDupdCC (NormalCC _ _ _ ADupdCC _) = True -isDupdCC _ = False +isDupdCC (NormalCC {cc_is_dupd = DupdCC}) = True +isDupdCC _ = False isSccCountCostCentre :: CostCentre -> Bool -- Is this a cost-centre which records scc counts @@ -254,7 +241,6 @@ isSccCountCostCentre NoCostCentre = panic "isSccCount:NoCostCentre" #endif isSccCountCostCentre cc | isCafCC cc = False | isDupdCC cc = False - | isDictCC cc = True | otherwise = True sccAbleCostCentre :: CostCentre -> Bool @@ -266,19 +252,8 @@ sccAbleCostCentre NoCostCentre = panic "sccAbleCC:NoCostCentre" sccAbleCostCentre cc | isCafCC cc = False | otherwise = True -ccFromThisModule :: CostCentre -> FAST_STRING{-module name-} -> Bool - -ccFromThisModule (NormalCC _ m _ _ _) mod_name = m == mod_name -ccFromThisModule (AllCafsCC m _) mod_name = m == mod_name -ccFromThisModule (AllDictsCC m _ _) mod_name = m == mod_name -\end{code} - -\begin{code} -ccMentionsId :: CostCentre -> Maybe Id - -ccMentionsId (NormalCC (AutoCC id) _ _ _ _) = Just id -ccMentionsId (NormalCC (DictCC id) _ _ _ _) = Just id -ccMentionsId other = Nothing +ccFromThisModule :: CostCentre -> Module -> Bool +ccFromThisModule cc m = cc_mod cc == moduleName m \end{code} \begin{code} @@ -290,86 +265,57 @@ instance Ord CostCentre where cmpCostCentre :: CostCentre -> CostCentre -> Ordering -cmpCostCentre (AllCafsCC m1 _) (AllCafsCC m2 _) = m1 `compare` m2 -cmpCostCentre (AllDictsCC m1 _ _) (AllDictsCC m2 _ _) = m1 `compare` m2 +cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2}) = m1 `compare` m2 -cmpCostCentre (NormalCC k1 m1 _ _ c1) (NormalCC k2 m2 _ _ c2) +cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1}) + (NormalCC {cc_name = n2, cc_mod = m2, cc_is_caf = c2}) -- first key is module name, then we use "kinds" (which include -- names) and finally the caf flag - = (m1 `compare` m2) `thenCmp` (k1 `cmp_kind` k2) `thenCmp` (c1 `cmp_caf` c2) + = (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `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 - where - tag_CC (NormalCC _ _ _ _ _) = (ILIT(1) :: FAST_INT) - tag_CC (AllCafsCC _ _) = ILIT(2) - tag_CC (AllDictsCC _ _ _) = ILIT(3) - -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 <# 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 + tag_CC (NormalCC {}) = (_ILIT 1 :: FastInt) + tag_CC (AllCafsCC {}) = _ILIT 2 + +cmp_caf NotCafCC CafCC = LT +cmp_caf NotCafCC NotCafCC = EQ +cmp_caf CafCC CafCC = EQ +cmp_caf CafCC NotCafCC = GT + +decomposeCCS :: CostCentreStack -> ([CostCentre],CostCentreStack) +decomposeCCS (PushCC cc ccs) = (cc:more, ccs') + where (more,ccs') = decomposeCCS ccs +decomposeCCS ccs = ([],ccs) \end{code} ----------------------------------------------------------------------------- Printing Cost Centre Stacks. -There are two ways to print a CCS: +The outputable instance for CostCentreStack prints the CCS as a C +expression. - - for debugging output (i.e. -ddump-whatever), - - as a C label +NOTE: Not all cost centres are suitable for using in a static +initializer. In particular, the PushCC forms where the tail is CCCS +may only be used in inline C code because they expand to a +non-constant C expression. \begin{code} instance Outputable CostCentreStack where - ppr ccs = case ccs of - NoCCS -> ptext SLIT("NO_CCS") - CurrentCCS -> ptext SLIT("CCCS") - OverheadCCS -> ptext SLIT("CCS_OVERHEAD") - DontCareCCS -> ptext SLIT("CCS_DONTZuCARE") - SubsumedCCS -> ptext SLIT("CCS_SUBSUMED") - SingletonCCS cc -> - getPprStyle $ \sty -> - if (codeStyle sty) - then ptext SLIT("CCS_") <> - identToC (_PK_ (costCentreStr cc)) - else ptext SLIT("CCS.") <> text (costCentreStr cc) - -pprCostCentreStackDecl :: CostCentreStack -> SDoc - -pprCostCentreStackDecl ccs@(SingletonCCS cc) - = let - (mod_name, grp_name, is_subsumed, externally_visible) = get_cc_info cc - in - hcat [ ptext SLIT("CCS_DECLARE"), char '(', - ppr ccs, comma, -- better be codeStyle - ppCostCentreLbl cc, comma, - ptext is_subsumed, comma, - if externally_visible - then empty - else ptext SLIT("static"), - text ");" - ] - -pprCostCentreStackDecl ccs - = pprPanic "pprCostCentreStackDecl: " (ppr ccs) + ppr NoCCS = ptext SLIT("NO_CCS") + ppr CurrentCCS = ptext SLIT("CCCS") + ppr OverheadCCS = ptext SLIT("CCS_OVERHEAD") + ppr DontCareCCS = ptext SLIT("CCS_DONT_CARE") + ppr SubsumedCCS = ptext SLIT("CCS_SUBSUMED") + ppr (PushCC cc NoCCS) = ppr cc <> ptext SLIT("_ccs") + ppr (PushCC cc ccs) = ptext SLIT("PushCostCentre") <> + parens (ppr ccs <> comma <> + parens(ptext SLIT("void *")) <> ppr cc) \end{code} ----------------------------------------------------------------------------- @@ -390,95 +336,39 @@ by costCentreName. instance Outputable CostCentre where ppr cc = getPprStyle $ \ sty -> if codeStyle sty - then ppCostCentreLbl cc - else - if ifaceStyle sty - then ppCostCentreIface cc - else text (costCentreStr cc) - -ppCostCentreLbl cc = ptext SLIT("CC_") <> identToC (_PK_ (costCentreStr cc)) -ppCostCentreIface cc = doubleQuotes (text (costCentreStr cc)) -ppCostCentreName cc = doubleQuotes (text (stringToC (costCentreName cc))) - -costCentreStr (NoCostCentre) = "NO_CC" -costCentreStr (AllCafsCC m _) = "CAFs." ++ _UNPK_ m -costCentreStr (AllDictsCC m _ d) = "DICTs." ++ _UNPK_ m -costCentreStr (NormalCC kind mod_name grp_name is_dupd is_caf) - = case is_caf of { IsCafCC -> "CAF:"; _ -> "" } - ++ moduleString mod_name - ++ case kind of { UserCC name -> _UNPK_ name; - AutoCC id -> getOccString id ++ "/AUTO"; - DictCC id -> getOccString id ++ "/DICT" - } - -- ToDo: group name - ++ case is_dupd of { ADupdCC -> "/DUPD"; _ -> "" } - --- This is the name to go in the cost centre declaration -costCentreName (NoCostCentre) = "NO_CC" -costCentreName (AllCafsCC _ _) = "CAFs_in_..." -costCentreName (AllDictsCC _ _ _) = "DICTs_in_..." -costCentreName (NormalCC kind mod_name grp_name is_dupd is_caf) - = case is_caf of { IsCafCC -> "CAF:"; _ -> "" } - ++ case kind of { UserCC name -> _UNPK_ name; - AutoCC id -> getOccString id; - DictCC id -> getOccString id - } -\end{code} - -Cost Centre Declarations - -\begin{code} -#ifdef DEBUG -pprCostCentreDecl is_local (NoCostCentre) - = panic "pprCostCentreDecl: no cost centre!" -#endif -pprCostCentreDecl is_local cc - = if is_local then - hcat [ - ptext SLIT("CC_DECLARE"),char '(', - cc_ident, comma, - ppCostCentreName cc, comma, - pp_str mod_name, comma, - pp_str grp_name, comma, - ptext is_subsumed, comma, - if externally_visible - then empty - else ptext SLIT("static"), - text ");"] - else - hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ] - where - cc_ident = ppCostCentreLbl cc - - pp_str s = doubleQuotes (ptext s) - - (mod_name, grp_name, is_subsumed, externally_visible) - = get_cc_info cc - - -get_cc_info :: CostCentre -> - (FAST_STRING, -- module name - FAST_STRING, -- group name - FAST_STRING, -- subsumed value - Bool) -- externally visible - -get_cc_info cc - = case cc of - AllCafsCC m g -> (m, g, cc_IS_CAF, True) - - AllDictsCC m g _ -> (m, g, cc_IS_DICT, True) - - NormalCC (DictCC i) m g is_dupd is_caf - -> (m, g, cc_IS_DICT, externallyVisibleId i) - - NormalCC x m g is_dupd is_caf - -> (m, g, do_caf is_caf, - case x of { UserCC _ -> True; AutoCC i -> externallyVisibleId i}) - where - cc_IS_CAF = SLIT("CC_IS_CAF") - cc_IS_DICT = SLIT("CC_IS_DICT") - cc_IS_BORING = SLIT("CC_IS_BORING") - - do_caf IsCafCC = cc_IS_CAF - do_caf IsNotCafCC = cc_IS_BORING + then ppCostCentreLbl cc + else text (costCentreUserName cc) + +-- Printing in an interface file or in Core generally +pprCostCentreCore (AllCafsCC {cc_mod = m}) + = text "__sccC" <+> braces (ppr m) +pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, + cc_is_caf = caf, cc_is_dupd = dup}) + = text "__scc" <+> braces (hsep [ + ftext n, + ppr m, + pp_dup dup, + pp_caf caf + ]) + +pp_dup DupdCC = char '!' +pp_dup other = empty + +pp_caf CafCC = text "__C" +pp_caf other = empty + + +-- Printing as a C label +ppCostCentreLbl (NoCostCentre) = text "NONE_cc" +ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc" +ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf}) + = ppr m <> ftext n <> + text (case is_caf of { CafCC -> "_CAF"; _ -> "" }) <> text "_cc" + +-- This is the name to go in the user-displayed string, +-- recorded in the cost centre declaration +costCentreUserName (NoCostCentre) = "NO_CC" +costCentreUserName (AllCafsCC {}) = "CAF" +costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf}) + = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (unpackFS name) \end{code}