From: Simon Marlow <marlowsd@gmail.com>
Date: Wed, 9 Jul 2008 13:31:39 +0000 (+0000)
Subject: Add Control.Exception.blocked :: IO Bool
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;h=4407eb3b5cdcb6310ed8ab5f7d55ba313b40a927;p=ghc-base.git

Add Control.Exception.blocked :: IO Bool
Tells you whether async exceptions are currently blocked or not.
---

diff --git a/Control/Exception.hs b/Control/Exception.hs
index 14bdef1..bd997b1 100644
--- a/Control/Exception.hs
+++ b/Control/Exception.hs
@@ -98,6 +98,7 @@ module Control.Exception (
 
         block,          -- :: IO a -> IO a
         unblock,        -- :: IO a -> IO a
+        blocked,        -- :: IO Bool
 
         -- *** Applying @block@ to an exception handler
 
@@ -183,6 +184,8 @@ block   :: IO a -> IO a
 block    = id
 unblock :: IO a -> IO a
 unblock  = id
+blocked :: IO Bool
+blocked  = False
 
 assert :: Bool -> a -> a
 assert True  x = x
diff --git a/GHC/Exception.lhs b/GHC/Exception.lhs
index 5ec9bcc..a0bf8e8 100644
--- a/GHC/Exception.lhs
+++ b/GHC/Exception.lhs
@@ -106,6 +106,12 @@ unblock :: IO a -> IO a
 
 block (IO io) = IO $ blockAsyncExceptions# io
 unblock (IO io) = IO $ unblockAsyncExceptions# io
+
+-- | returns True if asynchronous exceptions are blocked in the
+-- current thread.
+blocked :: IO Bool
+blocked = IO $ \s -> case asyncExceptionsBlocked# s of
+                        (# s', i #) -> (# s', i /=# 0# #)
 \end{code}
 
 \begin{code}