X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprofiling%2FCostCentre.lhs;h=9e08831c97cb8e4b4d8d7a1c9f6866b1e792af49;hp=38c5a82036578ef5b8740b749e6d0edb9af31efd;hb=5289f5d85610f71625a439747a09384876655eb5;hpb=17b297d97d327620ed6bfab942f8992b2446f1bf diff --git a/compiler/profiling/CostCentre.lhs b/compiler/profiling/CostCentre.lhs index 38c5a82..9e08831 100644 --- a/compiler/profiling/CostCentre.lhs +++ b/compiler/profiling/CostCentre.lhs @@ -4,12 +4,13 @@ \section[CostCentre]{The @CostCentre@ data type} \begin{code} -{-# OPTIONS_GHC -w #-} +{-# 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/WorkingConventions#Warnings +-- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings -- for details +{-# LANGUAGE BangPatterns, DeriveDataTypeable #-} module CostCentre ( CostCentre(..), CcName, IsDupdCC(..), IsCafCC(..), @@ -21,7 +22,7 @@ module CostCentre ( noCostCentre, noCCAttached, noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS, isDerivedFromCurrentCCS, maybeSingletonCCS, - decomposeCCS, + decomposeCCS, pushCCisNop, mkUserCC, mkAutoCC, mkAllCafsCC, mkSingletonCCS, dupifyCC, pushCCOnCCS, @@ -36,15 +37,16 @@ module CostCentre ( cmpCostCentre -- used for removing dups in a list ) where -#include "HsVersions.h" - import Var ( Id ) 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. @@ -124,6 +126,7 @@ data CostCentre | AllCafsCC { cc_mod :: Module -- Name of module defining this CC. } + deriving (Data, Typeable) type CcName = FastString @@ -142,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. @@ -162,6 +167,7 @@ being moved across module boundaries. SIMON: Maybe later... \begin{code} +noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS :: CostCentreStack noCCS = NoCCS subsumedCCS = SubsumedCCS @@ -169,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 @@ -218,12 +240,15 @@ mkAutoCC id mod is_caf } where name = getName id - -- beware: we might be making an auto CC for a compiler-generated - -- thing (like a CAF when -caf-all is on), so include the uniq. - -- See bug #249, tests prof001, prof002 - str | isSystemName name = mkFastString (showSDoc (ppr name)) - | otherwise = occNameFS (getOccName 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 } @@ -234,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 @@ -287,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 @@ -319,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} ----------------------------------------------------------------------------- @@ -352,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, @@ -363,13 +392,16 @@ 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}) @@ -378,8 +410,9 @@ ppCostCentreLbl (NormalCC {cc_name = n, cc_mod = m, cc_is_caf = is_caf}) -- 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}