{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE NumericUnderscores #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE FlexibleContexts #-}
-- | Functions to support the constant space traversal of a heap.
module GHC.Debug.Trace ( traceFromM, TraceFunctions(..), justClosures ) where

import           GHC.Debug.Types
import GHC.Debug.Client.Monad
import           GHC.Debug.Client.Query

import qualified Data.IntMap as IM
import Data.Array.BitArray.IO
import Control.Monad.Reader
import Control.Monad
import Data.IORef
import Data.Word
import Data.Bitraversable
import Data.Coerce

newtype VisitedSet = VisitedSet (IM.IntMap (IOBitArray Word16))

data TraceState = TraceState { TraceState -> VisitedSet
visited :: !VisitedSet, TraceState -> Int
n :: !Int }


getKeyPair :: ClosurePtr -> (Int, Word16)
getKeyPair :: ClosurePtr -> (Int, Word16)
getKeyPair ClosurePtr
cp =
  let BlockPtr Word64
raw_bk = ClosurePtr -> BlockPtr
applyBlockMask ClosurePtr
cp
      bk :: Int
bk = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
raw_bk Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
      offset :: Word64
offset = ClosurePtr -> Word64
getBlockOffset ClosurePtr
cp Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
8
  in (Int
bk, Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
offset)

checkVisit :: ClosurePtr -> IORef TraceState -> IO (Maybe Int, Bool)
checkVisit :: ClosurePtr -> IORef TraceState -> IO (Maybe Int, Bool)
checkVisit ClosurePtr
cp IORef TraceState
mref = do
  TraceState
st <- IORef TraceState -> IO TraceState
forall a. IORef a -> IO a
readIORef IORef TraceState
mref
  let VisitedSet IntMap (IOBitArray Word16)
v = TraceState -> VisitedSet
visited TraceState
st
      num_visited :: Int
num_visited = TraceState -> Int
n TraceState
st
      (Int
bk, Word16
offset) = ClosurePtr -> (Int, Word16)
getKeyPair ClosurePtr
cp
  case Int -> IntMap (IOBitArray Word16) -> Maybe (IOBitArray Word16)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
bk IntMap (IOBitArray Word16)
v of
    Maybe (IOBitArray Word16)
Nothing -> do
      IOBitArray Word16
na <- (Word16, Word16) -> Bool -> IO (IOBitArray Word16)
forall i. Ix i => (i, i) -> Bool -> IO (IOBitArray i)
newArray (Word16
0, Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
blockMask Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`div` Word64
8)) Bool
False
      IOBitArray Word16 -> Word16 -> Bool -> IO ()
forall i. Ix i => IOBitArray i -> i -> Bool -> IO ()
writeArray IOBitArray Word16
na Word16
offset Bool
True
      IORef TraceState -> TraceState -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef TraceState
mref (VisitedSet -> Int -> TraceState
TraceState (IntMap (IOBitArray Word16) -> VisitedSet
VisitedSet (Int
-> IOBitArray Word16
-> IntMap (IOBitArray Word16)
-> IntMap (IOBitArray Word16)
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
bk IOBitArray Word16
na IntMap (IOBitArray Word16)
v)) (Int
num_visited Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))
      return (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
num_visited, Bool
False)
    Just IOBitArray Word16
bm -> do
      Bool
res <- IOBitArray Word16 -> Word16 -> IO Bool
forall i. Ix i => IOBitArray i -> i -> IO Bool
readArray IOBitArray Word16
bm Word16
offset
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
res (IOBitArray Word16 -> Word16 -> Bool -> IO ()
forall i. Ix i => IOBitArray i -> i -> Bool -> IO ()
writeArray IOBitArray Word16
bm Word16
offset Bool
True)
      return (Maybe Int
forall a. Maybe a
Nothing, Bool
res)



data TraceFunctions m =
      TraceFunctions { forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> GenPapPayload ClosurePtr -> m DebugM ()
papTrace :: !(GenPapPayload ClosurePtr -> m DebugM ())
      , forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> GenSrtPayload ClosurePtr -> m DebugM ()
srtTrace   :: !(GenSrtPayload ClosurePtr -> m DebugM ())
      , forall (m :: (* -> *) -> * -> *).
TraceFunctions m
-> GenStackFrames SrtCont ClosurePtr -> m DebugM ()
stackTrace :: !(GenStackFrames SrtCont ClosurePtr -> m DebugM ())
      , forall (m :: (* -> *) -> * -> *).
TraceFunctions m
-> ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()
closTrace :: !(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
      , forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> ClosurePtr -> m DebugM ()
visitedVal :: !(ClosurePtr -> (m DebugM) ())
      , forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> ConstrDesc -> m DebugM ()
conDescTrace :: !(ConstrDesc -> m DebugM ())
      , forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> CCSPtr -> CCSPayload -> m DebugM ()
ccsTrace :: !(CCSPtr -> CCSPayload -> m DebugM ())
      }

justClosures :: C m => (ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()) -> TraceFunctions m
justClosures :: forall (m :: (* -> *) -> * -> *).
C m =>
(ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
-> TraceFunctions m
justClosures ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()
f = (GenPapPayload ClosurePtr -> m DebugM ())
-> (GenSrtPayload ClosurePtr -> m DebugM ())
-> (GenStackFrames SrtCont ClosurePtr -> m DebugM ())
-> (ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
-> (ClosurePtr -> m DebugM ())
-> (ConstrDesc -> m DebugM ())
-> (CCSPtr -> CCSPayload -> m DebugM ())
-> TraceFunctions m
forall (m :: (* -> *) -> * -> *).
(GenPapPayload ClosurePtr -> m DebugM ())
-> (GenSrtPayload ClosurePtr -> m DebugM ())
-> (GenStackFrames SrtCont ClosurePtr -> m DebugM ())
-> (ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ())
-> (ClosurePtr -> m DebugM ())
-> (ConstrDesc -> m DebugM ())
-> (CCSPtr -> CCSPayload -> m DebugM ())
-> TraceFunctions m
TraceFunctions GenPapPayload ClosurePtr -> m DebugM ()
forall {b}. b -> m DebugM ()
nop GenSrtPayload ClosurePtr -> m DebugM ()
forall {b}. b -> m DebugM ()
nop GenStackFrames SrtCont ClosurePtr -> m DebugM ()
forall {b}. b -> m DebugM ()
nop ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()
f ClosurePtr -> m DebugM ()
forall {b}. b -> m DebugM ()
nop ConstrDesc -> m DebugM ()
forall {b}. b -> m DebugM ()
nop ((CCSPayload -> m DebugM ()) -> CCSPtr -> CCSPayload -> m DebugM ()
forall a b. a -> b -> a
const CCSPayload -> m DebugM ()
forall {b}. b -> m DebugM ()
nop)
  where
    nop :: b -> m DebugM ()
nop = m DebugM () -> b -> m DebugM ()
forall a b. a -> b -> a
const (() -> m DebugM ()
forall a. a -> m DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ())

type C m = (MonadTrans m, Monad (m DebugM))

-- | A generic heap traversal function which will use a small amount of
-- memory linear in the heap size. Using this function with appropiate
-- accumulation functions you should be able to traverse quite big heaps in
-- not a huge amount of memory.
traceFromM :: C m => TraceFunctions m-> [ClosurePtr] -> m DebugM ()
traceFromM :: forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m -> [ClosurePtr] -> m DebugM ()
traceFromM TraceFunctions m
k [ClosurePtr]
cps = do
  IORef TraceState
st <- DebugM (IORef TraceState) -> m DebugM (IORef TraceState)
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (IORef TraceState) -> DebugM (IORef TraceState)
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (TraceState -> IO (IORef TraceState)
forall a. a -> IO (IORef a)
newIORef (VisitedSet -> Int -> TraceState
TraceState (IntMap (IOBitArray Word16) -> VisitedSet
VisitedSet IntMap (IOBitArray Word16)
forall a. IntMap a
IM.empty) Int
1)))
  ReaderT (IORef TraceState) (m DebugM) ()
-> IORef TraceState -> m DebugM ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ((ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ())
-> [ClosurePtr] -> ReaderT (IORef TraceState) (m DebugM) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (TraceFunctions m
-> ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m
-> ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
traceClosureFromM TraceFunctions m
k) [ClosurePtr]
cps) IORef TraceState
st
{-# INLINE traceFromM #-}
{-# INLINE traceClosureFromM #-}

traceClosureFromM :: C m
                  => TraceFunctions m
                  -> ClosurePtr
                  -> ReaderT (IORef TraceState) (m DebugM) ()
traceClosureFromM :: forall (m :: (* -> *) -> * -> *).
C m =>
TraceFunctions m
-> ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
traceClosureFromM !TraceFunctions m
k = ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
go
  where
    go :: ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
go ClosurePtr
cp = do
      IORef TraceState
mref <- ReaderT (IORef TraceState) (m DebugM) (IORef TraceState)
forall r (m :: * -> *). MonadReader r m => m r
ask
      (Maybe Int
mnum_visited, Bool
b) <- m DebugM (Maybe Int, Bool)
-> ReaderT (IORef TraceState) (m DebugM) (Maybe Int, Bool)
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (IORef TraceState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM (Maybe Int, Bool)
 -> ReaderT (IORef TraceState) (m DebugM) (Maybe Int, Bool))
-> m DebugM (Maybe Int, Bool)
-> ReaderT (IORef TraceState) (m DebugM) (Maybe Int, Bool)
forall a b. (a -> b) -> a -> b
$ DebugM (Maybe Int, Bool) -> m DebugM (Maybe Int, Bool)
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM (Maybe Int, Bool) -> m DebugM (Maybe Int, Bool))
-> DebugM (Maybe Int, Bool) -> m DebugM (Maybe Int, Bool)
forall a b. (a -> b) -> a -> b
$ IO (Maybe Int, Bool) -> DebugM (Maybe Int, Bool)
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (ClosurePtr -> IORef TraceState -> IO (Maybe Int, Bool)
checkVisit ClosurePtr
cp IORef TraceState
mref)
      Maybe Int
-> (Int -> ReaderT (IORef TraceState) (m DebugM) ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Int
mnum_visited ((Int -> ReaderT (IORef TraceState) (m DebugM) ())
 -> ReaderT (IORef TraceState) (m DebugM) ())
-> (Int -> ReaderT (IORef TraceState) (m DebugM) ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ \Int
num_visited ->
        m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (IORef TraceState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ())
-> m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ DebugM () -> m DebugM ()
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM () -> m DebugM ()) -> DebugM () -> m DebugM ()
forall a b. (a -> b) -> a -> b
$ Bool -> DebugM () -> DebugM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
num_visited Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
10_000 Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (DebugM () -> DebugM ()) -> DebugM () -> DebugM ()
forall a b. (a -> b) -> a -> b
$ String -> DebugM ()
forall (m :: * -> *). DebugMonad m => String -> m ()
traceMsg (String
"Traced: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Int -> String
forall a. Show a => a -> String
show Int
num_visited)
      if Bool
b
        then m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (IORef TraceState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ())
-> m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ TraceFunctions m -> ClosurePtr -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> ClosurePtr -> m DebugM ()
visitedVal TraceFunctions m
k ClosurePtr
cp
        else do
        SizedClosure
sc <- m DebugM SizedClosure
-> ReaderT (IORef TraceState) (m DebugM) SizedClosure
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (IORef TraceState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM SizedClosure
 -> ReaderT (IORef TraceState) (m DebugM) SizedClosure)
-> m DebugM SizedClosure
-> ReaderT (IORef TraceState) (m DebugM) SizedClosure
forall a b. (a -> b) -> a -> b
$ DebugM SizedClosure -> m DebugM SizedClosure
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM SizedClosure -> m DebugM SizedClosure)
-> DebugM SizedClosure -> m DebugM SizedClosure
forall a b. (a -> b) -> a -> b
$ ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
cp
        (IORef TraceState -> m DebugM ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall r (m :: * -> *) a. (r -> m a) -> ReaderT r m a
ReaderT ((IORef TraceState -> m DebugM ())
 -> ReaderT (IORef TraceState) (m DebugM) ())
-> (IORef TraceState -> m DebugM ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ \IORef TraceState
st -> TraceFunctions m
-> ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m
-> ClosurePtr -> SizedClosure -> m DebugM () -> m DebugM ()
closTrace TraceFunctions m
k ClosurePtr
cp SizedClosure
sc
         (ReaderT (IORef TraceState) (m DebugM) ()
-> IORef TraceState -> m DebugM ()
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (() ()
-> ReaderT
     (IORef TraceState)
     (m DebugM)
     (DebugClosureWithExtra Size () () () () () ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall a b.
a
-> ReaderT (IORef TraceState) (m DebugM) b
-> ReaderT (IORef TraceState) (m DebugM) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (CCSPtr -> ReaderT (IORef TraceState) (m DebugM) ())
-> (SrtCont -> ReaderT (IORef TraceState) (m DebugM) ())
-> (PayloadCont -> ReaderT (IORef TraceState) (m DebugM) ())
-> (SrtCont -> ReaderT (IORef TraceState) (m DebugM) ())
-> (StackCont -> ReaderT (IORef TraceState) (m DebugM) ())
-> (ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ())
-> SizedClosure
-> ReaderT
     (IORef TraceState)
     (m DebugM)
     (DebugClosureWithExtra Size () () () () () ())
forall (f :: * -> *) a b c d e g h i j k l n.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> DebugClosureWithExtra Size a c e h j l
-> f (DebugClosureWithExtra Size b d g i k n)
forall (m :: * -> * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d
       e g h i j k l n.
(Hextraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> (l -> f n)
-> m a c e h j l
-> f (m b d g i k n)
hextraverse CCSPtr -> ReaderT (IORef TraceState) (m DebugM) ()
forall {t :: (* -> *) -> * -> *}.
(MonadReader (IORef TraceState) (t (m DebugM)), MonadTrans t) =>
CCSPtr -> t (m DebugM) ()
goccs SrtCont -> ReaderT (IORef TraceState) (m DebugM) ()
gosrt PayloadCont -> ReaderT (IORef TraceState) (m DebugM) ()
gop SrtCont -> ReaderT (IORef TraceState) (m DebugM) ()
forall {t :: (* -> *) -> * -> *}.
(Monad (t (m DebugM)), MonadTrans t) =>
SrtCont -> t (m DebugM) ()
gocd StackCont -> ReaderT (IORef TraceState) (m DebugM) ()
gos ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
go SizedClosure
sc) IORef TraceState
st)


    gos :: StackCont -> ReaderT (IORef TraceState) (m DebugM) ()
gos StackCont
st = do
      GenStackFrames SrtCont ClosurePtr
st' <- m DebugM (GenStackFrames SrtCont ClosurePtr)
-> ReaderT
     (IORef TraceState) (m DebugM) (GenStackFrames SrtCont ClosurePtr)
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (IORef TraceState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM (GenStackFrames SrtCont ClosurePtr)
 -> ReaderT
      (IORef TraceState) (m DebugM) (GenStackFrames SrtCont ClosurePtr))
-> m DebugM (GenStackFrames SrtCont ClosurePtr)
-> ReaderT
     (IORef TraceState) (m DebugM) (GenStackFrames SrtCont ClosurePtr)
forall a b. (a -> b) -> a -> b
$ DebugM (GenStackFrames SrtCont ClosurePtr)
-> m DebugM (GenStackFrames SrtCont ClosurePtr)
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM (GenStackFrames SrtCont ClosurePtr)
 -> m DebugM (GenStackFrames SrtCont ClosurePtr))
-> DebugM (GenStackFrames SrtCont ClosurePtr)
-> m DebugM (GenStackFrames SrtCont ClosurePtr)
forall a b. (a -> b) -> a -> b
$ StackCont -> DebugM (GenStackFrames SrtCont ClosurePtr)
dereferenceStack StackCont
st
      m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (IORef TraceState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ())
-> m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ TraceFunctions m
-> GenStackFrames SrtCont ClosurePtr -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m
-> GenStackFrames SrtCont ClosurePtr -> m DebugM ()
stackTrace TraceFunctions m
k GenStackFrames SrtCont ClosurePtr
st'
      () ()
-> ReaderT
     (IORef TraceState) (m DebugM) (GenStackFrames SrtCont ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall a b.
a
-> ReaderT (IORef TraceState) (m DebugM) b
-> ReaderT (IORef TraceState) (m DebugM) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ())
-> GenStackFrames SrtCont ClosurePtr
-> ReaderT
     (IORef TraceState) (m DebugM) (GenStackFrames SrtCont ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b)
-> GenStackFrames SrtCont a -> f (GenStackFrames SrtCont b)
traverse ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
go GenStackFrames SrtCont ClosurePtr
st'

    gocd :: SrtCont -> t (m DebugM) ()
gocd SrtCont
d = do
      ConstrDesc
cd <- m DebugM ConstrDesc -> t (m DebugM) ConstrDesc
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM ConstrDesc -> t (m DebugM) ConstrDesc)
-> m DebugM ConstrDesc -> t (m DebugM) ConstrDesc
forall a b. (a -> b) -> a -> b
$ DebugM ConstrDesc -> m DebugM ConstrDesc
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM ConstrDesc -> m DebugM ConstrDesc)
-> DebugM ConstrDesc -> m DebugM ConstrDesc
forall a b. (a -> b) -> a -> b
$ SrtCont -> DebugM ConstrDesc
dereferenceConDesc SrtCont
d
      m DebugM () -> t (m DebugM) ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM () -> t (m DebugM) ()) -> m DebugM () -> t (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ TraceFunctions m -> ConstrDesc -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> ConstrDesc -> m DebugM ()
conDescTrace TraceFunctions m
k ConstrDesc
cd

    gop :: PayloadCont -> ReaderT (IORef TraceState) (m DebugM) ()
gop PayloadCont
p = do
      GenPapPayload ClosurePtr
p' <- m DebugM (GenPapPayload ClosurePtr)
-> ReaderT (IORef TraceState) (m DebugM) (GenPapPayload ClosurePtr)
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (IORef TraceState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM (GenPapPayload ClosurePtr)
 -> ReaderT
      (IORef TraceState) (m DebugM) (GenPapPayload ClosurePtr))
-> m DebugM (GenPapPayload ClosurePtr)
-> ReaderT (IORef TraceState) (m DebugM) (GenPapPayload ClosurePtr)
forall a b. (a -> b) -> a -> b
$ DebugM (GenPapPayload ClosurePtr)
-> m DebugM (GenPapPayload ClosurePtr)
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM (GenPapPayload ClosurePtr)
 -> m DebugM (GenPapPayload ClosurePtr))
-> DebugM (GenPapPayload ClosurePtr)
-> m DebugM (GenPapPayload ClosurePtr)
forall a b. (a -> b) -> a -> b
$ PayloadCont -> DebugM (GenPapPayload ClosurePtr)
dereferencePapPayload PayloadCont
p
      m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (IORef TraceState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ())
-> m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ TraceFunctions m -> GenPapPayload ClosurePtr -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> GenPapPayload ClosurePtr -> m DebugM ()
papTrace TraceFunctions m
k GenPapPayload ClosurePtr
p'
      () ()
-> ReaderT (IORef TraceState) (m DebugM) (GenPapPayload ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall a b.
a
-> ReaderT (IORef TraceState) (m DebugM) b
-> ReaderT (IORef TraceState) (m DebugM) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ())
-> GenPapPayload ClosurePtr
-> ReaderT (IORef TraceState) (m DebugM) (GenPapPayload ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenPapPayload a -> f (GenPapPayload b)
traverse ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
go GenPapPayload ClosurePtr
p'

    gosrt :: SrtCont -> ReaderT (IORef TraceState) (m DebugM) ()
gosrt SrtCont
p = do
      GenSrtPayload ClosurePtr
p' <- m DebugM (GenSrtPayload ClosurePtr)
-> ReaderT (IORef TraceState) (m DebugM) (GenSrtPayload ClosurePtr)
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (IORef TraceState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM (GenSrtPayload ClosurePtr)
 -> ReaderT
      (IORef TraceState) (m DebugM) (GenSrtPayload ClosurePtr))
-> m DebugM (GenSrtPayload ClosurePtr)
-> ReaderT (IORef TraceState) (m DebugM) (GenSrtPayload ClosurePtr)
forall a b. (a -> b) -> a -> b
$ DebugM (GenSrtPayload ClosurePtr)
-> m DebugM (GenSrtPayload ClosurePtr)
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM (GenSrtPayload ClosurePtr)
 -> m DebugM (GenSrtPayload ClosurePtr))
-> DebugM (GenSrtPayload ClosurePtr)
-> m DebugM (GenSrtPayload ClosurePtr)
forall a b. (a -> b) -> a -> b
$ SrtCont -> DebugM (GenSrtPayload ClosurePtr)
dereferenceSRT SrtCont
p
      m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ReaderT (IORef TraceState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ())
-> m DebugM () -> ReaderT (IORef TraceState) (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ TraceFunctions m -> GenSrtPayload ClosurePtr -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> GenSrtPayload ClosurePtr -> m DebugM ()
srtTrace TraceFunctions m
k GenSrtPayload ClosurePtr
p'
      () ()
-> ReaderT (IORef TraceState) (m DebugM) (GenSrtPayload ())
-> ReaderT (IORef TraceState) (m DebugM) ()
forall a b.
a
-> ReaderT (IORef TraceState) (m DebugM) b
-> ReaderT (IORef TraceState) (m DebugM) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ())
-> GenSrtPayload ClosurePtr
-> ReaderT (IORef TraceState) (m DebugM) (GenSrtPayload ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> GenSrtPayload a -> f (GenSrtPayload b)
traverse ClosurePtr -> ReaderT (IORef TraceState) (m DebugM) ()
go GenSrtPayload ClosurePtr
p'

    goccs :: CCSPtr -> t (m DebugM) ()
goccs CCSPtr
p = do
      IORef TraceState
mref <- t (m DebugM) (IORef TraceState)
forall r (m :: * -> *). MonadReader r m => m r
ask
      (Maybe Int
mnum_visited, Bool
b) <- m DebugM (Maybe Int, Bool) -> t (m DebugM) (Maybe Int, Bool)
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM (Maybe Int, Bool) -> t (m DebugM) (Maybe Int, Bool))
-> m DebugM (Maybe Int, Bool) -> t (m DebugM) (Maybe Int, Bool)
forall a b. (a -> b) -> a -> b
$ DebugM (Maybe Int, Bool) -> m DebugM (Maybe Int, Bool)
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM (Maybe Int, Bool) -> m DebugM (Maybe Int, Bool))
-> DebugM (Maybe Int, Bool) -> m DebugM (Maybe Int, Bool)
forall a b. (a -> b) -> a -> b
$ IO (Maybe Int, Bool) -> DebugM (Maybe Int, Bool)
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (ClosurePtr -> IORef TraceState -> IO (Maybe Int, Bool)
checkVisit (CCSPtr -> ClosurePtr
forall a b. Coercible a b => a -> b
coerce CCSPtr
p) IORef TraceState
mref)
      if Bool
b
        then () -> t (m DebugM) ()
forall a. a -> t (m DebugM) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        else do
          CCSPayload
p' <- m DebugM CCSPayload -> t (m DebugM) CCSPayload
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM CCSPayload -> t (m DebugM) CCSPayload)
-> m DebugM CCSPayload -> t (m DebugM) CCSPayload
forall a b. (a -> b) -> a -> b
$ DebugM CCSPayload -> m DebugM CCSPayload
forall (m :: * -> *) a. Monad m => m a -> m m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (DebugM CCSPayload -> m DebugM CCSPayload)
-> DebugM CCSPayload -> m DebugM CCSPayload
forall a b. (a -> b) -> a -> b
$ CCSPtr -> DebugM CCSPayload
dereferenceCCS CCSPtr
p
          m DebugM () -> t (m DebugM) ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m DebugM () -> t (m DebugM) ()) -> m DebugM () -> t (m DebugM) ()
forall a b. (a -> b) -> a -> b
$ TraceFunctions m -> CCSPtr -> CCSPayload -> m DebugM ()
forall (m :: (* -> *) -> * -> *).
TraceFunctions m -> CCSPtr -> CCSPayload -> m DebugM ()
ccsTrace TraceFunctions m
k CCSPtr
p CCSPayload
p'
          () () -> t (m DebugM) (GenCCSPayload () CCPtr) -> t (m DebugM) ()
forall a b. a -> t (m DebugM) b -> t (m DebugM) a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (CCSPtr -> t (m DebugM) ())
-> (CCPtr -> t (m DebugM) CCPtr)
-> CCSPayload
-> t (m DebugM) (GenCCSPayload () CCPtr)
forall (f :: * -> *) a c b d.
Applicative f =>
(a -> f c)
-> (b -> f d) -> GenCCSPayload a b -> f (GenCCSPayload c d)
forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse CCSPtr -> t (m DebugM) ()
goccs CCPtr -> t (m DebugM) CCPtr
forall a. a -> t (m DebugM) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure CCSPayload
p'