X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprofiling%2FCostCentre.lhs;h=9e08831c97cb8e4b4d8d7a1c9f6866b1e792af49;hp=56fde05608343d2f418d98061835b03840f77f7f;hb=5289f5d85610f71625a439747a09384876655eb5;hpb=61d2625ae2e6a4cdae2ffc92df828905e81c24cc diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index 56fde05..9e08831 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -4,6 +4,14 @@ \section[CostCentre]{The @CostCentre@ data type} \begin{code} +{-# OPTIONS -fno-warn-incomplete-patterns #-} +-- The above warning supression flag is a temporary kludge. +-- While working on this module you are encouraged to remove it and fix +-- any warnings in the module. See +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings +-- for details +{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} + module CostCentre ( CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..), -- All abstract except to friend: ParseIface.y @@ -14,7 +22,7 @@ module CostCentre ( noCostCentre, noCCAttached, noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS, isDerivedFromCurrentCCS, maybeSingletonCCS, - decomposeCCS, + decomposeCCS, pushCCisNop, mkUserCC, mkAutoCC, mkAllCafsCC, mkSingletonCCS, dupifyCC, pushCCOnCCS, @@ -29,15 +37,16 @@ module CostCentre ( cmpCostCentre -- used for removing dups in a list ) where -#include "HsVersions.h" - import Var ( Id ) -import Name ( getOccName, occNameFS ) +import Name import Module ( Module ) +import Unique import Outputable import FastTypes import FastString import Util ( thenCmp ) + +import Data.Data \end{code} A Cost Centre Stack is something that can be attached to a closure. @@ -117,6 +126,7 @@ data CostCentre | AllCafsCC { cc_mod :: Module -- Name of module defining this CC. } + deriving (Data, Typeable) type CcName = FastString @@ -135,8 +145,10 @@ data IsDupdCC -- but we are trying to avoid confusion between -- "subd" and "subsumed". So we call the former -- "dupd". + deriving (Data, Typeable) data IsCafCC = CafCC | NotCafCC + deriving (Data, Typeable) -- synonym for triple which describes the cost centre info in the generated -- code for a module. @@ -155,6 +167,7 @@ being moved across module boundaries. SIMON: Maybe later... \begin{code} +noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS :: CostCentreStack noCCS = NoCCS subsumedCCS = SubsumedCCS @@ -162,37 +175,53 @@ currentCCS = CurrentCCS overheadCCS = OverheadCCS dontCareCCS = DontCareCCS +noCostCentre :: CostCentre noCostCentre = NoCostCentre \end{code} Predicates on Cost-Centre Stacks \begin{code} +noCCSAttached :: CostCentreStack -> Bool noCCSAttached NoCCS = True noCCSAttached _ = False +noCCAttached :: CostCentre -> Bool noCCAttached NoCostCentre = True noCCAttached _ = False +isCurrentCCS :: CostCentreStack -> Bool isCurrentCCS CurrentCCS = True isCurrentCCS _ = False +isSubsumedCCS :: CostCentreStack -> Bool isSubsumedCCS SubsumedCCS = True isSubsumedCCS _ = False +isCafCCS :: CostCentreStack -> Bool isCafCCS (PushCC cc NoCCS) = isCafCC cc isCafCCS _ = False +isDerivedFromCurrentCCS :: CostCentreStack -> Bool isDerivedFromCurrentCCS CurrentCCS = True isDerivedFromCurrentCCS (PushCC _ ccs) = isDerivedFromCurrentCCS ccs isDerivedFromCurrentCCS _ = False +currentOrSubsumedCCS :: CostCentreStack -> Bool currentOrSubsumedCCS SubsumedCCS = True currentOrSubsumedCCS CurrentCCS = True currentOrSubsumedCCS _ = False +maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre maybeSingletonCCS (PushCC cc NoCCS) = Just cc maybeSingletonCCS _ = Nothing + +pushCCisNop :: CostCentre -> CostCentreStack -> Bool +-- (pushCCisNop cc ccs) = True => pushing cc on ccs is a no-op +-- It's safe to return False, but the optimiser can remove +-- redundant pushes if this function returns True. +pushCCisNop cc (PushCC cc' _) = cc == cc' +pushCCisNop _ _ = False \end{code} Building cost centres @@ -206,10 +235,20 @@ mkUserCC cc_name mod mkAutoCC :: Id -> Module -> IsCafCC -> CostCentre mkAutoCC id mod is_caf - = NormalCC { cc_name = occNameFS (getOccName id), cc_mod = mod, + = NormalCC { cc_name = str, cc_mod = mod, cc_is_dupd = OriginalCC, cc_is_caf = is_caf } - + where + name = getName id + -- beware: only external names are guaranteed to have unique + -- Occnames. If the name is not external, we must append its + -- Unique. + -- See bug #249, tests prof001, prof002, also #2411 + str | isExternalName name = occNameFS (getOccName id) + | otherwise = mkFastString $ showSDoc $ + ftext (occNameFS (getOccName id)) + <> char '_' <> pprUnique (getUnique name) +mkAllCafsCC :: Module -> CostCentre mkAllCafsCC m = AllCafsCC { cc_mod = m } @@ -220,6 +259,7 @@ mkSingletonCCS cc = pushCCOnCCS cc NoCCS pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack pushCCOnCCS = PushCC +dupifyCC :: CostCentre -> CostCentre dupifyCC cc = cc {cc_is_dupd = DupdCC} isCafCC, isDupdCC :: CostCentre -> Bool @@ -273,14 +313,16 @@ cmpCostCentre (NormalCC {cc_name = n1, cc_mod = m1, cc_is_caf = c1}) cmpCostCentre other_1 other_2 = let - tag1 = tag_CC other_1 - tag2 = tag_CC other_2 + !tag1 = tag_CC other_1 + !tag2 = tag_CC other_2 in if tag1 <# tag2 then LT else GT where - tag_CC (NormalCC {}) = (_ILIT 1 :: FastInt) - tag_CC (AllCafsCC {}) = _ILIT 2 + tag_CC (NormalCC {}) = _ILIT(1) + tag_CC (AllCafsCC {}) = _ILIT(2) +-- TODO: swap order of IsCafCC, add deriving Ord +cmp_caf :: IsCafCC -> IsCafCC -> Ordering cmp_caf NotCafCC CafCC = LT cmp_caf NotCafCC NotCafCC = EQ cmp_caf CafCC CafCC = EQ @@ -305,15 +347,15 @@ non-constant C expression. \begin{code} instance Outputable CostCentreStack where - 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") <> + 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) + parens(ptext (sLit "void *")) <> ppr cc) \end{code} ----------------------------------------------------------------------------- @@ -338,6 +380,7 @@ instance Outputable CostCentre where else text (costCentreUserName cc) -- Printing in an interface file or in Core generally +pprCostCentreCore :: CostCentre -> SDoc pprCostCentreCore (AllCafsCC {cc_mod = m}) = text "__sccC" <+> braces (ppr m) pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, @@ -349,23 +392,27 @@ pprCostCentreCore (NormalCC {cc_name = n, cc_mod = m, pp_caf caf ]) +pp_dup :: IsDupdCC -> SDoc pp_dup DupdCC = char '!' -pp_dup other = empty +pp_dup _ = empty +pp_caf :: IsCafCC -> SDoc pp_caf CafCC = text "__C" -pp_caf other = empty +pp_caf _ = empty -- Printing as a C label +ppCostCentreLbl :: CostCentre -> SDoc 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 (zEncodeFS n) <> + = ppr m <> char '_' <> ftext (zEncodeFS 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 :: CostCentre -> String costCentreUserName (NoCostCentre) = "NO_CC" costCentreUserName (AllCafsCC {}) = "CAF" -costCentreUserName cc@(NormalCC {cc_name = name, cc_is_caf = is_caf}) +costCentreUserName (NormalCC {cc_name = name, cc_is_caf = is_caf}) = case is_caf of { CafCC -> "CAF:"; _ -> "" } ++ unpackFS name \end{code}