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)

-- | 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) (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