{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TupleSections #-}
module GHC.Core.Opt.CallerCC
( addCallerCostCentres
, CallerCcFilter(..)
, NamePattern(..)
, parseCallerCcFilter
) where
import Data.Word (Word8)
import Data.Maybe
import Control.Applicative
import Control.Monad.Trans.State.Strict
import Data.Either
import Control.Monad
import qualified Text.ParserCombinators.ReadP as P
import GHC.Prelude
import GHC.Utils.Outputable as Outputable
import GHC.Driver.Session
import GHC.Driver.Ppr
import GHC.Types.CostCentre
import GHC.Types.CostCentre.State
import GHC.Types.Name hiding (varName)
import GHC.Types.Tickish
import GHC.Unit.Module.Name
import GHC.Unit.Module.ModGuts
import GHC.Types.SrcLoc
import GHC.Types.Var
import GHC.Unit.Types
import GHC.Data.FastString
import GHC.Core
import GHC.Core.Opt.Monad
import GHC.Utils.Panic
import qualified GHC.Utils.Binary as B
import Data.Char
addCallerCostCentres :: ModGuts -> CoreM ModGuts
addCallerCostCentres :: ModGuts -> CoreM ModGuts
addCallerCostCentres ModGuts
guts = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let filters :: [CallerCcFilter]
filters = DynFlags -> [CallerCcFilter]
callerCcFilters DynFlags
dflags
let env :: Env
env :: Env
env = Env
{ thisModule :: Module
thisModule = ModGuts -> Module
mg_module ModGuts
guts
, ccState :: CostCentreState
ccState = CostCentreState
newCostCentreState
, dflags :: DynFlags
dflags = DynFlags
dflags
, revParents :: [Id]
revParents = []
, filters :: [CallerCcFilter]
filters = [CallerCcFilter]
filters
}
let guts' :: ModGuts
guts' = ModGuts
guts { mg_binds :: CoreProgram
mg_binds = Env -> CoreProgram -> CoreProgram
doCoreProgram Env
env (ModGuts -> CoreProgram
mg_binds ModGuts
guts)
}
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts'
doCoreProgram :: Env -> CoreProgram -> CoreProgram
doCoreProgram :: Env -> CoreProgram -> CoreProgram
doCoreProgram Env
env CoreProgram
binds = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall s a. State s a -> s -> a
evalState CostCentreState
newCostCentreState forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Env -> CoreBind -> M CoreBind
doBind Env
env) CoreProgram
binds
doBind :: Env -> CoreBind -> M CoreBind
doBind :: Env -> CoreBind -> M CoreBind
doBind Env
env (NonRec Id
b Expr Id
rhs) = forall b. b -> Expr b -> Bind b
NonRec Id
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr Id -> M (Expr Id)
doExpr (Id -> Env -> Env
addParent Id
b Env
env) Expr Id
rhs
doBind Env
env (Rec [(Id, Expr Id)]
bs) = forall b. [(b, Expr b)] -> Bind b
Rec forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Id, Expr Id) -> StateT CostCentreState Identity (Id, Expr Id)
doPair [(Id, Expr Id)]
bs
where
doPair :: (Id, Expr Id) -> StateT CostCentreState Identity (Id, Expr Id)
doPair (Id
b,Expr Id
rhs) = (Id
b,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr Id -> M (Expr Id)
doExpr (Id -> Env -> Env
addParent Id
b Env
env) Expr Id
rhs
doExpr :: Env -> CoreExpr -> M CoreExpr
doExpr :: Env -> Expr Id -> M (Expr Id)
doExpr Env
env e :: Expr Id
e@(Var Id
v)
| Env -> Id -> Bool
needsCallSiteCostCentre Env
env Id
v = do
let nameDoc :: SDoc
nameDoc :: SDoc
nameDoc = PrintUnqualified -> Depth -> SDoc -> SDoc
withUserStyle PrintUnqualified
alwaysQualify Depth
DefaultDepth forall a b. (a -> b) -> a -> b
$
[SDoc] -> SDoc
hcat (SDoc -> [SDoc] -> [SDoc]
punctuate SDoc
dot (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr (Env -> [Id]
parents Env
env))) SDoc -> SDoc -> SDoc
<> SDoc -> SDoc
parens (String -> SDoc
text String
"calling:" SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr Id
v)
ccName :: CcName
ccName :: CcName
ccName = String -> CcName
mkFastString forall a b. (a -> b) -> a -> b
$ DynFlags -> SDoc -> String
showSDoc (Env -> DynFlags
dflags Env
env) SDoc
nameDoc
CostCentreIndex
ccIdx <- CcName -> M CostCentreIndex
getCCIndex' CcName
ccName
let span :: SrcSpan
span = case Env -> [Id]
revParents Env
env of
Id
top:[Id]
_ -> Name -> SrcSpan
nameSrcSpan forall a b. (a -> b) -> a -> b
$ Id -> Name
varName Id
top
[Id]
_ -> SrcSpan
noSrcSpan
cc :: CostCentre
cc = CCFlavour -> CcName -> Module -> SrcSpan -> CostCentre
NormalCC (CostCentreIndex -> CCFlavour
ExprCC CostCentreIndex
ccIdx) CcName
ccName (Env -> Module
thisModule Env
env) SrcSpan
span
tick :: CoreTickish
tick :: CoreTickish
tick = forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote CostCentre
cc Bool
True Bool
True
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
tick Expr Id
e
| Bool
otherwise = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr Id
e
doExpr Env
_env e :: Expr Id
e@(Lit Literal
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr Id
e
doExpr Env
env (Expr Id
f `App` Expr Id
x) = forall b. Expr b -> Expr b -> Expr b
App forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr Id -> M (Expr Id)
doExpr Env
env Expr Id
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Env -> Expr Id -> M (Expr Id)
doExpr Env
env Expr Id
x
doExpr Env
env (Lam Id
b Expr Id
x) = forall b. b -> Expr b -> Expr b
Lam Id
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr Id -> M (Expr Id)
doExpr Env
env Expr Id
x
doExpr Env
env (Let CoreBind
b Expr Id
rhs) = forall b. Bind b -> Expr b -> Expr b
Let forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> CoreBind -> M CoreBind
doBind Env
env CoreBind
b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Env -> Expr Id -> M (Expr Id)
doExpr Env
env Expr Id
rhs
doExpr Env
env (Case Expr Id
scrut Id
b Type
ty [Alt Id]
alts) =
forall b. Expr b -> b -> Type -> [Alt b] -> Expr b
Case forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr Id -> M (Expr Id)
doExpr Env
env Expr Id
scrut forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Id
b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
ty forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Alt Id -> StateT CostCentreState Identity (Alt Id)
doAlt [Alt Id]
alts
where
doAlt :: Alt Id -> StateT CostCentreState Identity (Alt Id)
doAlt (Alt AltCon
con [Id]
bs Expr Id
rhs) = forall b. AltCon -> [b] -> Expr b -> Alt b
Alt AltCon
con [Id]
bs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr Id -> M (Expr Id)
doExpr Env
env Expr Id
rhs
doExpr Env
env (Cast Expr Id
expr CoercionR
co) = forall b. Expr b -> CoercionR -> Expr b
Cast forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr Id -> M (Expr Id)
doExpr Env
env Expr Id
expr forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure CoercionR
co
doExpr Env
env (Tick CoreTickish
t Expr Id
e) = forall b. CoreTickish -> Expr b -> Expr b
Tick CoreTickish
t forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Expr Id -> M (Expr Id)
doExpr Env
env Expr Id
e
doExpr Env
_env e :: Expr Id
e@(Type Type
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr Id
e
doExpr Env
_env e :: Expr Id
e@(Coercion CoercionR
_) = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr Id
e
type M = State CostCentreState
getCCIndex' :: FastString -> M CostCentreIndex
getCCIndex' :: CcName -> M CostCentreIndex
getCCIndex' CcName
name = forall (m :: * -> *) s a. Monad m => (s -> (a, s)) -> StateT s m a
state (CcName -> CostCentreState -> (CostCentreIndex, CostCentreState)
getCCIndex CcName
name)
data Env = Env
{ Env -> Module
thisModule :: Module
, Env -> DynFlags
dflags :: DynFlags
, Env -> CostCentreState
ccState :: CostCentreState
, Env -> [Id]
revParents :: [Id]
, Env -> [CallerCcFilter]
filters :: [CallerCcFilter]
}
addParent :: Id -> Env -> Env
addParent :: Id -> Env -> Env
addParent Id
i Env
env = Env
env { revParents :: [Id]
revParents = Id
i forall a. a -> [a] -> [a]
: Env -> [Id]
revParents Env
env }
parents :: Env -> [Id]
parents :: Env -> [Id]
parents Env
env = forall a. [a] -> [a]
reverse (Env -> [Id]
revParents Env
env)
needsCallSiteCostCentre :: Env -> Id -> Bool
needsCallSiteCostCentre :: Env -> Id -> Bool
needsCallSiteCostCentre Env
env Id
i =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any CallerCcFilter -> Bool
matches (Env -> [CallerCcFilter]
filters Env
env)
where
matches :: CallerCcFilter -> Bool
matches :: CallerCcFilter -> Bool
matches CallerCcFilter
ccf =
Bool
checkModule Bool -> Bool -> Bool
&& Bool
checkFunc
where
checkModule :: Bool
checkModule =
case CallerCcFilter -> Maybe ModuleName
ccfModuleName CallerCcFilter
ccf of
Just ModuleName
modFilt
| Just Module
iMod <- Name -> Maybe Module
nameModule_maybe (Id -> Name
varName Id
i)
-> forall unit. GenModule unit -> ModuleName
moduleName Module
iMod forall a. Eq a => a -> a -> Bool
== ModuleName
modFilt
| Bool
otherwise -> Bool
False
Maybe ModuleName
Nothing -> Bool
True
checkFunc :: Bool
checkFunc =
NamePattern -> OccName -> Bool
occNameMatches (CallerCcFilter -> NamePattern
ccfFuncName CallerCcFilter
ccf) (forall a. NamedThing a => a -> OccName
getOccName Id
i)
data NamePattern
= PChar Char NamePattern
| PWildcard NamePattern
| PEnd
instance Outputable NamePattern where
ppr :: NamePattern -> SDoc
ppr (PChar Char
c NamePattern
rest) = Char -> SDoc
char Char
c SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr NamePattern
rest
ppr (PWildcard NamePattern
rest) = Char -> SDoc
char Char
'*' SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr NamePattern
rest
ppr NamePattern
PEnd = SDoc
Outputable.empty
instance B.Binary NamePattern where
get :: BinHandle -> IO NamePattern
get BinHandle
bh = do
Word8
tag <- forall a. Binary a => BinHandle -> IO a
B.get BinHandle
bh
case Word8
tag :: Word8 of
Word8
0 -> Char -> NamePattern -> NamePattern
PChar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
B.get BinHandle
bh forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Binary a => BinHandle -> IO a
B.get BinHandle
bh
Word8
1 -> NamePattern -> NamePattern
PWildcard forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
B.get BinHandle
bh
Word8
2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure NamePattern
PEnd
Word8
_ -> forall a. String -> a
panic String
"Binary(NamePattern): Invalid tag"
put_ :: BinHandle -> NamePattern -> IO ()
put_ BinHandle
bh (PChar Char
x NamePattern
y) = forall a. Binary a => BinHandle -> a -> IO ()
B.put_ BinHandle
bh (Word8
0 :: Word8) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Binary a => BinHandle -> a -> IO ()
B.put_ BinHandle
bh Char
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Binary a => BinHandle -> a -> IO ()
B.put_ BinHandle
bh NamePattern
y
put_ BinHandle
bh (PWildcard NamePattern
x) = forall a. Binary a => BinHandle -> a -> IO ()
B.put_ BinHandle
bh (Word8
1 :: Word8) forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Binary a => BinHandle -> a -> IO ()
B.put_ BinHandle
bh NamePattern
x
put_ BinHandle
bh NamePattern
PEnd = forall a. Binary a => BinHandle -> a -> IO ()
B.put_ BinHandle
bh (Word8
2 :: Word8)
occNameMatches :: NamePattern -> OccName -> Bool
occNameMatches :: NamePattern -> OccName -> Bool
occNameMatches NamePattern
pat = NamePattern -> String -> Bool
go NamePattern
pat forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccName -> String
occNameString
where
go :: NamePattern -> String -> Bool
go :: NamePattern -> String -> Bool
go NamePattern
PEnd String
"" = Bool
True
go (PChar Char
c NamePattern
rest) (Char
d:String
s)
= Char
d forall a. Eq a => a -> a -> Bool
== Char
c Bool -> Bool -> Bool
&& NamePattern -> String -> Bool
go NamePattern
rest String
s
go (PWildcard NamePattern
rest) String
s
= NamePattern -> String -> Bool
go NamePattern
rest String
s Bool -> Bool -> Bool
|| NamePattern -> String -> Bool
go (NamePattern -> NamePattern
PWildcard NamePattern
rest) (forall a. [a] -> [a]
tail String
s)
go NamePattern
_ String
_ = Bool
False
type Parser = P.ReadP
parseNamePattern :: Parser NamePattern
parseNamePattern :: Parser NamePattern
parseNamePattern = Parser NamePattern
pattern
where
pattern :: Parser NamePattern
pattern = Parser NamePattern
star forall a. ReadP a -> ReadP a -> ReadP a
P.<++ Parser NamePattern
wildcard forall a. ReadP a -> ReadP a -> ReadP a
P.<++ Parser NamePattern
char forall a. ReadP a -> ReadP a -> ReadP a
P.<++ Parser NamePattern
end
star :: Parser NamePattern
star = Char -> NamePattern -> NamePattern
PChar Char
'*' forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ String -> ReadP String
P.string String
"\\*" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser NamePattern
pattern
wildcard :: Parser NamePattern
wildcard = do
forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
P.char Char
'*'
NamePattern -> NamePattern
PWildcard forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser NamePattern
pattern
char :: Parser NamePattern
char = Char -> NamePattern -> NamePattern
PChar forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP Char
P.get forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser NamePattern
pattern
end :: Parser NamePattern
end = NamePattern
PEnd forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ReadP ()
P.eof
data CallerCcFilter
= CallerCcFilter { CallerCcFilter -> Maybe ModuleName
ccfModuleName :: Maybe ModuleName
, CallerCcFilter -> NamePattern
ccfFuncName :: NamePattern
}
instance Outputable CallerCcFilter where
ppr :: CallerCcFilter -> SDoc
ppr CallerCcFilter
ccf =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Char -> SDoc
char Char
'*') forall a. Outputable a => a -> SDoc
ppr (CallerCcFilter -> Maybe ModuleName
ccfModuleName CallerCcFilter
ccf)
SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'.'
SDoc -> SDoc -> SDoc
<> forall a. Outputable a => a -> SDoc
ppr (CallerCcFilter -> NamePattern
ccfFuncName CallerCcFilter
ccf)
instance B.Binary CallerCcFilter where
get :: BinHandle -> IO CallerCcFilter
get BinHandle
bh = Maybe ModuleName -> NamePattern -> CallerCcFilter
CallerCcFilter forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Binary a => BinHandle -> IO a
B.get BinHandle
bh forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. Binary a => BinHandle -> IO a
B.get BinHandle
bh
put_ :: BinHandle -> CallerCcFilter -> IO ()
put_ BinHandle
bh (CallerCcFilter Maybe ModuleName
x NamePattern
y) = forall a. Binary a => BinHandle -> a -> IO ()
B.put_ BinHandle
bh Maybe ModuleName
x forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall a. Binary a => BinHandle -> a -> IO ()
B.put_ BinHandle
bh NamePattern
y
parseCallerCcFilter :: String -> Either String CallerCcFilter
parseCallerCcFilter :: String -> Either String CallerCcFilter
parseCallerCcFilter String
inp =
case forall a. ReadP a -> ReadS a
P.readP_to_S Parser CallerCcFilter
parseCallerCcFilter' String
inp of
((CallerCcFilter
result, String
""):[(CallerCcFilter, String)]
_) -> forall a b. b -> Either a b
Right CallerCcFilter
result
[(CallerCcFilter, String)]
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ String
"parse error on " forall a. [a] -> [a] -> [a]
++ String
inp
parseCallerCcFilter' :: Parser CallerCcFilter
parseCallerCcFilter' :: Parser CallerCcFilter
parseCallerCcFilter' =
Maybe ModuleName -> NamePattern -> CallerCcFilter
CallerCcFilter
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser (Maybe ModuleName)
moduleFilter
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> ReadP Char
P.char Char
'.'
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser NamePattern
parseNamePattern
where
moduleFilter :: Parser (Maybe ModuleName)
moduleFilter :: Parser (Maybe ModuleName)
moduleFilter =
(forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ModuleName
mkModuleName forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReadP String
moduleName)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
(forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Char -> ReadP Char
P.char Char
'*')
moduleName :: Parser String
moduleName :: ReadP String
moduleName = do
Char
c <- (Char -> Bool) -> ReadP Char
P.satisfy Char -> Bool
isUpper
String
cs <- (Char -> Bool) -> ReadP String
P.munch1 (\Char
c -> Char -> Bool
isUpper Char
c Bool -> Bool -> Bool
|| Char -> Bool
isLower Char
c Bool -> Bool -> Bool
|| Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c forall a. Eq a => a -> a -> Bool
== Char
'_')
Maybe String
rest <- forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional forall a b. (a -> b) -> a -> b
$ Char -> ReadP Char
P.char Char
'.' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Char
'.'forall a. a -> [a] -> [a]
:) ReadP String
moduleName
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Char
c forall a. a -> [a] -> [a]
: (String
cs forall a. [a] -> [a] -> [a]
++ forall a. a -> Maybe a -> a
fromMaybe String
"" Maybe String
rest)