Thread Status

.gitignore

@@ -0,0 +1 @@
+dist-newstyle

io-classes/src/Control/Monad/Class/MonadFork.hs

@@ -16,7 +16,8 @@ import qualified Control.Concurrent as IO
 import           Control.Exception (AsyncException (ThreadKilled), Exception)
 import           Control.Monad.Reader (ReaderT (..), lift)
 import           Data.Kind (Type)
-import qualified GHC.Conc.Sync as IO (labelThread)
+import           GHC.Conc (ThreadStatus)
+import qualified GHC.Conc.Sync as IO (labelThread, threadStatus)
 
 
 class (Monad m, Eq   (ThreadId m),
@@ -27,6 +28,7 @@ class (Monad m, Eq   (ThreadId m),
 
   myThreadId     :: m (ThreadId m)
   labelThread    :: ThreadId m -> String -> m ()
+  threadStatus   :: ThreadId m -> m ThreadStatus
 
 
 class MonadThread m => MonadFork m where
@@ -54,6 +56,7 @@ instance MonadThread IO where
   type ThreadId IO = IO.ThreadId
   myThreadId = IO.myThreadId
   labelThread = IO.labelThread
+  threadStatus = IO.threadStatus
 
 instance MonadFork IO where
   forkIO           = IO.forkIO
@@ -67,6 +70,7 @@ instance MonadThread m => MonadThread (ReaderT r m) where
   type ThreadId (ReaderT r m) = ThreadId m
   myThreadId  = lift myThreadId
   labelThread t l = lift (labelThread t l)
+  threadStatus t = lift (threadStatus t)
 
 instance MonadFork m => MonadFork (ReaderT e m) where
   forkIO (ReaderT f)   = ReaderT $ \e -> forkIO (f e)

io-sim/src/Control/Monad/IOSim/CommonTypes.hs

@@ -80,5 +80,10 @@ instance Eq (TVar s a) where
 data SomeTVar s where
   SomeTVar :: !(TVar s a) -> SomeTVar s
 
-data Deschedule = Yield | Interruptable | Blocked | Terminated | Sleep
+-- | The reason a thread finished running
+data FinishedReason = FinishedNormally
+                    | FinishedDied
+                    deriving (Ord, Eq, Show, Enum, Bounded)
+
+data Deschedule = Yield | Interruptable | Blocked | Terminated FinishedReason | Sleep
   deriving Show

io-sim/src/Control/Monad/IOSim/Internal.hs

@@ -69,6 +69,7 @@ import           Deque.Strict (Deque)
 import qualified Deque.Strict as Deque
 
 import           GHC.Exts (fromList)
+import           GHC.Conc (ThreadStatus(..), BlockReason(..))
 
 import           Control.Exception (NonTermination (..), assert, throw)
 import           Control.Monad (join)
@@ -123,14 +124,15 @@ labelledThreads threadMap =
 --
 data TimerVars s = TimerVars !(TVar s TimeoutState) !(TVar s Bool)
 
-
 -- | Internal state.
 --
 data SimState s a = SimState {
        runqueue :: !(Deque ThreadId),
        -- | All threads other than the currently running thread: both running
        -- and blocked threads.
        threads  :: !(Map ThreadId (Thread s a)),
+       -- | Keep track of the reason threads finished for 'threadStatus'
+       finished :: !(Map ThreadId FinishedReason),
        -- | current time
        curTime  :: !Time,
        -- | ordered list of timers
@@ -146,6 +148,7 @@ initialState =
     SimState {
       runqueue = mempty,
       threads  = Map.empty,
+      finished = Map.empty,
       curTime  = Time 0,
       timers   = PSQ.empty,
       clocks   = Map.singleton (ClockId []) epoch1970,
@@ -190,6 +193,7 @@ schedule !thread@Thread{
          !simstate@SimState {
            runqueue,
            threads,
+           finished,
            timers,
            clocks,
            nextVid, nextTmid,
@@ -208,9 +212,9 @@ schedule !thread@Thread{
 
       ForkFrame -> do
         -- this thread is done
-        !trace <- deschedule Terminated thread simstate
+        !trace <- deschedule (Terminated FinishedNormally) thread simstate
         return $ SimTrace time tid tlbl EventThreadFinished
-               $ SimTrace time tid tlbl (EventDeschedule Terminated)
+               $ SimTrace time tid tlbl (EventDeschedule $ Terminated FinishedNormally)
                $ trace
 
       MaskFrame k maskst' ctl' -> do
@@ -228,7 +232,7 @@ schedule !thread@Thread{
         let thread' = thread { threadControl = ThreadControl (k x) ctl' }
         schedule thread' simstate
 
-    Throw e -> {-# SCC "schedule.Throw" #-}
+    Throw thrower e -> {-# SCC "schedule.Throw" #-}
                case unwindControlStack e thread of
       Right thread'@Thread { threadMasking = maskst' } -> do
         -- We found a suitable exception handler, continue with that
@@ -247,10 +251,12 @@ schedule !thread@Thread{
 
         | otherwise -> do
           -- An unhandled exception in any other thread terminates the thread
-          !trace <- deschedule Terminated thread simstate
+          let reason | ThrowSelf <- thrower = FinishedNormally
+                     | otherwise            = FinishedDied
+          !trace <- deschedule (Terminated reason) thread simstate
           return $ SimTrace time tid tlbl (EventThrow e)
                  $ SimTrace time tid tlbl (EventThreadUnhandled e)
-                 $ SimTrace time tid tlbl (EventDeschedule Terminated)
+                 $ SimTrace time tid tlbl (EventDeschedule $ Terminated reason)
                  $ trace
 
     Catch action' handler k ->
@@ -266,7 +272,7 @@ schedule !thread@Thread{
       case mbWHNF of
         Left e -> do
           -- schedule this thread to immediately raise the exception
-          let thread' = thread { threadControl = ThreadControl (Throw e) ctl }
+          let thread' = thread { threadControl = ThreadControl (Throw ThrowSelf e) ctl }
           schedule thread' simstate
         Right whnf -> do
           -- continue with the resulting WHNF
@@ -466,7 +472,7 @@ schedule !thread@Thread{
 
         StmTxAborted _read e -> do
           -- schedule this thread to immediately raise the exception
-          let thread' = thread { threadControl = ThreadControl (Throw e) ctl }
+          let thread' = thread { threadControl = ThreadControl (Throw ThrowSelf e) ctl }
           !trace <- schedule thread' simstate
           return $ SimTrace time tid tlbl (EventTxAborted Nothing) trace
 
@@ -495,6 +501,19 @@ schedule !thread@Thread{
           threads' = Map.adjust (\t -> t { threadLabel = Just l }) tid' threads
       schedule thread' simstate { threads = threads' }
 
+    ThreadStatus tid' k ->
+      {-# SCC "schedule.ThreadStatus" #-} do
+      let result | Just r <- Map.lookup tid' finished = reasonToStatus r
+                 | Just t <- Map.lookup tid' threads  = threadStatus t
+                 | otherwise                          = error "The impossible happened - tried to loookup thread in state."
+          reasonToStatus FinishedNormally  = ThreadFinished
+          reasonToStatus FinishedDied      = ThreadDied
+          threadStatus t | threadBlocked t = ThreadBlocked BlockedOnOther
+                         | otherwise       = ThreadRunning
+
+          thread' = thread { threadControl = ThreadControl (k result) ctl }
+      schedule thread' simstate
+
     GetMaskState k ->
       {-# SCC "schedule.GetMaskState" #-} do
       let thread' = thread { threadControl = ThreadControl (k maskst) ctl }
@@ -519,7 +538,7 @@ schedule !thread@Thread{
       {-# SCC "schedule.ThrowTo" #-} do
       -- Throw to ourself is equivalent to a synchronous throw,
       -- and works irrespective of masking state since it does not block.
-      let thread' = thread { threadControl = ThreadControl (Throw e) ctl }
+      let thread' = thread { threadControl = ThreadControl (Throw ThrowSelf e) ctl }
       trace <- schedule thread' simstate
       return (SimTrace time tid tlbl (EventThrowTo e tid) trace)
 
@@ -549,8 +568,11 @@ schedule !thread@Thread{
           -- be resolved if the thread terminates or if it leaves the exception
           -- handler (when restoring the masking state would trigger the any
           -- new pending async exception).
-          let adjustTarget t@Thread{ threadControl = ThreadControl _ ctl' } =
-                t { threadControl = ThreadControl (Throw e) ctl'
+          let thrower = case threadMasking <$> Map.lookup tid' threads of
+                          Just Unmasked -> ThrowOther
+                          _             -> ThrowSelf
+              adjustTarget t@Thread{ threadControl = ThreadControl _ ctl' } =
+                t { threadControl = ThreadControl (Throw thrower e) ctl'
                   , threadBlocked = False
                   }
               simstate'@SimState { threads = threads' }
@@ -619,7 +641,7 @@ deschedule Interruptable !thread@Thread {
     -- So immediately raise the exception and unblock the blocked thread
     -- if possible.
     {-# SCC "deschedule.Interruptable.Unmasked" #-}
-    let thread' = thread { threadControl = ThreadControl (Throw e) ctl
+    let thread' = thread { threadControl = ThreadControl (Throw ThrowSelf e) ctl
                          , threadMasking = MaskedInterruptible
                          , threadThrowTo = etids }
         (unblocked,
@@ -654,13 +676,16 @@ deschedule Blocked !thread !simstate@SimState{threads} =
         threads' = Map.insert (threadId thread') thread' threads in
     reschedule simstate { threads = threads' }
 
-deschedule Terminated !thread !simstate@SimState{ curTime = time, threads } =
+deschedule (Terminated reason) !thread !simstate@SimState{ curTime = time, threads } =
     -- This thread is done. If there are other threads blocked in a
     -- ThrowTo targeted at this thread then we can wake them up now.
     {-# SCC "deschedule.Terminated" #-}
     let !wakeup      = map (l_labelled . snd) (reverse (threadThrowTo thread))
         (unblocked,
-         !simstate') = unblockThreads wakeup simstate
+         !simstate') = unblockThreads wakeup
+                        simstate { finished = Map.insert (threadId thread)
+                                                         reason
+                                                         (finished simstate) }
     in do
     !trace <- reschedule simstate'
     return $ traceMany

io-sim/src/Control/Monad/IOSim/Types.hs

@@ -59,6 +59,7 @@ module Control.Monad.IOSim.Types
   , module Control.Monad.IOSim.CommonTypes
   , SimM
   , SimSTM
+  , Thrower (..)
   ) where
 
 import           Control.Applicative
@@ -113,6 +114,8 @@ import           Control.Monad.IOSim.CommonTypes
 import           Control.Monad.IOSim.STM
 import           Control.Monad.IOSimPOR.Types
 
+import           GHC.Conc (ThreadStatus)
+
 
 import qualified System.IO.Error as IO.Error (userError)
 
@@ -131,6 +134,8 @@ traceM x = IOSim $ oneShot $ \k -> Output (toDyn x) (k ())
 traceSTM :: Typeable a => a -> STMSim s ()
 traceSTM x = STM $ oneShot $ \k -> OutputStm (toDyn x) (k ())
 
+data Thrower = ThrowSelf | ThrowOther deriving (Ord, Eq, Show)
+
 data SimA s a where
   Return       :: a -> SimA s a
 
@@ -148,14 +153,15 @@ data SimA s a where
   UpdateTimeout:: Timeout (IOSim s) -> DiffTime -> SimA s b -> SimA s b
   CancelTimeout:: Timeout (IOSim s) -> SimA s b -> SimA s b
 
-  Throw        :: SomeException -> SimA s a
+  Throw        :: Thrower -> SomeException -> SimA s a
   Catch        :: Exception e =>
                   SimA s a -> (e -> SimA s a) -> (a -> SimA s b) -> SimA s b
   Evaluate     :: a -> (a -> SimA s b) -> SimA s b
 
   Fork         :: IOSim s () -> (ThreadId -> SimA s b) -> SimA s b
   GetThreadId  :: (ThreadId -> SimA s b) -> SimA s b
   LabelThread  :: ThreadId -> String -> SimA s b -> SimA s b
+  ThreadStatus :: ThreadId -> (ThreadStatus -> SimA s b) -> SimA s b
 
   Atomically   :: STM  s a -> (a -> SimA s b) -> SimA s b
 
@@ -242,7 +248,7 @@ instance Monoid a => Monoid (IOSim s a) where
 #endif
 
 instance Fail.MonadFail (IOSim s) where
-  fail msg = IOSim $ oneShot $ \_ -> Throw (toException (IO.Error.userError msg))
+  fail msg = IOSim $ oneShot $ \_ -> Throw ThrowSelf (toException (IO.Error.userError msg))
 
 instance MonadFix (IOSim s) where
     mfix f = IOSim $ oneShot $ \k -> Fix f k
@@ -289,7 +295,7 @@ instance MonadSay (IOSim s) where
   say msg = IOSim $ oneShot $ \k -> Say msg (k ())
 
 instance MonadThrow (IOSim s) where
-  throwIO e = IOSim $ oneShot $ \_ -> Throw (toException e)
+  throwIO e = IOSim $ oneShot $ \_ -> Throw ThrowSelf (toException e)
 
 instance MonadEvaluate (IOSim s) where
   evaluate a = IOSim $ oneShot $ \k -> Evaluate a k
@@ -373,6 +379,7 @@ instance MonadThread (IOSim s) where
   type ThreadId (IOSim s) = ThreadId
   myThreadId       = IOSim $ oneShot $ \k -> GetThreadId k
   labelThread t l  = IOSim $ oneShot $ \k -> LabelThread t l (k ())
+  threadStatus t   = IOSim $ oneShot $ \k -> ThreadStatus t k
 
 instance MonadFork (IOSim s) where
   forkIO task        = IOSim $ oneShot $ \k -> Fork task k
@@ -802,6 +809,7 @@ data SimEventType
   | EventPerformAction StepId
   | EventReschedule           ScheduleControl
   | EventUnblocked     [ThreadId]
+  | EventThreadStatus  ThreadId ThreadId
   deriving Show
 
 type TraceEvent = SimEventType