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 a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
forall a. Monoid a => a
mempty)
    nop2 :: b -> DebugM CensusStats
nop2 = DebugM CensusStats -> b -> DebugM CensusStats
forall a b. a -> b -> a
const (CensusStats -> DebugM CensusStats
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return CensusStats
forall a. Monoid a => a
mempty)
    funcs :: TraceFunctionsIO () CensusStats
funcs = (GenPapPayload ClosurePtr -> DebugM ())
-> (GenSrtPayload ClosurePtr -> DebugM ())
-> (GenStackFrames SrtCont ClosurePtr -> DebugM ())
-> (ClosurePtr
    -> SizedClosure
    -> ()
    -> DebugM ((), CensusStats, DebugM () -> DebugM ()))
-> (ClosurePtr -> () -> DebugM CensusStats)
-> (CCSPtr -> DebugM CensusStats)
-> (ConstrDesc -> DebugM ())
-> (CCSPtr -> CCSPayload -> DebugM CensusStats)
-> TraceFunctionsIO () CensusStats
forall a s.
(GenPapPayload ClosurePtr -> DebugM ())
-> (GenSrtPayload ClosurePtr -> DebugM ())
-> (GenStackFrames SrtCont ClosurePtr -> DebugM ())
-> (ClosurePtr
    -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))
-> (ClosurePtr -> a -> DebugM s)
-> (CCSPtr -> DebugM s)
-> (ConstrDesc -> DebugM ())
-> (CCSPtr -> CCSPayload -> DebugM s)
-> TraceFunctionsIO a s
TraceFunctionsIO GenPapPayload ClosurePtr -> DebugM ()
forall {b}. b -> DebugM ()
nop GenSrtPayload ClosurePtr -> DebugM ()
forall {b}. b -> DebugM ()
nop GenStackFrames SrtCont 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 a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return CensusStats
forall a. Monoid a => a
mempty))) CCSPtr -> DebugM CensusStats
forall {b}. b -> DebugM CensusStats
nop2 ConstrDesc -> DebugM ()
forall {b}. b -> DebugM ()
nop ((CCSPayload -> DebugM CensusStats)
-> CCSPtr -> CCSPayload -> DebugM CensusStats
forall a b. a -> b -> a
const CCSPayload -> DebugM CensusStats
forall {b}. b -> DebugM CensusStats
nop2)

    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 a. a -> DebugM a
forall (f :: * -> *) a. Applicative f => a -> f a
return ((), ClosurePtr -> Size -> CensusStats
mkCS ClosurePtr
cp (SizedClosure -> Size
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b -> Size
dcSize SizedClosure
sc), DebugM () -> DebugM ()
forall a. a -> a
id)

-- | Simple statistics about a heap, total objects, size and maximum object
-- size
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) CensusStats
forall a. Monoid a => a
mempty
  where
    funcs :: TraceFunctions (StateT CensusStats)
funcs = (ClosurePtr
 -> SizedClosure
 -> StateT CensusStats DebugM ()
 -> StateT CensusStats DebugM ())
-> TraceFunctions (StateT CensusStats)
forall (m :: (* -> *) -> * -> *).
C m =>
(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
-> TraceFunctions m
justClosures ClosurePtr
-> SizedClosure
-> StateT CensusStats DebugM ()
-> StateT CensusStats DebugM ()
closAccum

    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' (ClosurePtr -> SizedClosure -> CensusStats -> CensusStats
go ClosurePtr
cp SizedClosure
s)
      StateT CensusStats DebugM ()
k

    go :: ClosurePtr -> SizedClosure -> CensusStats -> CensusStats
    go :: ClosurePtr -> SizedClosure -> CensusStats -> CensusStats
go ClosurePtr
cp SizedClosure
sc CensusStats
cs = ClosurePtr -> Size -> CensusStats
mkCS ClosurePtr
cp (SizedClosure -> Size
forall ccs srt pap string s b.
DebugClosureWithSize ccs srt pap string s b -> Size
dcSize SizedClosure
sc) CensusStats -> CensusStats -> CensusStats
forall a. Semigroup a => a -> a -> a
<> CensusStats
cs