[commit: ghc] master: Don't allowInterrupt inside uninterruptibleMask (5a8a8a6)
git at git.haskell.org
git at git.haskell.org
Thu Jul 30 15:04:44 UTC 2015
Repository : ssh://git@git.haskell.org/ghc
On branch : master
Link : http://ghc.haskell.org/trac/ghc/changeset/5a8a8a64e793d2efbe9ea7d445cc8efe75d11f80/ghc
>---------------------------------------------------------------
commit 5a8a8a64e793d2efbe9ea7d445cc8efe75d11f80
Author: Ben Gamari <ben at smart-cactus.org>
Date: Mon Jul 27 15:04:43 2015 +0200
Don't allowInterrupt inside uninterruptibleMask
This fixes #9516.
Differential Revision: https://phabricator.haskell.org/D181
Authored-by: Edsko de Vries <edsko at well-typed.com>
>---------------------------------------------------------------
5a8a8a64e793d2efbe9ea7d445cc8efe75d11f80
docs/users_guide/7.12.1-notes.xml | 16 ++++++++++++++++
libraries/base/Control/Exception.hs | 7 ++++---
libraries/base/GHC/IO.hs | 18 +++++++++++++++++-
libraries/base/changelog.md | 3 +++
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 eccf13d..e00706c 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 61ebf29..9c388f4 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 7dbd338..231d110 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 53bcb10..7a4bb71 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
More information about the ghc-commits
mailing list