, yield -- :: IO ()
, labelThread -- :: ThreadId -> String -> IO ()
+ , ThreadStatus(..), BlockReason(..)
+ , threadStatus -- :: ThreadId -> IO ThreadStatus
+
-- * Waiting
, threadDelay -- :: Int -> IO ()
, registerDelay -- :: Int -> IO (TVar Bool)
import GHC.Read ( Read )
import GHC.Enum ( Enum )
#endif
-import GHC.Exception
+import GHC.Exception ( throw )
import GHC.Pack ( packCString# )
import GHC.Ptr ( Ptr(..), plusPtr, FunPtr(..) )
import GHC.STRef
{-# INLINE par #-}
par :: a -> b -> b
par x y = case (par# x) of { _ -> lazy y }
+
+
+data BlockReason
+ = BlockedOnMVar
+ -- ^blocked on on 'MVar'
+ | BlockedOnBlackHole
+ -- ^blocked on a computation in progress by another thread
+ | BlockedOnException
+ -- ^blocked in 'throwTo'
+ | BlockedOnSTM
+ -- ^blocked in 'retry' in an STM transaction
+ | BlockedOnForeignCall
+ -- ^currently in a foreign call
+ | BlockedOnOther
+ -- ^blocked on some other resource. Without @-threaded@,
+ -- I\/O and 'threadDelay' show up as 'BlockedOnOther', with @-threaded@
+ -- they show up as 'BlockedOnMVar'.
+ deriving (Eq,Ord,Show)
+
+-- | The current status of a thread
+data ThreadStatus
+ = ThreadRunning
+ -- ^the thread is currently runnable or running
+ | ThreadFinished
+ -- ^the thread has finished
+ | ThreadBlocked BlockReason
+ -- ^the thread is blocked on some resource
+ | ThreadDied
+ -- ^the thread received an uncaught exception
+ deriving (Eq,Ord,Show)
+
+threadStatus :: ThreadId -> IO ThreadStatus
+threadStatus (ThreadId t) = IO $ \s ->
+ case threadStatus# t s of
+ (# s', stat #) -> (# s', mk_stat (I# stat) #)
+ where
+ -- NB. keep these in sync with includes/Constants.h
+ mk_stat 0 = ThreadRunning
+ mk_stat 1 = ThreadBlocked BlockedOnMVar
+ mk_stat 2 = ThreadBlocked BlockedOnBlackHole
+ mk_stat 3 = ThreadBlocked BlockedOnException
+ mk_stat 7 = ThreadBlocked BlockedOnSTM
+ mk_stat 11 = ThreadBlocked BlockedOnForeignCall
+ mk_stat 12 = ThreadBlocked BlockedOnForeignCall
+ mk_stat 16 = ThreadFinished
+ mk_stat 17 = ThreadDied
+ mk_stat _ = ThreadBlocked BlockedOnOther
\end{code}
returnSTM :: a -> STM a
returnSTM x = STM (\s -> (# s, x #))
--- | Unsafely performs IO in the STM monad.
+-- | Unsafely performs IO in the STM monad. Beware: this is a highly
+-- dangerous thing to do.
+--
+-- * The STM implementation will often run transactions multiple
+-- times, so you need to be prepared for this if your IO has any
+-- side effects.
+--
+-- * The STM implementation will abort transactions that are known to
+-- be invalid and need to be restarted. This may happen in the middle
+-- of `unsafeIOToSTM`, so make sure you don't acquire any resources
+-- that need releasing (exception handlers are ignored when aborting
+-- the transaction). That includes doing any IO using Handles, for
+-- example. Getting this wrong will probably lead to random deadlocks.
+--
+-- * The transaction may have seen an inconsistent view of memory when
+-- the IO runs. Invariants that you expect to be true throughout
+-- your program may not be true inside a transaction, due to the
+-- way transactions are implemented. Normally this wouldn't be visible
+-- to the programmer, but using `unsafeIOToSTM` can expose it.
+--
unsafeIOToSTM :: IO a -> STM a
unsafeIOToSTM (IO m) = STM m
withMVar m io =
block $ do
a <- takeMVar m
- b <- catchException (unblock (io a))
+ b <- catchAny (unblock (io a))
(\e -> do putMVar m a; throw e)
putMVar m a
return b