module CostCentre (
CostCentre(..), CcName, CCFlavour(..),
CostCentreStack,
CollectedCCs, emptyCollectedCCs, collectCC,
currentCCS, dontCareCCS,
isCurrentCCS,
maybeSingletonCCS,
mkUserCC, mkAutoCC, mkAllCafsCC,
mkSingletonCCS,
isCafCCS, isCafCC, isSccCountCC, sccAbleCC, ccFromThisModule,
pprCostCentreCore,
costCentreUserName, costCentreUserNameFS,
costCentreSrcSpan,
cmpCostCentre
) where
import GhcPrelude
import Binary
import Var
import Name
import Module
import Unique
import Outputable
import SrcLoc
import FastString
import Util
import CostCentreState
import Data.Data
data CostCentre
= NormalCC {
cc_flavour :: CCFlavour,
cc_name :: CcName,
cc_mod :: Module,
cc_loc :: SrcSpan
}
| AllCafsCC {
cc_mod :: Module,
cc_loc :: SrcSpan
}
deriving Data
type CcName = FastString
data CCFlavour = CafCC
| ExprCC !CostCentreIndex
| DeclCC !CostCentreIndex
| HpcCC !CostCentreIndex
deriving (Eq, Ord, Data)
flavourIndex :: CCFlavour -> Int
flavourIndex CafCC = 0
flavourIndex (ExprCC x) = unCostCentreIndex x
flavourIndex (DeclCC x) = unCostCentreIndex x
flavourIndex (HpcCC x) = unCostCentreIndex x
instance Eq CostCentre where
c1 == c2 = case c1 `cmpCostCentre` c2 of { EQ -> True; _ -> False }
instance Ord CostCentre where
compare = cmpCostCentre
cmpCostCentre :: CostCentre -> CostCentre -> Ordering
cmpCostCentre (AllCafsCC {cc_mod = m1}) (AllCafsCC {cc_mod = m2})
= m1 `compare` m2
cmpCostCentre NormalCC {cc_flavour = f1, cc_mod = m1, cc_name = n1}
NormalCC {cc_flavour = f2, cc_mod = m2, cc_name = n2}
= (m1 `compare` m2) `thenCmp` (n1 `compare` n2) `thenCmp` (f1 `compare` f2)
cmpCostCentre other_1 other_2
= let
tag1 = tag_CC other_1
tag2 = tag_CC other_2
in
if tag1 < tag2 then LT else GT
where
tag_CC :: CostCentre -> Int
tag_CC (NormalCC {}) = 0
tag_CC (AllCafsCC {}) = 1
isCafCC :: CostCentre -> Bool
isCafCC (AllCafsCC {}) = True
isCafCC (NormalCC {cc_flavour = CafCC}) = True
isCafCC _ = False
isSccCountCC :: CostCentre -> Bool
isSccCountCC cc | isCafCC cc = False
| otherwise = True
sccAbleCC :: CostCentre -> Bool
sccAbleCC cc | isCafCC cc = False
| otherwise = True
ccFromThisModule :: CostCentre -> Module -> Bool
ccFromThisModule cc m = cc_mod cc == m
mkUserCC :: FastString -> Module -> SrcSpan -> CCFlavour -> CostCentre
mkUserCC cc_name mod loc flavour
= NormalCC { cc_name = cc_name, cc_mod = mod, cc_loc = loc,
cc_flavour = flavour
}
mkAutoCC :: Id -> Module -> CostCentre
mkAutoCC id mod
= NormalCC { cc_name = str, cc_mod = mod,
cc_loc = nameSrcSpan (getName id),
cc_flavour = CafCC
}
where
name = getName id
str | isExternalName name = occNameFS (getOccName id)
| otherwise = occNameFS (getOccName id)
`appendFS`
mkFastString ('_' : show (getUnique name))
mkAllCafsCC :: Module -> SrcSpan -> CostCentre
mkAllCafsCC m loc = AllCafsCC { cc_mod = m, cc_loc = loc }
data CostCentreStack
= CurrentCCS
| DontCareCCS
| SingletonCCS CostCentre
deriving (Eq, Ord)
type CollectedCCs
= ( [CostCentre]
, [CostCentreStack]
)
emptyCollectedCCs :: CollectedCCs
emptyCollectedCCs = ([], [])
collectCC :: CostCentre -> CostCentreStack -> CollectedCCs -> CollectedCCs
collectCC cc ccs (c, cs) = (cc : c, ccs : cs)
currentCCS, dontCareCCS :: CostCentreStack
currentCCS = CurrentCCS
dontCareCCS = DontCareCCS
isCurrentCCS :: CostCentreStack -> Bool
isCurrentCCS CurrentCCS = True
isCurrentCCS _ = False
isCafCCS :: CostCentreStack -> Bool
isCafCCS (SingletonCCS cc) = isCafCC cc
isCafCCS _ = False
maybeSingletonCCS :: CostCentreStack -> Maybe CostCentre
maybeSingletonCCS (SingletonCCS cc) = Just cc
maybeSingletonCCS _ = Nothing
mkSingletonCCS :: CostCentre -> CostCentreStack
mkSingletonCCS cc = SingletonCCS cc
instance Outputable CostCentreStack where
ppr CurrentCCS = text "CCCS"
ppr DontCareCCS = text "CCS_DONT_CARE"
ppr (SingletonCCS cc) = ppr cc <> text "_ccs"
instance Outputable CostCentre where
ppr cc = getPprStyle $ \ sty ->
if codeStyle sty
then ppCostCentreLbl cc
else text (costCentreUserName cc)
pprCostCentreCore :: CostCentre -> SDoc
pprCostCentreCore (AllCafsCC {cc_mod = m})
= text "__sccC" <+> braces (ppr m)
pprCostCentreCore (NormalCC {cc_flavour = flavour, cc_name = n,
cc_mod = m, cc_loc = loc})
= text "__scc" <+> braces (hsep [
ppr m <> char '.' <> ftext n,
pprFlavourCore flavour,
whenPprDebug (ppr loc)
])
pprFlavourCore :: CCFlavour -> SDoc
pprFlavourCore CafCC = text "__C"
pprFlavourCore f = pprIdxCore $ flavourIndex f
pprIdxCore :: Int -> SDoc
pprIdxCore 0 = empty
pprIdxCore idx = whenPprDebug $ ppr idx
ppCostCentreLbl :: CostCentre -> SDoc
ppCostCentreLbl (AllCafsCC {cc_mod = m}) = ppr m <> text "_CAFs_cc"
ppCostCentreLbl (NormalCC {cc_flavour = f, cc_name = n, cc_mod = m})
= ppr m <> char '_' <> ztext (zEncodeFS n) <> char '_' <>
ppFlavourLblComponent f <> text "_cc"
ppFlavourLblComponent :: CCFlavour -> SDoc
ppFlavourLblComponent CafCC = text "CAF"
ppFlavourLblComponent (ExprCC i) = text "EXPR" <> ppIdxLblComponent i
ppFlavourLblComponent (DeclCC i) = text "DECL" <> ppIdxLblComponent i
ppFlavourLblComponent (HpcCC i) = text "HPC" <> ppIdxLblComponent i
ppIdxLblComponent :: CostCentreIndex -> SDoc
ppIdxLblComponent n =
case unCostCentreIndex n of
0 -> empty
n -> ppr n
costCentreUserName :: CostCentre -> String
costCentreUserName = unpackFS . costCentreUserNameFS
costCentreUserNameFS :: CostCentre -> FastString
costCentreUserNameFS (AllCafsCC {}) = mkFastString "CAF"
costCentreUserNameFS (NormalCC {cc_name = name, cc_flavour = is_caf})
= case is_caf of
CafCC -> mkFastString "CAF:" `appendFS` name
_ -> name
costCentreSrcSpan :: CostCentre -> SrcSpan
costCentreSrcSpan = cc_loc
instance Binary CCFlavour where
put_ bh CafCC = do
putByte bh 0
put_ bh (ExprCC i) = do
putByte bh 1
put_ bh i
put_ bh (DeclCC i) = do
putByte bh 2
put_ bh i
put_ bh (HpcCC i) = do
putByte bh 3
put_ bh i
get bh = do
h <- getByte bh
case h of
0 -> do return CafCC
1 -> ExprCC <$> get bh
2 -> DeclCC <$> get bh
_ -> HpcCC <$> get bh
instance Binary CostCentre where
put_ bh (NormalCC aa ab ac _ad) = do
putByte bh 0
put_ bh aa
put_ bh ab
put_ bh ac
put_ bh (AllCafsCC ae _af) = do
putByte bh 1
put_ bh ae
get bh = do
h <- getByte bh
case h of
0 -> do aa <- get bh
ab <- get bh
ac <- get bh
return (NormalCC aa ab ac noSrcSpan)
_ -> do ae <- get bh
return (AllCafsCC ae noSrcSpan)