{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NumericUnderscores #-}
{-# OPTIONS_GHC -Wno-orphans #-}
module GHC.Debug.ParTrace ( traceParFromM, tracePar, TraceFunctionsIO(..), ClosurePtrWithInfo(..) ) where
import GHC.Debug.Types
import GHC.Debug.Client.Query
import qualified Data.IntMap as IM
import Data.Array.BitArray.IO hiding (map)
import Control.Monad.Reader
import Control.Monad
import Data.Word
import GHC.Debug.Client.Monad.Simple
import GHC.Debug.Client.Monad.Class
import Control.Concurrent.Async
import Data.IORef
import Control.Exception.Base
import Control.Concurrent.STM
threads :: Int
threads :: Int
threads = Int
64
type InChan = TChan
type OutChan = TChan
data ThreadState s = ThreadState (IM.IntMap (IM.IntMap (IOBitArray Word16))) (IORef s)
newtype ThreadInfo a = ThreadInfo (InChan (ClosurePtrWithInfo a))
data ClosurePtrWithInfo a = ClosurePtrWithInfo !a !ClosurePtr
type ThreadMap a = IM.IntMap (ThreadInfo a)
newtype TraceState a = TraceState { forall a. TraceState a -> ThreadMap a
visited :: (ThreadMap a) }
getKeyTriple :: ClosurePtr -> (Int, Int, Word16)
getKeyTriple :: ClosurePtr -> (Int, Int, Word16)
getKeyTriple 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
BlockPtr Word64
raw_mbk = ClosurePtr -> BlockPtr
applyMBlockMask ClosurePtr
cp
mbk :: Int
mbk = Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
raw_mbk Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
8
in (Int
mbk, Int
bk, Word64 -> Word16
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
offset)
getMBlockKey :: ClosurePtr -> Int
getMBlockKey :: ClosurePtr -> Int
getMBlockKey ClosurePtr
cp =
let BlockPtr Word64
raw_bk = ClosurePtr -> BlockPtr
applyMBlockMask ClosurePtr
cp
in (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` Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
mblockMask Int -> Int -> Int
forall a. Integral a => a -> a -> a
`div` Int
4) Int -> Int -> Int
forall a. Integral a => a -> a -> a
`mod` Int
threads
sendToChan :: TraceState a -> ClosurePtrWithInfo a -> DebugM ()
sendToChan :: forall a. TraceState a -> ClosurePtrWithInfo a -> DebugM ()
sendToChan TraceState a
ts cpi :: ClosurePtrWithInfo a
cpi@(ClosurePtrWithInfo a
_ ClosurePtr
cp) = ReaderT Debuggee IO () -> DebugM ()
forall a. ReaderT Debuggee IO a -> DebugM a
DebugM (ReaderT Debuggee IO () -> DebugM ())
-> ReaderT Debuggee IO () -> DebugM ()
forall a b. (a -> b) -> a -> b
$ IO () -> ReaderT Debuggee IO ()
forall a. IO a -> ReaderT Debuggee IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ReaderT Debuggee IO ())
-> IO () -> ReaderT Debuggee IO ()
forall a b. (a -> b) -> a -> b
$ do
let st :: ThreadMap a
st = TraceState a -> ThreadMap a
forall a. TraceState a -> ThreadMap a
visited TraceState a
ts
mkey :: Int
mkey = ClosurePtr -> Int
getMBlockKey ClosurePtr
cp
case Int -> ThreadMap a -> Maybe (ThreadInfo a)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
mkey ThreadMap a
st of
Maybe (ThreadInfo a)
Nothing -> [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Not enough chans:" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
mkey [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
threads
Just (ThreadInfo InChan (ClosurePtrWithInfo a)
ic) -> STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ InChan (ClosurePtrWithInfo a) -> ClosurePtrWithInfo a -> STM ()
forall a. TChan a -> a -> STM ()
writeTChan InChan (ClosurePtrWithInfo a)
ic ClosurePtrWithInfo a
cpi
initThread :: Monoid s =>
Int
-> TraceFunctionsIO a s
-> DebugM (ThreadInfo a, STM Bool, (ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
initThread :: forall s a.
Monoid s =>
Int
-> TraceFunctionsIO a s
-> DebugM
(ThreadInfo a, STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
initThread Int
n TraceFunctionsIO a s
k = ReaderT
Debuggee
IO
(ThreadInfo a, STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
-> DebugM
(ThreadInfo a, STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
forall a. ReaderT Debuggee IO a -> DebugM a
DebugM (ReaderT
Debuggee
IO
(ThreadInfo a, STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
-> DebugM
(ThreadInfo a, STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)))
-> ReaderT
Debuggee
IO
(ThreadInfo a, STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
-> DebugM
(ThreadInfo a, STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
forall a b. (a -> b) -> a -> b
$ do
Debuggee
e <- ReaderT Debuggee IO Debuggee
forall r (m :: * -> *). MonadReader r m => m r
ask
TChan (ClosurePtrWithInfo a)
ic <- IO (TChan (ClosurePtrWithInfo a))
-> ReaderT Debuggee IO (TChan (ClosurePtrWithInfo a))
forall a. IO a -> ReaderT Debuggee IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TChan (ClosurePtrWithInfo a))
-> ReaderT Debuggee IO (TChan (ClosurePtrWithInfo a)))
-> IO (TChan (ClosurePtrWithInfo a))
-> ReaderT Debuggee IO (TChan (ClosurePtrWithInfo a))
forall a b. (a -> b) -> a -> b
$ IO (TChan (ClosurePtrWithInfo a))
forall a. IO (TChan a)
newTChanIO
let oc :: TChan (ClosurePtrWithInfo a)
oc = TChan (ClosurePtrWithInfo a)
ic
IORef s
ref <- IO (IORef s) -> ReaderT Debuggee IO (IORef s)
forall a. IO a -> ReaderT Debuggee IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef s) -> ReaderT Debuggee IO (IORef s))
-> IO (IORef s) -> ReaderT Debuggee IO (IORef s)
forall a b. (a -> b) -> a -> b
$ s -> IO (IORef s)
forall a. a -> IO (IORef a)
newIORef s
forall a. Monoid a => a
mempty
TVar Bool
worker_active <- IO (TVar Bool) -> ReaderT Debuggee IO (TVar Bool)
forall a. IO a -> ReaderT Debuggee IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (TVar Bool) -> ReaderT Debuggee IO (TVar Bool))
-> IO (TVar Bool) -> ReaderT Debuggee IO (TVar Bool)
forall a b. (a -> b) -> a -> b
$ Bool -> IO (TVar Bool)
forall a. a -> IO (TVar a)
newTVarIO Bool
True
let start :: (ClosurePtrWithInfo a -> DebugM ()) -> m (Async s)
start ClosurePtrWithInfo a -> DebugM ()
go = IO (Async s) -> m (Async s)
forall a. IO a -> m a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (IO (Async s) -> m (Async s)) -> IO (Async s) -> m (Async s)
forall a b. (a -> b) -> a -> b
$ IO s -> IO (Async s)
forall a. IO a -> IO (Async a)
async (IO s -> IO (Async s)) -> IO s -> IO (Async s)
forall a b. (a -> b) -> a -> b
$ Debuggee -> DebugM s -> IO s
forall a. Debuggee -> DebugM a -> IO a
runSimple Debuggee
e (DebugM s -> IO s) -> DebugM s -> IO s
forall a b. (a -> b) -> a -> b
$ Int
-> TraceFunctionsIO a s
-> TVar Bool
-> IORef s
-> (ClosurePtrWithInfo a -> DebugM ())
-> TChan (ClosurePtrWithInfo a)
-> DebugM s
forall s a.
Monoid s =>
Int
-> TraceFunctionsIO a s
-> TVar Bool
-> IORef s
-> (ClosurePtrWithInfo a -> DebugM ())
-> OutChan (ClosurePtrWithInfo a)
-> DebugM s
workerThread Int
n TraceFunctionsIO a s
k TVar Bool
worker_active IORef s
ref ClosurePtrWithInfo a -> DebugM ()
go TChan (ClosurePtrWithInfo a)
oc
finished :: STM Bool
finished = do
Bool
active <- Bool -> Bool
not (Bool -> Bool) -> STM Bool -> STM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TVar Bool -> STM Bool
forall a. TVar a -> STM a
readTVar TVar Bool
worker_active
Bool
empty <- TChan (ClosurePtrWithInfo a) -> STM Bool
forall a. TChan a -> STM Bool
isEmptyTChan TChan (ClosurePtrWithInfo a)
ic
return (Bool
active Bool -> Bool -> Bool
&& Bool
empty)
(ThreadInfo a, STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
-> ReaderT
Debuggee
IO
(ThreadInfo a, STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
forall a. a -> ReaderT Debuggee IO a
forall (f :: * -> *) a. Applicative f => a -> f a
return (TChan (ClosurePtrWithInfo a) -> ThreadInfo a
forall a. InChan (ClosurePtrWithInfo a) -> ThreadInfo a
ThreadInfo TChan (ClosurePtrWithInfo a)
ic, STM Bool
finished, (ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)
forall {m :: * -> *}.
DebugMonad m =>
(ClosurePtrWithInfo a -> DebugM ()) -> m (Async s)
start)
workerThread :: forall s a . Monoid s => Int -> TraceFunctionsIO a s -> TVar Bool -> IORef s -> (ClosurePtrWithInfo a -> DebugM ()) -> OutChan (ClosurePtrWithInfo a) -> DebugM s
workerThread :: forall s a.
Monoid s =>
Int
-> TraceFunctionsIO a s
-> TVar Bool
-> IORef s
-> (ClosurePtrWithInfo a -> DebugM ())
-> OutChan (ClosurePtrWithInfo a)
-> DebugM s
workerThread Int
n TraceFunctionsIO a s
k TVar Bool
worker_active IORef s
ref ClosurePtrWithInfo a -> DebugM ()
go OutChan (ClosurePtrWithInfo a)
oc = ReaderT Debuggee IO s -> DebugM s
forall a. ReaderT Debuggee IO a -> DebugM a
DebugM (ReaderT Debuggee IO s -> DebugM s)
-> ReaderT Debuggee IO s -> DebugM s
forall a b. (a -> b) -> a -> b
$ do
Debuggee
d <- ReaderT Debuggee IO Debuggee
forall r (m :: * -> *). MonadReader r m => m r
ask
IORef (ThreadState s)
r <- IO (IORef (ThreadState s))
-> ReaderT Debuggee IO (IORef (ThreadState s))
forall a. IO a -> ReaderT Debuggee IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef (ThreadState s))
-> ReaderT Debuggee IO (IORef (ThreadState s)))
-> IO (IORef (ThreadState s))
-> ReaderT Debuggee IO (IORef (ThreadState s))
forall a b. (a -> b) -> a -> b
$ ThreadState s -> IO (IORef (ThreadState s))
forall a. a -> IO (IORef a)
newIORef (IntMap (IntMap (IOBitArray Word16)) -> IORef s -> ThreadState s
forall s.
IntMap (IntMap (IOBitArray Word16)) -> IORef s -> ThreadState s
ThreadState IntMap (IntMap (IOBitArray Word16))
forall a. IntMap a
IM.empty IORef s
ref)
IO s -> ReaderT Debuggee IO s
forall a. IO a -> ReaderT Debuggee IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO s -> ReaderT Debuggee IO s) -> IO s -> ReaderT Debuggee IO s
forall a b. (a -> b) -> a -> b
$ Debuggee -> DebugM s -> IO s
forall a. Debuggee -> DebugM a -> IO a
runSimple Debuggee
d (IORef (ThreadState s) -> DebugM s
forall {s}. IORef (ThreadState s) -> DebugM s
loop IORef (ThreadState s)
r)
where
loop :: IORef (ThreadState s) -> DebugM s
loop IORef (ThreadState s)
r = do
Either AsyncCancelled (ClosurePtrWithInfo a)
mcp <- IO (Either AsyncCancelled (ClosurePtrWithInfo a))
-> DebugM (Either AsyncCancelled (ClosurePtrWithInfo a))
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (IO (Either AsyncCancelled (ClosurePtrWithInfo a))
-> DebugM (Either AsyncCancelled (ClosurePtrWithInfo a)))
-> IO (Either AsyncCancelled (ClosurePtrWithInfo a))
-> DebugM (Either AsyncCancelled (ClosurePtrWithInfo a))
forall a b. (a -> b) -> a -> b
$ IO (ClosurePtrWithInfo a)
-> IO (Either AsyncCancelled (ClosurePtrWithInfo a))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (ClosurePtrWithInfo a)
-> IO (Either AsyncCancelled (ClosurePtrWithInfo a)))
-> IO (ClosurePtrWithInfo a)
-> IO (Either AsyncCancelled (ClosurePtrWithInfo a))
forall a b. (a -> b) -> a -> b
$ do
STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
worker_active Bool
False
STM (ClosurePtrWithInfo a) -> IO (ClosurePtrWithInfo a)
forall a. STM a -> IO a
atomically (STM (ClosurePtrWithInfo a) -> IO (ClosurePtrWithInfo a))
-> STM (ClosurePtrWithInfo a) -> IO (ClosurePtrWithInfo a)
forall a b. (a -> b) -> a -> b
$ do
ClosurePtrWithInfo a
v <- OutChan (ClosurePtrWithInfo a) -> STM (ClosurePtrWithInfo a)
forall a. TChan a -> STM a
readTChan OutChan (ClosurePtrWithInfo a)
oc
TVar Bool -> Bool -> STM ()
forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
worker_active Bool
True
return ClosurePtrWithInfo a
v
case Either AsyncCancelled (ClosurePtrWithInfo a)
mcp of
Left AsyncCancelled
AsyncCancelled -> do
IO s -> DebugM s
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (IO s -> DebugM s) -> IO s -> DebugM s
forall a b. (a -> b) -> a -> b
$ IORef s -> IO s
forall a. IORef a -> IO a
readIORef IORef s
ref
Right ClosurePtrWithInfo a
cpi -> IORef (ThreadState s) -> ClosurePtrWithInfo a -> DebugM ()
forall {s}.
IORef (ThreadState s) -> ClosurePtrWithInfo a -> DebugM ()
deref IORef (ThreadState s)
r ClosurePtrWithInfo a
cpi DebugM () -> DebugM s -> DebugM s
forall a b. DebugM a -> DebugM b -> DebugM b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> IORef (ThreadState s) -> DebugM s
loop IORef (ThreadState s)
r
deref :: IORef (ThreadState s) -> ClosurePtrWithInfo a -> DebugM ()
deref IORef (ThreadState s)
r (ClosurePtrWithInfo a
a ClosurePtr
cp) = do
ThreadState s
m <- IO (ThreadState s) -> DebugM (ThreadState s)
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (IO (ThreadState s) -> DebugM (ThreadState s))
-> IO (ThreadState s) -> DebugM (ThreadState s)
forall a b. (a -> b) -> a -> b
$ IORef (ThreadState s) -> IO (ThreadState s)
forall a. IORef a -> IO a
readIORef IORef (ThreadState s)
r
do
(ThreadState s
m', Bool
b) <- IO (ThreadState s, Bool) -> DebugM (ThreadState s, Bool)
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (IO (ThreadState s, Bool) -> DebugM (ThreadState s, Bool))
-> IO (ThreadState s, Bool) -> DebugM (ThreadState s, Bool)
forall a b. (a -> b) -> a -> b
$ ClosurePtr -> ThreadState s -> IO (ThreadState s, Bool)
forall s. ClosurePtr -> ThreadState s -> IO (ThreadState s, Bool)
checkVisit ClosurePtr
cp ThreadState s
m
IO () -> DebugM ()
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (IO () -> DebugM ()) -> IO () -> DebugM ()
forall a b. (a -> b) -> a -> b
$ IORef (ThreadState s) -> ThreadState s -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (ThreadState s)
r ThreadState s
m'
if Bool
b
then do
s
s <- TraceFunctionsIO a s -> ClosurePtr -> a -> DebugM s
forall a s. TraceFunctionsIO a s -> ClosurePtr -> a -> DebugM s
visitedVal TraceFunctionsIO a s
k ClosurePtr
cp a
a
IO () -> DebugM ()
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (IO () -> DebugM ()) -> IO () -> DebugM ()
forall a b. (a -> b) -> a -> b
$ IORef s -> (s -> s) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef s
ref (s
s s -> s -> s
forall a. Semigroup a => a -> a -> a
<>)
else do
SizedClosure
sc <- ClosurePtr -> DebugM SizedClosure
dereferenceClosure ClosurePtr
cp
(a
a', s
s, DebugM () -> DebugM ()
cont) <- TraceFunctionsIO a s
-> ClosurePtr
-> SizedClosure
-> a
-> DebugM (a, s, DebugM () -> DebugM ())
forall a s.
TraceFunctionsIO a s
-> ClosurePtr
-> SizedClosure
-> a
-> DebugM (a, s, DebugM () -> DebugM ())
closTrace TraceFunctionsIO a s
k ClosurePtr
cp SizedClosure
sc a
a
IO () -> DebugM ()
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (IO () -> DebugM ()) -> IO () -> DebugM ()
forall a b. (a -> b) -> a -> b
$ IORef s -> (s -> s) -> IO ()
forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef s
ref (s
s s -> s -> s
forall a. Semigroup a => a -> a -> a
<>)
DebugM () -> DebugM ()
cont (() ()
-> DebugM (DebugClosureWithExtra Size () () () () ()) -> DebugM ()
forall a b. a -> DebugM b -> DebugM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (SrtCont -> DebugM ())
-> (PayloadCont -> DebugM ())
-> (SrtCont -> DebugM ())
-> (StackCont -> DebugM ())
-> (ClosurePtr -> DebugM ())
-> SizedClosure
-> DebugM (DebugClosureWithExtra Size () () () () ())
forall (f :: * -> *) a b c d e g h i j k.
Applicative f =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> DebugClosureWithExtra Size a c e h j
-> f (DebugClosureWithExtra Size b d g i k)
forall (m :: * -> * -> * -> * -> * -> *) (f :: * -> *) a b c d e g
h i j k.
(Quintraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> (j -> f k)
-> m a c e h j
-> f (m b d g i k)
quintraverse (IORef (ThreadState s) -> a -> SrtCont -> DebugM ()
gosrt IORef (ThreadState s)
r a
a') (IORef (ThreadState s) -> a -> PayloadCont -> DebugM ()
gop IORef (ThreadState s)
r a
a') SrtCont -> DebugM ()
gocd (IORef (ThreadState s) -> a -> StackCont -> DebugM ()
gos IORef (ThreadState s)
r a
a') (IORef (ThreadState s) -> ClosurePtrWithInfo a -> DebugM ()
goc IORef (ThreadState s)
r (ClosurePtrWithInfo a -> DebugM ())
-> (ClosurePtr -> ClosurePtrWithInfo a) -> ClosurePtr -> DebugM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ClosurePtr -> ClosurePtrWithInfo a
forall a. a -> ClosurePtr -> ClosurePtrWithInfo a
ClosurePtrWithInfo a
a') SizedClosure
sc)
goc :: IORef (ThreadState s) -> ClosurePtrWithInfo a -> DebugM ()
goc IORef (ThreadState s)
r c :: ClosurePtrWithInfo a
c@(ClosurePtrWithInfo a
_i ClosurePtr
cp) =
let mkey :: Int
mkey = ClosurePtr -> Int
getMBlockKey ClosurePtr
cp
in if (Int
mkey Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
n)
then IORef (ThreadState s) -> ClosurePtrWithInfo a -> DebugM ()
deref IORef (ThreadState s)
r ClosurePtrWithInfo a
c
else ClosurePtrWithInfo a -> DebugM ()
go ClosurePtrWithInfo a
c
gos :: IORef (ThreadState s) -> a -> StackCont -> DebugM ()
gos IORef (ThreadState s)
r a
a StackCont
st = do
StackFrames
st' <- StackCont -> DebugM StackFrames
dereferenceStack StackCont
st
TraceFunctionsIO a s -> StackFrames -> DebugM ()
forall a s. TraceFunctionsIO a s -> StackFrames -> DebugM ()
stackTrace TraceFunctionsIO a s
k StackFrames
st'
() () -> DebugM (GenStackFrames SrtCont ()) -> DebugM ()
forall a b. a -> DebugM b -> DebugM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ClosurePtr -> DebugM ())
-> StackFrames -> 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 (IORef (ThreadState s) -> ClosurePtrWithInfo a -> DebugM ()
goc IORef (ThreadState s)
r (ClosurePtrWithInfo a -> DebugM ())
-> (ClosurePtr -> ClosurePtrWithInfo a) -> ClosurePtr -> DebugM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ClosurePtr -> ClosurePtrWithInfo a
forall a. a -> ClosurePtr -> ClosurePtrWithInfo a
ClosurePtrWithInfo a
a) StackFrames
st'
gocd :: SrtCont -> DebugM ()
gocd SrtCont
d = do
ConstrDesc
cd <- SrtCont -> DebugM ConstrDesc
dereferenceConDesc SrtCont
d
TraceFunctionsIO a s -> ConstrDesc -> DebugM ()
forall a s. TraceFunctionsIO a s -> ConstrDesc -> DebugM ()
conDescTrace TraceFunctionsIO a s
k ConstrDesc
cd
gop :: IORef (ThreadState s) -> a -> PayloadCont -> DebugM ()
gop IORef (ThreadState s)
r a
a PayloadCont
p = do
PapPayload
p' <- PayloadCont -> DebugM PapPayload
dereferencePapPayload PayloadCont
p
TraceFunctionsIO a s -> PapPayload -> DebugM ()
forall a s. TraceFunctionsIO a s -> PapPayload -> DebugM ()
papTrace TraceFunctionsIO a s
k PapPayload
p'
() () -> DebugM (GenPapPayload ()) -> DebugM ()
forall a b. a -> DebugM b -> DebugM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ClosurePtr -> DebugM ())
-> PapPayload -> 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 (IORef (ThreadState s) -> ClosurePtrWithInfo a -> DebugM ()
goc IORef (ThreadState s)
r (ClosurePtrWithInfo a -> DebugM ())
-> (ClosurePtr -> ClosurePtrWithInfo a) -> ClosurePtr -> DebugM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ClosurePtr -> ClosurePtrWithInfo a
forall a. a -> ClosurePtr -> ClosurePtrWithInfo a
ClosurePtrWithInfo a
a) PapPayload
p'
gosrt :: IORef (ThreadState s) -> a -> SrtCont -> DebugM ()
gosrt IORef (ThreadState s)
r a
a SrtCont
p = do
SrtPayload
p' <- SrtCont -> DebugM SrtPayload
dereferenceSRT SrtCont
p
TraceFunctionsIO a s -> SrtPayload -> DebugM ()
forall a s. TraceFunctionsIO a s -> SrtPayload -> DebugM ()
srtTrace TraceFunctionsIO a s
k SrtPayload
p'
() () -> DebugM (GenSrtPayload ()) -> DebugM ()
forall a b. a -> DebugM b -> DebugM a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ClosurePtr -> DebugM ())
-> SrtPayload -> 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 (IORef (ThreadState s) -> ClosurePtrWithInfo a -> DebugM ()
goc IORef (ThreadState s)
r (ClosurePtrWithInfo a -> DebugM ())
-> (ClosurePtr -> ClosurePtrWithInfo a) -> ClosurePtr -> DebugM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ClosurePtr -> ClosurePtrWithInfo a
forall a. a -> ClosurePtr -> ClosurePtrWithInfo a
ClosurePtrWithInfo a
a) SrtPayload
p'
handleBlockLevel :: IM.Key
-> Word16
-> IM.IntMap (IOBitArray Word16)
-> IO (IM.IntMap (IOBitArray Word16), Bool)
handleBlockLevel :: Int
-> Word16
-> IntMap (IOBitArray Word16)
-> IO (IntMap (IOBitArray Word16), Bool)
handleBlockLevel Int
bk Word16
offset IntMap (IOBitArray Word16)
m = do
case Int -> IntMap (IOBitArray Word16) -> Maybe (IOBitArray Word16)
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
bk IntMap (IOBitArray Word16)
m 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
return (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)
m, 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 (IntMap (IOBitArray Word16)
m, Bool
res)
checkVisit :: ClosurePtr -> ThreadState s -> IO (ThreadState s, Bool)
checkVisit :: forall s. ClosurePtr -> ThreadState s -> IO (ThreadState s, Bool)
checkVisit ClosurePtr
cp ThreadState s
st = do
let (Int
mbk, Int
bk, Word16
offset) = ClosurePtr -> (Int, Int, Word16)
getKeyTriple ClosurePtr
cp
ThreadState IntMap (IntMap (IOBitArray Word16))
v IORef s
ref = ThreadState s
st
case Int
-> IntMap (IntMap (IOBitArray Word16))
-> Maybe (IntMap (IOBitArray Word16))
forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
mbk IntMap (IntMap (IOBitArray Word16))
v of
Maybe (IntMap (IOBitArray Word16))
Nothing -> do
(IntMap (IOBitArray Word16)
st', Bool
res) <- Int
-> Word16
-> IntMap (IOBitArray Word16)
-> IO (IntMap (IOBitArray Word16), Bool)
handleBlockLevel Int
bk Word16
offset IntMap (IOBitArray Word16)
forall a. IntMap a
IM.empty
(ThreadState s, Bool) -> IO (ThreadState s, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap (IntMap (IOBitArray Word16)) -> IORef s -> ThreadState s
forall s.
IntMap (IntMap (IOBitArray Word16)) -> IORef s -> ThreadState s
ThreadState (Int
-> IntMap (IOBitArray Word16)
-> IntMap (IntMap (IOBitArray Word16))
-> IntMap (IntMap (IOBitArray Word16))
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
mbk IntMap (IOBitArray Word16)
st' IntMap (IntMap (IOBitArray Word16))
v) IORef s
ref, Bool
res)
Just IntMap (IOBitArray Word16)
bm -> do
(IntMap (IOBitArray Word16)
st', Bool
res) <- Int
-> Word16
-> IntMap (IOBitArray Word16)
-> IO (IntMap (IOBitArray Word16), Bool)
handleBlockLevel Int
bk Word16
offset IntMap (IOBitArray Word16)
bm
(ThreadState s, Bool) -> IO (ThreadState s, Bool)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IntMap (IntMap (IOBitArray Word16)) -> IORef s -> ThreadState s
forall s.
IntMap (IntMap (IOBitArray Word16)) -> IORef s -> ThreadState s
ThreadState (Int
-> IntMap (IOBitArray Word16)
-> IntMap (IntMap (IOBitArray Word16))
-> IntMap (IntMap (IOBitArray Word16))
forall a. Int -> a -> IntMap a -> IntMap a
IM.insert Int
mbk IntMap (IOBitArray Word16)
st' IntMap (IntMap (IOBitArray Word16))
v) IORef s
ref, Bool
res)
data TraceFunctionsIO a s =
TraceFunctionsIO { forall a s. TraceFunctionsIO a s -> PapPayload -> DebugM ()
papTrace :: !(GenPapPayload ClosurePtr -> DebugM ())
, forall a s. TraceFunctionsIO a s -> SrtPayload -> DebugM ()
srtTrace :: !(GenSrtPayload ClosurePtr -> DebugM ())
, forall a s. TraceFunctionsIO a s -> StackFrames -> DebugM ()
stackTrace :: !(GenStackFrames SrtCont ClosurePtr -> DebugM ())
, forall a s.
TraceFunctionsIO a s
-> ClosurePtr
-> SizedClosure
-> a
-> DebugM (a, s, DebugM () -> DebugM ())
closTrace :: !(ClosurePtr -> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))
, forall a s. TraceFunctionsIO a s -> ClosurePtr -> a -> DebugM s
visitedVal :: !(ClosurePtr -> a -> DebugM s)
, forall a s. TraceFunctionsIO a s -> ConstrDesc -> DebugM ()
conDescTrace :: !(ConstrDesc -> DebugM ())
}
traceParFromM :: Monoid s => TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s
traceParFromM :: forall s a.
Monoid s =>
TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s
traceParFromM TraceFunctionsIO a s
k [ClosurePtrWithInfo a]
cps = do
[Char] -> DebugM ()
forall (m :: * -> *). DebugMonad m => [Char] -> m ()
traceMsg ([Char]
"SPAWNING: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
threads)
([(Int, ThreadInfo a)]
init_mblocks, [STM Bool]
work_actives, [(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)]
start) <- [((Int, ThreadInfo a), STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))]
-> ([(Int, ThreadInfo a)], [STM Bool],
[(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)])
forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 ([((Int, ThreadInfo a), STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))]
-> ([(Int, ThreadInfo a)], [STM Bool],
[(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)]))
-> DebugM
[((Int, ThreadInfo a), STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))]
-> DebugM
([(Int, ThreadInfo a)], [STM Bool],
[(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Int
-> DebugM
((Int, ThreadInfo a), STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)))
-> [Int]
-> DebugM
[((Int, ThreadInfo a), STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\Int
b -> do
(ThreadInfo a
ti, STM Bool
working, (ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)
start) <- Int
-> TraceFunctionsIO a s
-> DebugM
(ThreadInfo a, STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
forall s a.
Monoid s =>
Int
-> TraceFunctionsIO a s
-> DebugM
(ThreadInfo a, STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
initThread Int
b TraceFunctionsIO a s
k
((Int, ThreadInfo a), STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
-> DebugM
((Int, ThreadInfo a), STM Bool,
(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Int -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
b, ThreadInfo a
ti), STM Bool
working, (ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)
start)) [Int
0 .. Int
threads Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
let ts_map :: IntMap (ThreadInfo a)
ts_map = [(Int, ThreadInfo a)] -> IntMap (ThreadInfo a)
forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int, ThreadInfo a)]
init_mblocks
go :: ClosurePtrWithInfo a -> DebugM ()
go = TraceState a -> ClosurePtrWithInfo a -> DebugM ()
forall a. TraceState a -> ClosurePtrWithInfo a -> DebugM ()
sendToChan (IntMap (ThreadInfo a) -> TraceState a
forall a. ThreadMap a -> TraceState a
TraceState IntMap (ThreadInfo a)
ts_map)
[Async s]
as <- [DebugM (Async s)] -> DebugM [Async s]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ((((ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
-> DebugM (Async s))
-> [(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)]
-> [DebugM (Async s)]
forall a b. (a -> b) -> [a] -> [b]
map (((ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s))
-> (ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)
forall a b. (a -> b) -> a -> b
$ ClosurePtrWithInfo a -> DebugM ()
go) [(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)]
start )
(ClosurePtrWithInfo a -> DebugM ())
-> [ClosurePtrWithInfo a] -> DebugM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ClosurePtrWithInfo a -> DebugM ()
go [ClosurePtrWithInfo a]
cps
IO () -> DebugM ()
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (IO () -> DebugM ()) -> IO () -> DebugM ()
forall a b. (a -> b) -> a -> b
$ [STM Bool] -> IO ()
waitFinish [STM Bool]
work_actives
IO () -> DebugM ()
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (IO () -> DebugM ()) -> IO () -> DebugM ()
forall a b. (a -> b) -> a -> b
$ (Async s -> IO ()) -> [Async s] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Async s -> IO ()
forall a. Async a -> IO ()
cancel [Async s]
as
IO s -> DebugM s
forall a. IO a -> DebugM a
forall (m :: * -> *) a. DebugMonad m => IO a -> m a
unsafeLiftIO (IO s -> DebugM s) -> IO s -> DebugM s
forall a b. (a -> b) -> a -> b
$ [s] -> s
forall a. Monoid a => [a] -> a
mconcat ([s] -> s) -> IO [s] -> IO s
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Async s -> IO s) -> [Async s] -> IO [s]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Async s -> IO s
forall a. Async a -> IO a
wait [Async s]
as
waitFinish :: [STM Bool] -> IO ()
waitFinish :: [STM Bool] -> IO ()
waitFinish [STM Bool]
working = STM () -> IO ()
forall a. STM a -> IO a
atomically ([STM Bool] -> STM ()
checkDone [STM Bool]
working)
where
checkDone :: [STM Bool] -> STM ()
checkDone [] = () -> STM ()
forall a. a -> STM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkDone (STM Bool
x:[STM Bool]
xs) = do
Bool
b <- STM Bool
x
if Bool
b then [STM Bool] -> STM ()
checkDone [STM Bool]
xs else STM ()
forall a. STM a
retry
tracePar :: [ClosurePtr] -> DebugM ()
tracePar :: [ClosurePtr] -> DebugM ()
tracePar = TraceFunctionsIO () () -> [ClosurePtrWithInfo ()] -> DebugM ()
forall s a.
Monoid s =>
TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s
traceParFromM TraceFunctionsIO () ()
funcs ([ClosurePtrWithInfo ()] -> DebugM ())
-> ([ClosurePtr] -> [ClosurePtrWithInfo ()])
-> [ClosurePtr]
-> DebugM ()
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 ())
funcs :: TraceFunctionsIO () ()
funcs = (PapPayload -> DebugM ())
-> (SrtPayload -> DebugM ())
-> (StackFrames -> DebugM ())
-> (ClosurePtr
-> SizedClosure -> () -> DebugM ((), (), DebugM () -> DebugM ()))
-> (ClosurePtr -> () -> DebugM ())
-> (ConstrDesc -> DebugM ())
-> TraceFunctionsIO () ()
forall a s.
(PapPayload -> DebugM ())
-> (SrtPayload -> DebugM ())
-> (StackFrames -> DebugM ())
-> (ClosurePtr
-> SizedClosure -> a -> DebugM (a, s, DebugM () -> DebugM ()))
-> (ClosurePtr -> a -> DebugM s)
-> (ConstrDesc -> DebugM ())
-> TraceFunctionsIO a s
TraceFunctionsIO PapPayload -> DebugM ()
forall {b}. b -> DebugM ()
nop SrtPayload -> DebugM ()
forall {b}. b -> DebugM ()
nop StackFrames -> DebugM ()
stack ClosurePtr
-> SizedClosure -> () -> DebugM ((), (), DebugM () -> DebugM ())
clos ((() -> DebugM ()) -> ClosurePtr -> () -> DebugM ()
forall a b. a -> b -> a
const (DebugM () -> () -> DebugM ()
forall a b. a -> b -> a
const (() -> DebugM ()
forall a. a -> DebugM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()))) ConstrDesc -> DebugM ()
forall {b}. b -> DebugM ()
nop
stack :: GenStackFrames SrtCont ClosurePtr -> DebugM ()
stack :: StackFrames -> DebugM ()
stack StackFrames
fs =
let stack_frames :: [DebugStackFrame SrtCont ClosurePtr]
stack_frames = StackFrames -> [DebugStackFrame SrtCont ClosurePtr]
forall srt b. GenStackFrames srt b -> [DebugStackFrame srt b]
getFrames StackFrames
fs
in (DebugStackFrame SrtCont ClosurePtr
-> DebugM (Maybe SourceInformation))
-> [DebugStackFrame SrtCont ClosurePtr] -> DebugM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (SrtCont -> DebugM (Maybe SourceInformation)
getSourceInfo (SrtCont -> DebugM (Maybe SourceInformation))
-> (DebugStackFrame SrtCont ClosurePtr -> SrtCont)
-> DebugStackFrame SrtCont ClosurePtr
-> DebugM (Maybe SourceInformation)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgInfoTableWithPtr -> SrtCont
tableId (StgInfoTableWithPtr -> SrtCont)
-> (DebugStackFrame SrtCont ClosurePtr -> StgInfoTableWithPtr)
-> DebugStackFrame SrtCont ClosurePtr
-> SrtCont
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DebugStackFrame SrtCont ClosurePtr -> StgInfoTableWithPtr
forall srt b. DebugStackFrame srt b -> StgInfoTableWithPtr
frame_info) [DebugStackFrame SrtCont ClosurePtr]
stack_frames
clos :: ClosurePtr -> SizedClosure -> ()
-> DebugM ((), (), DebugM () -> DebugM ())
clos :: ClosurePtr
-> SizedClosure -> () -> DebugM ((), (), DebugM () -> DebugM ())
clos ClosurePtr
_cp SizedClosure
sc ()
_ = do
let itb :: StgInfoTableWithPtr
itb = DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr
-> StgInfoTableWithPtr
forall srt pap string s b.
DebugClosure srt pap string s b -> StgInfoTableWithPtr
info (SizedClosure
-> DebugClosure SrtCont PayloadCont SrtCont StackCont ClosurePtr
forall srt pap string s b.
DebugClosureWithSize srt pap string s b
-> DebugClosure srt pap string s b
noSize SizedClosure
sc)
Maybe SourceInformation
_traced <- SrtCont -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> SrtCont
tableId StgInfoTableWithPtr
itb)
return ((), (), DebugM () -> DebugM ()
forall a. a -> a
id)