{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE NumericUnderscores #-}
{-# OPTIONS_GHC -Wno-orphans #-}
-- | Functions to support the constant space traversal of a heap.
-- This module is like the Trace module but performs the tracing in
-- parellel. The speed-up is quite modest but hopefully can be improved in
-- future.
--
-- The tracing functions create a thread for each MBlock which we
-- traverse, closures are then sent to the relevant threads to be
-- dereferenced and thread-local storage is accumulated.
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 = forall a. ReaderT Debuggee IO a -> DebugM a
DebugM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO

-- | State local to a thread, there are $threads spawned, each which deals
-- with (address `div` 8) % threads. Each thread therefore:
--
-- * Outer map, segmented by MBlock
--  * Inner map, blocks for that MBlock
--    * Inner IOBitArray, visited information for that block
data ThreadState s = ThreadState (IM.IntMap (IM.IntMap (IOBitArray Word16))) (IORef s)

newtype ThreadInfo a = ThreadInfo (InChan (ClosurePtrWithInfo a))

-- | A 'ClosurePtr' with some additional information which needs to be
-- communicated across to another thread.
data ClosurePtrWithInfo a = ClosurePtrWithInfo !a !ClosurePtr


-- | Map from Thread -> Information about the thread
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 = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
raw_bk forall a. Integral a => a -> a -> a
`div` Int
8
      offset :: Word64
offset = ClosurePtr -> Word64
getBlockOffset ClosurePtr
cp forall a. Integral a => a -> a -> a
`div` Word64
8
      BlockPtr Word64
raw_mbk = ClosurePtr -> BlockPtr
applyMBlockMask ClosurePtr
cp
      mbk :: Int
mbk = forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
raw_mbk forall a. Integral a => a -> a -> a
`div` Int
8
  in (Int
mbk, Int
bk, 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
  -- Not sure why I had to divide this by 4, but I did.
  in (forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
raw_bk forall a. Integral a => a -> a -> a
`div` forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
mblockMask forall a. Integral a => a -> a -> a
`div` Int
4) 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) = forall a. ReaderT Debuggee IO a -> DebugM a
DebugM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  let st :: ThreadMap a
st = forall a. TraceState a -> ThreadMap a
visited TraceState a
ts
      mkey :: Int
mkey = ClosurePtr -> Int
getMBlockKey ClosurePtr
cp
  case forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
mkey ThreadMap a
st of
    Maybe (ThreadInfo a)
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"Not enough chans:" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
mkey forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int
threads
    Just (ThreadInfo InChan (ClosurePtrWithInfo a)
ic) -> forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ 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 = forall a. ReaderT Debuggee IO a -> DebugM a
DebugM forall a b. (a -> b) -> a -> b
$ do
  Debuggee
e <- forall r (m :: * -> *). MonadReader r m => m r
ask
  TChan (ClosurePtrWithInfo a)
ic <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. IO (TChan a)
newTChanIO
  let oc :: TChan (ClosurePtrWithInfo a)
oc = TChan (ClosurePtrWithInfo a)
ic
  IORef s
ref <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef forall a. Monoid a => a
mempty
  TVar Bool
worker_active <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (TVar a)
newTVarIO Bool
True
  let start :: (ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)
start ClosurePtrWithInfo a -> DebugM ()
go = forall a. IO a -> DebugM a
unsafeLiftIO forall a b. (a -> b) -> a -> b
$ forall a. IO a -> IO (Async a)
async forall a b. (a -> b) -> a -> b
$ forall a. Debuggee -> DebugM a -> IO a
runSimple Debuggee
e forall a b. (a -> b) -> a -> b
$ 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TVar a -> STM a
readTVar TVar Bool
worker_active
        Bool
empty  <- forall a. TChan a -> STM Bool
isEmptyTChan TChan (ClosurePtrWithInfo a)
ic
        return (Bool
active Bool -> Bool -> Bool
&& Bool
empty)

  forall (m :: * -> *) a. Monad m => a -> m a
return (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 = forall a. ReaderT Debuggee IO a -> DebugM a
DebugM forall a b. (a -> b) -> a -> b
$ do
  Debuggee
d <- forall r (m :: * -> *). MonadReader r m => m r
ask
  IORef (ThreadState s)
r <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. a -> IO (IORef a)
newIORef (forall s.
IntMap (IntMap (IOBitArray Word16)) -> IORef s -> ThreadState s
ThreadState forall a. IntMap a
IM.empty IORef s
ref)
  forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall a. Debuggee -> DebugM a -> IO a
runSimple Debuggee
d (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 <- forall a. IO a -> DebugM a
unsafeLiftIO forall a b. (a -> b) -> a -> b
$ forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ do
              forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
worker_active Bool
False
              forall a. STM a -> IO a
atomically forall a b. (a -> b) -> a -> b
$ do
                ClosurePtrWithInfo a
v <- forall a. TChan a -> STM a
readTChan OutChan (ClosurePtrWithInfo a)
oc
                forall a. TVar a -> a -> STM ()
writeTVar TVar Bool
worker_active Bool
True
                return ClosurePtrWithInfo a
v
      case Either AsyncCancelled (ClosurePtrWithInfo a)
mcp of
        -- The thread gets blocked on readChan when the work is finished so
        -- when this happens, catch the exception and return the accumulated
        -- state for the thread. Each thread has a reference to all over
        -- threads, so the exception is only raised when ALL threads are
        -- waiting for work.
        Left AsyncCancelled
AsyncCancelled -> do
          forall a. IO a -> DebugM a
unsafeLiftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef s
ref
        Right ClosurePtrWithInfo a
cpi -> forall {s}.
IORef (ThreadState s) -> ClosurePtrWithInfo a -> DebugM ()
deref IORef (ThreadState s)
r ClosurePtrWithInfo a
cpi 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 <- forall a. IO a -> DebugM a
unsafeLiftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> IO a
readIORef IORef (ThreadState s)
r
        do
          (ThreadState s
m', Bool
b) <- forall a. IO a -> DebugM a
unsafeLiftIO forall a b. (a -> b) -> a -> b
$ forall s. ClosurePtr -> ThreadState s -> IO (ThreadState s, Bool)
checkVisit ClosurePtr
cp ThreadState s
m
          forall a. IO a -> DebugM a
unsafeLiftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> a -> IO ()
writeIORef IORef (ThreadState s)
r ThreadState s
m'
          if Bool
b
            then do
              s
s <- forall a s. TraceFunctionsIO a s -> ClosurePtr -> a -> DebugM s
visitedVal TraceFunctionsIO a s
k ClosurePtr
cp a
a
              forall a. IO a -> DebugM a
unsafeLiftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef s
ref (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) <- 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
              forall a. IO a -> DebugM a
unsafeLiftIO forall a b. (a -> b) -> a -> b
$ forall a. IORef a -> (a -> a) -> IO ()
modifyIORef' IORef s
ref (s
s forall a. Semigroup a => a -> a -> a
<>)
              DebugM () -> DebugM ()
cont (() forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 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

    -- Just do the other dereferencing in the same thread for other closure
    -- types as they are not as common.
    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
      forall a s. TraceFunctionsIO a s -> StackFrames -> DebugM ()
stackTrace TraceFunctionsIO a s
k StackFrames
st'
      () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
      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
      forall a s. TraceFunctionsIO a s -> PapPayload -> DebugM ()
papTrace TraceFunctionsIO a s
k PapPayload
p'
      () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Int -> IntMap a -> Maybe a
IM.lookup Int
bk IntMap (IOBitArray Word16)
m of
    Maybe (IOBitArray Word16)
Nothing -> do
      IOBitArray Word16
na <- forall i. Ix i => (i, i) -> Bool -> IO (IOBitArray i)
newArray (Word16
0, forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word64
blockMask forall a. Integral a => a -> a -> a
`div` Word64
8)) Bool
False
      forall i. Ix i => IOBitArray i -> i -> Bool -> IO ()
writeArray IOBitArray Word16
na Word16
offset Bool
True
      return (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 <- forall i. Ix i => IOBitArray i -> i -> IO Bool
readArray IOBitArray Word16
bm Word16
offset
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
res (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 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 forall a. IntMap a
IM.empty
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall s.
IntMap (IntMap (IOBitArray Word16)) -> IORef s -> ThreadState s
ThreadState (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
      forall (m :: * -> *) a. Monad m => a -> m a
return (forall s.
IntMap (IntMap (IOBitArray Word16)) -> IORef s -> ThreadState s
ThreadState (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 ())
      }


-- | 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.
--
-- The performance of this parralel version depends on how much contention
-- the functions given in 'TraceFunctionsIO' content for the handle
-- connecting for the debuggee (which is protected by an 'MVar'). With no
-- contention, and precached blocks, the workload can be very evenly
-- distributed leading to high core utilisation.
--
-- As performance depends highly on contention, snapshot mode is much more
-- amenable to parrelisation where the time taken for requests is much
-- lower.
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
  forall (f :: * -> *). Applicative f => [Char] -> f ()
traceM ([Char]
"SPAWNING: " forall a. [a] -> [a] -> [a]
++ 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)  <- forall a b c. [(a, b, c)] -> ([a], [b], [c])
unzip3 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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) <- 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
                                    forall (m :: * -> *) a. Monad m => a -> m a
return ((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 forall a. Num a => a -> a -> a
- Int
1]
  let ts_map :: IntMap (ThreadInfo a)
ts_map = forall a. [(Int, a)] -> IntMap a
IM.fromList [(Int, ThreadInfo a)]
init_mblocks
      go :: ClosurePtrWithInfo a -> DebugM ()
go  = forall a. TraceState a -> ClosurePtrWithInfo a -> DebugM ()
sendToChan (forall a. ThreadMap a -> TraceState a
TraceState IntMap (ThreadInfo a)
ts_map)
  [Async s]
as <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a -> b) -> a -> b
$ ClosurePtrWithInfo a -> DebugM ()
go) [(ClosurePtrWithInfo a -> DebugM ()) -> DebugM (Async s)]
start )
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ClosurePtrWithInfo a -> DebugM ()
go [ClosurePtrWithInfo a]
cps
  forall a. IO a -> DebugM a
unsafeLiftIO forall a b. (a -> b) -> a -> b
$ [STM Bool] -> IO ()
waitFinish [STM Bool]
work_actives
  forall a. IO a -> DebugM a
unsafeLiftIO forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall a. Async a -> IO ()
cancel [Async s]
as
  forall a. IO a -> DebugM a
unsafeLiftIO forall a b. (a -> b) -> a -> b
$ forall a. Monoid a => [a] -> a
mconcat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a. Async a -> IO a
wait [Async s]
as

waitFinish :: [STM Bool] -> IO ()
waitFinish :: [STM Bool] -> IO ()
waitFinish [STM Bool]
working = forall a. STM a -> IO a
atomically ([STM Bool] -> STM ()
checkDone [STM Bool]
working)
  where
    checkDone :: [STM Bool] -> STM ()
checkDone [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    checkDone (STM Bool
x:[STM Bool]
xs) = do
      Bool
b <- STM Bool
x
      -- The variable tracks whether the thread thinks it's finished (no
      -- active work and empty chan)
      if Bool
b then [STM Bool] -> STM ()
checkDone [STM Bool]
xs else forall a. STM a
retry

-- | A parellel tracing function.
tracePar :: [ClosurePtr] -> DebugM ()
tracePar :: [ClosurePtr] -> DebugM ()
tracePar = forall s a.
Monoid s =>
TraceFunctionsIO a s -> [ClosurePtrWithInfo a] -> DebugM s
traceParFromM TraceFunctionsIO () ()
funcs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> ClosurePtr -> ClosurePtrWithInfo a
ClosurePtrWithInfo ())
  where
    nop :: b -> DebugM ()
nop = forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ())
    funcs :: TraceFunctionsIO () ()
funcs = 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 forall {b}. b -> DebugM ()
nop forall {b}. b -> DebugM ()
nop ClosurePtr
-> SizedClosure -> () -> DebugM ((), (), DebugM () -> DebugM ())
clos (forall a b. a -> b -> a
const (forall a b. a -> b -> a
const (forall (m :: * -> *) a. Monad m => a -> m a
return ()))) 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 = forall pap string s b.
DebugClosure pap string s b -> StgInfoTableWithPtr
info (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 ((), (), forall a. a -> a
id)