{-# 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 Data.Word
import GHC.Debug.Client.Monad.Simple
import Control.Concurrent.Async
import Data.IORef
import Control.Exception.Base
import Debug.Trace
import Control.Concurrent.STM
threads :: Int
threads :: Int
threads = Int
64
type InChan = TChan
type OutChan = TChan
unsafeLiftIO :: IO a -> DebugM a
unsafeLiftIO :: forall a. IO a -> DebugM a
unsafeLiftIO = ReaderT Debuggee IO a -> DebugM a
forall a. ReaderT Debuggee IO a -> DebugM a
DebugM (ReaderT Debuggee IO a -> DebugM a)
-> (IO a -> ReaderT Debuggee IO a) -> IO a -> DebugM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO a -> ReaderT Debuggee IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
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 (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 (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 (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 (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 ()) -> DebugM (Async s)
start ClosurePtrWithInfo a -> DebugM ()
go = IO (Async s) -> DebugM (Async s)
forall a. IO a -> DebugM a
unsafeLiftIO (IO (Async s) -> DebugM (Async s))
-> IO (Async s) -> DebugM (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 (m :: * -> *) a. Monad m => a -> m 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)
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 (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 (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
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
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 (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
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
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
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
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
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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (PayloadCont -> DebugM ())
-> (ConstrDescCont -> DebugM ())
-> (StackCont -> DebugM ())
-> (ClosurePtr -> DebugM ())
-> SizedClosure
-> DebugM (DebugClosureWithExtra Size () () () ())
forall (m :: * -> * -> * -> * -> *) (f :: * -> *) a b c d e g h i.
(Quadtraversable m, Applicative f) =>
(a -> f b)
-> (c -> f d)
-> (e -> f g)
-> (h -> f i)
-> m a c e h
-> f (m b d g i)
quadtraverse (IORef (ThreadState s) -> a -> PayloadCont -> DebugM ()
gop IORef (ThreadState s)
r a
a') ConstrDescCont -> 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 ()) -> DebugM ()
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ClosurePtr -> DebugM ())
-> StackFrames -> DebugM (GenStackFrames ())
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t 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 :: ConstrDescCont -> DebugM ()
gocd ConstrDescCont
d = do
ConstrDesc
cd <- ConstrDescCont -> DebugM ConstrDesc
dereferenceConDesc ConstrDescCont
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 (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)
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'
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 (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 (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 -> StackFrames -> DebugM ()
stackTrace :: !(GenStackFrames 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 (f :: * -> *). Applicative f => [Char] -> f ()
traceM ([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)
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 (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)
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
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
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
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)
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 (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 (m :: * -> *) a. Monad m => a -> m a
return ())
funcs :: TraceFunctionsIO () ()
funcs = (PapPayload -> DebugM ())
-> (StackFrames -> DebugM ())
-> (ClosurePtr
-> SizedClosure -> () -> DebugM ((), (), DebugM () -> DebugM ()))
-> (ClosurePtr -> () -> DebugM ())
-> (ConstrDesc -> DebugM ())
-> TraceFunctionsIO () ()
forall a s.
(PapPayload -> 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 StackFrames -> DebugM ()
forall {b}. b -> DebugM ()
nop 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 (m :: * -> *) a. Monad m => a -> m a
return ()))) ConstrDesc -> DebugM ()
forall {b}. b -> DebugM ()
nop
clos :: ClosurePtr -> SizedClosure -> ()
-> DebugM ((), (), DebugM () -> DebugM ())
clos :: ClosurePtr
-> SizedClosure -> () -> DebugM ((), (), DebugM () -> DebugM ())
clos ClosurePtr
_cp SizedClosure
sc ()
_ = do
let itb :: StgInfoTableWithPtr
itb = DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
-> StgInfoTableWithPtr
forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (SizedClosure
-> DebugClosure PayloadCont ConstrDescCont StackCont ClosurePtr
forall pap string s b.
DebugClosureWithSize pap string s b -> DebugClosure pap string s b
noSize SizedClosure
sc)
Maybe SourceInformation
_traced <- ConstrDescCont -> DebugM (Maybe SourceInformation)
getSourceInfo (StgInfoTableWithPtr -> ConstrDescCont
tableId StgInfoTableWithPtr
itb)
return ((), (), DebugM () -> DebugM ()
forall a. a -> a
id)