Rejig the extensible exceptions so there is less circular importing

[ghc-base.git] / GHC / Conc.lhs

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 460a98a..50ebab7 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -1,5 +1,5 @@
 \begin{code}
-{-# OPTIONS_GHC -fno-implicit-prelude #-}
+{-# OPTIONS_GHC -XNoImplicitPrelude #-}
 {-# OPTIONS_HADDOCK not-home #-}
 -----------------------------------------------------------------------------
 -- |
@@ -39,6 +39,9 @@ module GHC.Conc
         , yield         -- :: IO ()
         , labelThread   -- :: ThreadId -> String -> IO ()
 
+        , ThreadStatus(..), BlockReason(..)
+        , threadStatus  -- :: ThreadId -> IO ThreadStatus
+
         -- * Waiting
         , threadDelay           -- :: Int -> IO ()
         , registerDelay         -- :: Int -> IO (TVar Bool)
@@ -118,7 +121,7 @@ import GHC.Base         ( Int(..) )
 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
@@ -343,6 +346,53 @@ pseq  x y = x `seq` lazy y
 {-# 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}
 
 
@@ -390,7 +440,26 @@ thenSTM (STM m) k = STM ( \s ->
 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
 
@@ -593,7 +662,7 @@ withMVar :: MVar a -> (a -> IO b) -> IO b
 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