\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
noCostCentre, noCCAttached,
noCCSAttached, isCurrentCCS, isSubsumedCCS, currentOrSubsumedCCS,
isDerivedFromCurrentCCS, maybeSingletonCCS,
- decomposeCCS,
+ decomposeCCS, pushCCisNop,
mkUserCC, mkAutoCC, mkAllCafsCC,
mkSingletonCCS, dupifyCC, pushCCOnCCS,
cmpCostCentre -- used for removing dups in a list
) where
-#include "HsVersions.h"
-
import Var ( Id )
-import Name ( getOccName, occNameFS )
-import Module ( Module, moduleFS )
+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.
| AllCafsCC {
cc_mod :: Module -- Name of module defining this CC.
}
+ deriving (Data, Typeable)
type CcName = FastString
-- 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.
SIMON: Maybe later...
\begin{code}
+noCCS, subsumedCCS, currentCCS, overheadCCS, dontCareCCS :: CostCentreStack
noCCS = NoCCS
subsumedCCS = SubsumedCCS
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
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 }
pushCCOnCCS :: CostCentre -> CostCentreStack -> CostCentreStack
pushCCOnCCS = PushCC
+dupifyCC :: CostCentre -> CostCentre
dupifyCC cc = cc {cc_is_dupd = DupdCC}
isCafCC, isDupdCC :: CostCentre -> Bool
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
\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}
-----------------------------------------------------------------------------
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_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 (zEncodeFS n),
- ppr_mod m,
+ ppr m,
pp_dup dup,
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
-
-ppr_mod m = ftext (zEncodeFS (moduleFS m))
+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_mod 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}
projects / ghc-hetmet.git / blobdiff