X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2Fprofiling%2FCostCentre.lhs;h=46fd3c362b21a816ef34b136cce37b66e2e5305b;hb=423d477bfecd490de1449c59325c8776f91d7aac;hp=85c36be078d6394e4577511bc99483ddedba48d8;hpb=79abe0acae28895eeb8a762dcf5867b84982a27c;p=ghc-hetmet.git diff --git a/ghc/compiler/profiling/CostCentre.lhs b/ghc/compiler/profiling/CostCentre.lhs index 85c36be..46fd3c3 100644 --- a/ghc/compiler/profiling/CostCentre.lhs +++ b/ghc/compiler/profiling/CostCentre.lhs @@ -9,19 +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, + isDerivedFromCurrentCCS, maybeSingletonCCS, + decomposeCCS, mkUserCC, mkAutoCC, mkAllCafsCC, - mkSingletonCCS, cafifyCC, dupifyCC, pushCCOnCCS, - 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 @@ -32,12 +35,10 @@ import Var ( Id ) import Name ( UserFS, EncodedFS, encodeFS, decode, getOccName, occNameFS ) -import Module ( Module, ModuleName, moduleName, - moduleNameUserString - ) +import Module ( Module, ModuleName, moduleName ) import Outputable -import CStrings ( pprStringInCStyle ) import FastTypes +import FastString import Util ( thenCmp ) \end{code} @@ -138,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 @@ -183,6 +192,9 @@ isDerivedFromCurrentCCS _ = False currentOrSubsumedCCS SubsumedCCS = True currentOrSubsumedCCS CurrentCCS = True currentOrSubsumedCCS _ = False + +maybeSingletonCCS (PushCC cc NoCCS) = Just cc +maybeSingletonCCS _ = Nothing \end{code} Building cost centres @@ -210,21 +222,9 @@ mkSingletonCCS cc = pushCCOnCCS cc NoCCS pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack pushCCOnCCS = PushCC -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) - dupifyCC cc = cc {cc_is_dupd = DupdCC} -isEmptyCC, isCafCC, isDupdCC :: CostCentre -> Bool - -isEmptyCC (NoCostCentre) = True -isEmptyCC _ = False +isCafCC, isDupdCC :: CostCentre -> Bool isCafCC (AllCafsCC {}) = True isCafCC (NormalCC {cc_is_caf = CafCC}) = True @@ -287,6 +287,11 @@ 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} ----------------------------------------------------------------------------- @@ -309,20 +314,8 @@ instance Outputable CostCentreStack where 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 <> ppr cc) - --- print the static declaration for a singleton CCS. -pprCostCentreStackDecl :: CostCentreStack -> SDoc -pprCostCentreStackDecl ccs@(PushCC cc NoCCS) - = hcat [ ptext SLIT("CCS_DECLARE"), char '(', - ppr ccs, comma, -- better be codeStyle - ppCostCentreLbl cc, comma, - empty, -- Now always externally visible - text ");" - ] - -pprCostCentreStackDecl ccs - = pprPanic "pprCostCentreStackDecl: " (ppr ccs) + parens (ppr ccs <> comma <> + parens(ptext SLIT("void *")) <> ppr cc) \end{code} ----------------------------------------------------------------------------- @@ -352,7 +345,7 @@ pprCostCentreCore (AllCafsCC {cc_mod = m}) pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = caf, cc_is_dupd = dup}) = text "__scc" <+> braces (hsep [ - ptext n, + ftext n, ppr m, pp_dup dup, pp_caf caf @@ -369,7 +362,7 @@ pp_caf other = empty 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 <> 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, @@ -377,34 +370,5 @@ ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf}) 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 (_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, - pprStringInCStyle (costCentreUserName cc), comma, - pprStringInCStyle (moduleNameUserString mod_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 - 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}