{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE TupleSections #-}
module GHC.Core.LateCC
( addLateCostCentresMG
, addLateCostCentresPgm
, addLateCostCentres
, Env(..)
) where
import Control.Applicative
import Control.Monad
import qualified Data.Set as S
import GHC.Prelude
import GHC.Types.CostCentre
import GHC.Types.CostCentre.State
import GHC.Types.Name hiding (varName)
import GHC.Types.Tickish
import GHC.Unit.Module.ModGuts
import GHC.Types.Var
import GHC.Unit.Types
import GHC.Data.FastString
import GHC.Core
import GHC.Core.Opt.Monad
import GHC.Core.Utils (mkTick)
import GHC.Types.Id
import GHC.Driver.Session
import GHC.Utils.Logger
import GHC.Utils.Outputable
import GHC.Utils.Misc
import GHC.Utils.Error (withTiming)
import GHC.Utils.Monad.State.Strict
addLateCostCentresMG :: ModGuts -> CoreM ModGuts
addLateCostCentresMG :: ModGuts -> CoreM ModGuts
addLateCostCentresMG ModGuts
guts = do
DynFlags
dflags <- forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let env :: Env
env :: Env
env = Env
{ thisModule :: Module
thisModule = ModGuts -> Module
mg_module ModGuts
guts
, ccState :: CostCentreState
ccState = CostCentreState
newCostCentreState
, countEntries :: Bool
countEntries = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfCountEntries DynFlags
dflags
, collectCCs :: Bool
collectCCs = Bool
False
}
let guts' :: ModGuts
guts' = ModGuts
guts { mg_binds :: CoreProgram
mg_binds = forall a b. (a, b) -> a
fst (Env -> CoreProgram -> (CoreProgram, Set CostCentre)
addLateCostCentres Env
env (ModGuts -> CoreProgram
mg_binds ModGuts
guts))
}
forall (m :: * -> *) a. Monad m => a -> m a
return ModGuts
guts'
addLateCostCentresPgm :: DynFlags -> Logger -> Module -> CoreProgram -> IO (CoreProgram, S.Set CostCentre)
addLateCostCentresPgm :: DynFlags
-> Logger
-> Module
-> CoreProgram
-> IO (CoreProgram, Set CostCentre)
addLateCostCentresPgm DynFlags
dflags Logger
logger Module
mod CoreProgram
binds =
forall (m :: * -> *) a.
MonadIO m =>
Logger -> SDoc -> (a -> ()) -> m a -> m a
withTiming Logger
logger
(forall doc. IsLine doc => String -> doc
text String
"LateCC"forall doc. IsLine doc => doc -> doc -> doc
<+>forall doc. IsLine doc => doc -> doc
brackets (forall a. Outputable a => a -> SDoc
ppr Module
mod))
(\(CoreProgram
a,Set CostCentre
b) -> CoreProgram
a forall a b. [a] -> b -> b
`seqList` (Set CostCentre
b seq :: forall a b. a -> b -> b
`seq` ())) forall a b. (a -> b) -> a -> b
$ do
let env :: Env
env = Env
{ thisModule :: Module
thisModule = Module
mod
, ccState :: CostCentreState
ccState = CostCentreState
newCostCentreState
, countEntries :: Bool
countEntries = GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_ProfCountEntries DynFlags
dflags
, collectCCs :: Bool
collectCCs = Bool
True
}
(CoreProgram
binds', Set CostCentre
ccs) = Env -> CoreProgram -> (CoreProgram, Set CostCentre)
addLateCostCentres Env
env CoreProgram
binds
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_dump_late_cc DynFlags
dflags Bool -> Bool -> Bool
|| DumpFlag -> DynFlags -> Bool
dopt DumpFlag
Opt_D_verbose_core2core DynFlags
dflags) forall a b. (a -> b) -> a -> b
$
Logger -> DumpFlag -> String -> DumpFormat -> SDoc -> IO ()
putDumpFileMaybe Logger
logger DumpFlag
Opt_D_dump_late_cc String
"LateCC" DumpFormat
FormatCore (forall doc. IsDoc doc => [doc] -> doc
vcat (forall a b. (a -> b) -> [a] -> [b]
map forall a. Outputable a => a -> SDoc
ppr CoreProgram
binds'))
forall (m :: * -> *) a. Monad m => a -> m a
return (CoreProgram
binds', Set CostCentre
ccs)
addLateCostCentres :: Env -> CoreProgram -> (CoreProgram,S.Set CostCentre)
addLateCostCentres :: Env -> CoreProgram -> (CoreProgram, Set CostCentre)
addLateCostCentres Env
env CoreProgram
binds =
let (CoreProgram
binds', LateCCState
state) = forall s a. State s a -> s -> (a, s)
runState (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) LateCCState
initLateCCState
in (CoreProgram
binds',LateCCState -> Set CostCentre
lcs_ccs LateCCState
state)
doBind :: Env -> CoreBind -> M CoreBind
doBind :: Env -> CoreBind -> M CoreBind
doBind Env
env (NonRec Var
b Expr Var
rhs) = forall b. b -> Expr b -> Bind b
NonRec Var
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Var -> Expr Var -> M (Expr Var)
doBndr Env
env Var
b Expr Var
rhs
doBind Env
env (Rec [(Var, Expr Var)]
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 (Var, Expr Var) -> M (Var, Expr Var)
doPair [(Var, Expr Var)]
bs
where
doPair :: ((Id, CoreExpr) -> M (Id, CoreExpr))
doPair :: (Var, Expr Var) -> M (Var, Expr Var)
doPair (Var
b,Expr Var
rhs) = (Var
b,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Var -> Expr Var -> M (Expr Var)
doBndr Env
env Var
b Expr Var
rhs
doBndr :: Env -> Id -> CoreExpr -> M CoreExpr
doBndr :: Env -> Var -> Expr Var -> M (Expr Var)
doBndr Env
env Var
bndr Expr Var
rhs
| Just DataCon
_ <- Var -> Maybe DataCon
isDataConId_maybe Var
bndr = forall (f :: * -> *) a. Applicative f => a -> f a
pure Expr Var
rhs
| Bool
otherwise = Env -> Var -> Expr Var -> M (Expr Var)
doBndr' Env
env Var
bndr Expr Var
rhs
doBndr' :: Env -> Id -> CoreExpr -> State LateCCState CoreExpr
doBndr' :: Env -> Var -> Expr Var -> M (Expr Var)
doBndr' Env
env Var
bndr (Lam Var
b Expr Var
rhs) = forall b. b -> Expr b -> Expr b
Lam Var
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Env -> Var -> Expr Var -> M (Expr Var)
doBndr' Env
env Var
bndr Expr Var
rhs
doBndr' Env
env Var
bndr Expr Var
rhs = do
let name :: Name
name = Var -> Name
idName Var
bndr
name_loc :: SrcSpan
name_loc = Name -> SrcSpan
nameSrcSpan Name
name
cc_name :: FastString
cc_name = forall a. NamedThing a => a -> FastString
getOccFS Name
name
count :: Bool
count = Env -> Bool
countEntries Env
env
CCFlavour
cc_flavour <- FastString -> M CCFlavour
getCCFlavour FastString
cc_name
let cc_mod :: Module
cc_mod = Env -> Module
thisModule Env
env
bndrCC :: CostCentre
bndrCC = CCFlavour -> FastString -> Module -> SrcSpan -> CostCentre
NormalCC CCFlavour
cc_flavour FastString
cc_name Module
cc_mod SrcSpan
name_loc
note :: GenTickish 'TickishPassCore
note = forall (pass :: TickishPass).
CostCentre -> Bool -> Bool -> GenTickish pass
ProfNote CostCentre
bndrCC Bool
count Bool
True
Env -> CostCentre -> M ()
addCC Env
env CostCentre
bndrCC
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ GenTickish 'TickishPassCore -> Expr Var -> Expr Var
mkTick GenTickish 'TickishPassCore
note Expr Var
rhs
data LateCCState = LateCCState
{ LateCCState -> CostCentreState
lcs_state :: !CostCentreState
, LateCCState -> Set CostCentre
lcs_ccs :: S.Set CostCentre
}
type M = State LateCCState
initLateCCState :: LateCCState
initLateCCState :: LateCCState
initLateCCState = CostCentreState -> Set CostCentre -> LateCCState
LateCCState CostCentreState
newCostCentreState forall a. Monoid a => a
mempty
getCCFlavour :: FastString -> M CCFlavour
getCCFlavour :: FastString -> M CCFlavour
getCCFlavour FastString
name = CostCentreIndex -> CCFlavour
LateCC forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FastString -> M CostCentreIndex
getCCIndex' FastString
name
getCCIndex' :: FastString -> M CostCentreIndex
getCCIndex' :: FastString -> M CostCentreIndex
getCCIndex' FastString
name = do
LateCCState
state <- forall s. State s s
get
let (CostCentreIndex
index,CostCentreState
cc_state') = FastString -> CostCentreState -> (CostCentreIndex, CostCentreState)
getCCIndex FastString
name (LateCCState -> CostCentreState
lcs_state LateCCState
state)
forall s. s -> State s ()
put (LateCCState
state { lcs_state :: CostCentreState
lcs_state = CostCentreState
cc_state'})
forall (m :: * -> *) a. Monad m => a -> m a
return CostCentreIndex
index
addCC :: Env -> CostCentre -> M ()
addCC :: Env -> CostCentre -> M ()
addCC !Env
env CostCentre
cc = do
LateCCState
state <- forall s. State s s
get
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Env -> Bool
collectCCs Env
env) forall a b. (a -> b) -> a -> b
$ do
let ccs' :: Set CostCentre
ccs' = forall a. Ord a => a -> Set a -> Set a
S.insert CostCentre
cc (LateCCState -> Set CostCentre
lcs_ccs LateCCState
state)
forall s. s -> State s ()
put (LateCCState
state { lcs_ccs :: Set CostCentre
lcs_ccs = Set CostCentre
ccs'})
data Env = Env
{ Env -> Module
thisModule :: !Module
, Env -> Bool
countEntries:: !Bool
, Env -> CostCentreState
ccState :: !CostCentreState
, Env -> Bool
collectCCs :: !Bool
}