X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprofiling%2FCostCentre.lhs;h=46fd3c362b21a816ef34b136cce37b66e2e5305b;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=1d7e73bc72cc58e41f472ec222066c74cd947f83;hpb=d01e768b927a536f36f8727f634a5e6e48e914e3;p=ghc-hetmet.git diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 1d7e73b..46fd3c3 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -9,18 +9,22 @@ module CostCentre ( -- 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, mkAllCafsCC, - mkSingletonCCS, cafifyCC, dupifyCC, - isCafCC, isDupdCC, isEmptyCC, isCafCCS, + mkSingletonCCS, dupifyCC, pushCCOnCCS, + isCafCCS, isCafCC, isSccCountCostCentre, sccAbleCostCentre, ccFromThisModule, - pprCostCentreDecl, pprCostCentreStackDecl, pprCostCentreCore, + pprCostCentreCore, + costCentreUserName, cmpCostCentre -- used for removing dups in a list ) where @@ -31,8 +35,10 @@ import Var ( Id ) import Name ( UserFS, EncodedFS, encodeFS, decode, getOccName, occNameFS ) -import Module ( Module, pprModule, moduleUserString ) +import Module ( Module, ModuleName, moduleName ) import Outputable +import FastTypes +import FastString import Util ( thenCmp ) \end{code} @@ -81,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} @@ -96,26 +105,19 @@ data CostCentreStack A Cost Centre is the argument of an _scc_ expression. \begin{code} -type Group = FAST_STRING -- "Group" that this CC is in; eg directory - data CostCentre = NoCostCentre -- Having this constructor avoids having -- to use "Maybe CostCentre" all the time. | NormalCC { - cc_name :: CcName, -- Name of the cost centre itself - cc_mod :: Module, -- Name of module defining this CC. - cc_grp :: Group, -- "Group" that this CC is in. - cc_is_dupd :: IsDupdCC, -- see below - cc_is_caf :: IsCafCC -- see below + 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 :: Module, -- Name of module defining this CC. - cc_grp :: Group -- "Group" that this CC is in - -- Again, one "big" CAF cc per module, where all - -- CAF costs are attributed unless the user asked for - -- per-individual-CAF cost attribution. + cc_mod :: ModuleName -- Name of module defining this CC. } type CcName = EncodedFS @@ -137,6 +139,14 @@ data IsDupdCC -- "dupd". 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 @@ -172,54 +182,49 @@ isCurrentCCS _ = False isSubsumedCCS SubsumedCCS = True isSubsumedCCS _ = False -isCafCCS (SingletonCCS cc) = isCafCC cc +isCafCCS (PushCC cc NoCCS) = isCafCC cc isCafCCS _ = 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 :: UserFS -> Module -> Group -> CostCentre - -mkUserCC cc_name module_name group_name - = NormalCC { cc_name = encodeFS cc_name, - cc_mod = module_name, cc_grp = group_name, +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-} } -mkAutoCC :: Id -> Module -> Group -> IsCafCC -> CostCentre - -mkAutoCC id module_name group_name is_caf - = NormalCC { cc_name = occNameFS (getOccName id), - cc_mod = module_name, cc_grp = group_name, +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 } -mkAllCafsCC m g = AllCafsCC { cc_mod = m, cc_grp = g } +mkAllCafsCC m = AllCafsCC { cc_mod = moduleName m } -mkSingletonCCS :: CostCentre -> CostCentreStack -mkSingletonCCS cc = SingletonCCS cc -cafifyCC, dupifyCC :: CostCentre -> CostCentre -cafifyCC cc@(NormalCC {cc_is_caf = is_caf}) - = ASSERT(not_a_caf_already is_caf) - cc {cc_is_caf = CafCC} - where - not_a_caf_already CafCC = False - not_a_caf_already _ = True -cafifyCC cc = pprPanic "cafifyCC" (ppr cc) +mkSingletonCCS :: CostCentre -> CostCentreStack +mkSingletonCCS cc = pushCCOnCCS cc NoCCS -dupifyCC cc = cc {cc_is_dupd = DupdCC} +pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack +pushCCOnCCS = PushCC -isEmptyCC, isCafCC, isDupdCC :: CostCentre -> Bool +dupifyCC cc = cc {cc_is_dupd = DupdCC} -isEmptyCC (NoCostCentre) = True -isEmptyCC _ = False +isCafCC, isDupdCC :: CostCentre -> Bool isCafCC (AllCafsCC {}) = True isCafCC (NormalCC {cc_is_caf = CafCC}) = True @@ -248,7 +253,7 @@ sccAbleCostCentre cc | isCafCC cc = False | otherwise = True ccFromThisModule :: CostCentre -> Module -> Bool -ccFromThisModule cc m = cc_mod cc == m +ccFromThisModule cc m = cc_mod cc == moduleName m \end{code} \begin{code} @@ -273,50 +278,44 @@ cmpCostCentre other_1 other_2 tag1 = tag_CC other_1 tag2 = tag_CC other_2 in - if tag1 _LT_ tag2 then LT else GT + if tag1 <# tag2 then LT else GT where - tag_CC (NormalCC {}) = (ILIT(1) :: FAST_INT) - tag_CC (AllCafsCC {}) = ILIT(2) + 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 -> ptext SLIT("CCS_") <> ppr cc - -pprCostCentreStackDecl :: CostCentreStack -> SDoc -pprCostCentreStackDecl ccs@(SingletonCCS cc) - = let - is_subsumed = ccSubsumed cc - in - hcat [ ptext SLIT("CCS_DECLARE"), char '(', - ppr ccs, comma, -- better be codeStyle - ppCostCentreLbl cc, comma, - ptext is_subsumed, comma, - empty, -- Now always externally visible - 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} ----------------------------------------------------------------------------- @@ -341,14 +340,13 @@ instance Outputable CostCentre where else text (costCentreUserName cc) -- Printing in an interface file or in Core generally -pprCostCentreCore (AllCafsCC {cc_mod = m, cc_grp = g}) - = text "__sccC" <+> braces (pprModule m <+> doubleQuotes (ptext g)) -pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, cc_grp = g, +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 [ - ptext n, - pprModule m, - doubleQuotes (ptext g), + ftext n, + ppr m, pp_dup dup, pp_caf caf ]) @@ -361,47 +359,16 @@ pp_caf other = empty -- Printing as a C label -ppCostCentreLbl (NoCostCentre) = text "CC_NONE" -ppCostCentreLbl (AllCafsCC {cc_mod = m}) = text "CC_CAFs_" <> pprModule m +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}) - = text "CC_" <> text (case is_caf of { CafCC -> "CAF_"; _ -> "" }) - <> pprModule m <> ptext n + = 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 {}) = "CAFs_in_..." +costCentreUserName (AllCafsCC {}) = "CAF" costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf}) - = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (_UNPK_ name) -\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, - doubleQuotes (text (costCentreUserName cc)), comma, - doubleQuotes (text (moduleUserString mod_name)), comma, - doubleQuotes (ptext grp_name), comma, - ptext is_subsumed, comma, - empty, -- Now always externally visible - text ");"] - else - hcat [ ptext SLIT("CC_EXTERN"),char '(', cc_ident, text ");" ] - where - cc_ident = ppCostCentreLbl cc - mod_name = cc_mod cc - grp_name = cc_grp cc - is_subsumed = ccSubsumed cc - -ccSubsumed :: CostCentre -> FAST_STRING -- subsumed value -ccSubsumed cc | isCafCC cc = SLIT("CC_IS_CAF") - | otherwise = SLIT("CC_IS_BORING") + = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ decode (unpackFS name) \end{code}