{-# 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 = 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

-- | 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 = 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
  -- Not sure why I had to divide this by 4, but I did.
  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
        -- 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
          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

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


-- | 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
  [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
      -- 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 STM ()
forall a. STM a
retry

-- | A parellel tracing function.
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)