module GHC.Debug.Count where
import GHC.Debug.Types
import GHC.Debug.Client.Monad
import GHC.Debug.Profile
import GHC.Debug.Trace
import GHC.Debug.ParTrace hiding (TraceFunctionsIO(..))
import GHC.Debug.ParTrace (TraceFunctionsIO(TraceFunctionsIO))
import Control.Monad.State
parCount :: [ClosurePtr] -> DebugM CensusStats
parCount :: [ClosurePtr] -> DebugM CensusStats
parCount = TraceFunctionsIO () CensusStats
-> [ClosurePtrWithInfo ()] -> DebugM CensusStats
forall s a.
Monoid s =>
TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s
traceParFromM TraceFunctionsIO () CensusStats
funcs ([ClosurePtrWithInfo ()] -> DebugM CensusStats)
-> ([ClosurePtr] -> [ClosurePtrWithInfo ()])
-> [ClosurePtr]
-> DebugM CensusStats
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ClosurePtr -> ClosurePtrWithInfo ())
-> [ClosurePtr] -> [ClosurePtrWithInfo ()]
forall a b. (a -> b) -> [a] -> [b]
map (() -> ClosurePtr -> ClosurePtrWithInfo ()
forall a. a -> ClosurePtr -> ClosurePtrWithInfo a
ClosurePtrWithInfo ())
where
nop :: b -> DebugM ()
nop = DebugM () -> b -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
funcs :: TraceFunctionsIO () CensusStats
funcs = (GenPapPayload ClosurePtr -> DebugM ())
-> (GenStackFrames ClosurePtr -> DebugM ())
-> (ClosurePtr
-> SizedClosure
-> ()
-> DebugM ((), CensusStats, DebugM () -> DebugM ()))
-> (ClosurePtr -> () -> DebugM CensusStats)
-> (ConstrDesc -> DebugM ())
-> TraceFunctionsIO () CensusStats
forall a s.
(GenPapPayload ClosurePtr -> DebugM ())
-> (GenStackFrames ClosurePtr -> DebugM ())
-> (ClosurePtr
-> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))
-> (ClosurePtr -> a -> DebugM s)
-> (ConstrDesc -> DebugM ())
-> TraceFunctionsIO a s
TraceFunctionsIO GenPapPayload ClosurePtr -> DebugM ()
forall {b}. b -> DebugM ()
nop GenStackFrames ClosurePtr -> DebugM ()
forall {b}. b -> DebugM ()
nop ClosurePtr
-> SizedClosure
-> ()
-> DebugM ((), CensusStats, DebugM () -> DebugM ())
clos ((() -> DebugM CensusStats)
-> ClosurePtr -> () -> DebugM CensusStats
forall a b. a -> b -> a
const (DebugM CensusStats -> () -> DebugM CensusStats
forall a b. a -> b -> a
const (CensusStats -> DebugM CensusStats
forall (m :: * -> *) a. Monad m => a -> m a
return CensusStats
forall a. Monoid a => a
mempty))) ConstrDesc -> DebugM ()
forall {b}. b -> DebugM ()
nop
clos :: ClosurePtr -> SizedClosure -> ()
-> DebugM ((), CensusStats, DebugM () -> DebugM ())
clos :: ClosurePtr
-> SizedClosure
-> ()
-> DebugM ((), CensusStats, DebugM () -> DebugM ())
clos ClosurePtr
_cp SizedClosure
sc ()
_ = do
((), CensusStats, DebugM () -> DebugM ())
-> DebugM ((), CensusStats, DebugM () -> DebugM ())
forall (m :: * -> *) a. Monad m => a -> m a
return ((), Size -> CensusStats
mkCS (SizedClosure -> Size
forall pap string s b. DebugClosureWithSize pap string s b -> Size
dcSize SizedClosure
sc), DebugM () -> DebugM ()
forall a. a -> a
id)
count :: [ClosurePtr] -> DebugM CensusStats
count :: [ClosurePtr] -> DebugM CensusStats
count [ClosurePtr]
cps = ((), CensusStats) -> CensusStats
forall a b. (a, b) -> b
snd (((), CensusStats) -> CensusStats)
-> DebugM ((), CensusStats) -> DebugM CensusStats
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> StateT CensusStats DebugM ()
-> CensusStats -> DebugM ((), CensusStats)
forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT (TraceFunctions (StateT CensusStats)
-> [ClosurePtr] -> StateT CensusStats DebugM ()
forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions (StateT CensusStats)
funcs [ClosurePtr]
cps) (Count -> Size -> Max Size -> CensusStats
CS Count
0 Size
0 Max Size
0)
where
funcs :: TraceFunctions (StateT CensusStats)
funcs = TraceFunctions {
papTrace :: GenPapPayload ClosurePtr -> StateT CensusStats DebugM ()
papTrace = StateT CensusStats DebugM ()
-> GenPapPayload ClosurePtr -> StateT CensusStats DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusStats DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, stackTrace :: GenStackFrames ClosurePtr -> StateT CensusStats DebugM ()
stackTrace = StateT CensusStats DebugM ()
-> GenStackFrames ClosurePtr -> StateT CensusStats DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusStats DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, closTrace :: ClosurePtr
-> SizedClosure
-> StateT CensusStats DebugM ()
-> StateT CensusStats DebugM ()
closTrace = ClosurePtr
-> SizedClosure
-> StateT CensusStats DebugM ()
-> StateT CensusStats DebugM ()
closAccum
, visitedVal :: ClosurePtr -> StateT CensusStats DebugM ()
visitedVal = StateT CensusStats DebugM ()
-> ClosurePtr -> StateT CensusStats DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusStats DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
, conDescTrace :: ConstrDesc -> StateT CensusStats DebugM ()
conDescTrace = StateT CensusStats DebugM ()
-> ConstrDesc -> StateT CensusStats DebugM ()
forall a b. a -> b -> a
const (() -> StateT CensusStats DebugM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ())
}
closAccum :: ClosurePtr
-> SizedClosure
-> (StateT CensusStats DebugM) ()
-> (StateT CensusStats DebugM) ()
closAccum :: ClosurePtr
-> SizedClosure
-> StateT CensusStats DebugM ()
-> StateT CensusStats DebugM ()
closAccum ClosurePtr
_cp SizedClosure
s StateT CensusStats DebugM ()
k = do
(CensusStats -> CensusStats) -> StateT CensusStats DebugM ()
forall s (m :: * -> *). MonadState s m => (s -> s) -> m ()
modify' (SizedClosure -> CensusStats -> CensusStats
go SizedClosure
s)
StateT CensusStats DebugM ()
k
go :: SizedClosure -> CensusStats -> CensusStats
go :: SizedClosure -> CensusStats -> CensusStats
go SizedClosure
sc CensusStats
cs = Size -> CensusStats
mkCS (SizedClosure -> Size
forall pap string s b. DebugClosureWithSize pap string s b -> Size
dcSize SizedClosure
sc) CensusStats -> CensusStats -> CensusStats
forall a. Semigroup a => a -> a -> a
<> CensusStats
cs