Don't allowInterrupt inside uninterruptibleMask

This fixes #9516.

Differential Revision: https://phabricator.haskell.org/D181

Authored-by: Edsko de Vries <edsko@well-typed.com>

4 files changed, 40 insertions, 4 deletions

diff --git a/docs/users_guide/7.12.1-notes.xml b/docs/users_guide/7.12.1-notes.xml
index eccf13d431..e00706c4de 100644
--- a/docs/users_guide/7.12.1-notes.xml
+++ b/docs/users_guide/7.12.1-notes.xml
@@ -234,6 +234,22 @@
                     call.
                </para>
            </listitem>
+            <listitem>
+                <para>
+                    A new function, <literal>interruptible</literal>, was added
+                    to <literal>GHC.IO</literal> allowing an
+                    <literal>IO</literal> action to be run such that it can be
+                    interrupted by an asynchronous exception, even if exceptions
+                    are masked (except if masked with
+                    <literal>interruptibleMask</literal>).
+                </para>
+                <para>
+                    This was introduced to fix the behavior of
+                    <literal>allowInterrupt</literal>, which would previously
+                    incorrectly allow exceptions in uninterruptible regions
+                    (see Trac #9516).
+               </para>
+           </listitem>
        </itemizedlist>
     </sect3>
 
diff --git a/libraries/base/Control/Exception.hs b/libraries/base/Control/Exception.hs
index 61ebf2961c..9c388f4450 100644
--- a/libraries/base/Control/Exception.hs
+++ b/libraries/base/Control/Exception.hs
@@ -106,6 +106,7 @@ module Control.Exception (
         uninterruptibleMask_,
         MaskingState(..),
         getMaskingState,
+        interruptible,
         allowInterrupt,
 
         -- *** Applying @mask@ to an exception handler
@@ -134,7 +135,7 @@ module Control.Exception (
 import Control.Exception.Base
 
 import GHC.Base
-import GHC.IO (unsafeUnmask)
+import GHC.IO (interruptible)
 
 -- | You need this when using 'catches'.
 data Handler a = forall e . Exception e => Handler (e -> IO a)
@@ -215,14 +216,14 @@ A typical use of 'tryJust' for recovery looks like this:
 -- | When invoked inside 'mask', this function allows a masked
 -- asynchronous exception to be raised, if one exists.  It is
 -- equivalent to performing an interruptible operation (see
--- #interruptible#), but does not involve any actual blocking.
+-- #interruptible), but does not involve any actual blocking.
 --
 -- When called outside 'mask', or inside 'uninterruptibleMask', this
 -- function has no effect.
 --
 -- @since 4.4.0.0
 allowInterrupt :: IO ()
-allowInterrupt = unsafeUnmask $ return ()
+allowInterrupt = interruptible $ return ()
 
 {- $async
 
diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index 7dbd3382f9..231d110709 100644
--- a/libraries/base/GHC/IO.hs
+++ b/libraries/base/GHC/IO.hs
@@ -36,7 +36,7 @@ module GHC.IO (
         catchException, catchAny, throwIO,
         mask, mask_, uninterruptibleMask, uninterruptibleMask_,
         MaskingState(..), getMaskingState,
-        unsafeUnmask,
+        unsafeUnmask, interruptible,
         onException, bracket, finally, evaluate
     ) where
 
@@ -341,6 +341,22 @@ unblock = unsafeUnmask
 unsafeUnmask :: IO a -> IO a
 unsafeUnmask (IO io) = IO $ unmaskAsyncExceptions# io
 
+-- | Allow asynchronous exceptions to be raised even inside 'mask', making
+-- the operation interruptible (see the discussion of "Interruptible operations"
+-- in 'Control.Exception').
+--
+-- When called outside 'mask', or inside 'uninterruptibleMask', this
+-- function has no effect.
+--
+-- /Since: 4.8.2.0/
+interruptible :: IO a -> IO a
+interruptible act = do
+  st <- getMaskingState
+  case st of
+    Unmasked              -> act
+    MaskedInterruptible   -> unsafeUnmask act
+    MaskedUninterruptible -> act
+
 blockUninterruptible :: IO a -> IO a
 blockUninterruptible (IO io) = IO $ maskUninterruptible# io
 
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 53bcb1035f..7a4bb71208 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -45,6 +45,9 @@
   * Exported `GiveGCStats`, `DoCostCentres`, `DoHeapProfile`, `DoTrace`,
     `RtsTime`, and `RtsNat` from `GHC.RTS.Flags`
 
+  * New function `GHC.IO.interruptible` used to correctly implement
+    `Control.Exception.allowInterrupt` (#9516)
+
 ## 4.8.1.0  *TBA*
 
   * Bundled with GHC 7.10.2