base: Have the argument of mask restore the state.

The implementation of `mask` and `uninterruptibleMask` assumed so far
that the restore argument would be called in a context with the same
masking state as that set by `mask` or `uninterruptibleMask`.

This patch has the restore argument restore the masking, whatever the
current masking state is.

Test Plan: validate

Reviewers: simonmar, hvr, austin, bgamari

Reviewed By: bgamari

Subscribers: thomie, qnikst

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

GHC Trac Issues: #10149

5 files changed, 31 insertions, 3 deletions

diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index e9ac94103d..0e3ac24e16 100644
--- a/libraries/base/GHC/IO.hs
+++ b/libraries/base/GHC/IO.hs
@@ -436,8 +436,9 @@ mask_ io = mask $ \_ -> io
 mask io = do
   b <- getMaskingState
   case b of
-    Unmasked -> block $ io unblock
-    _        -> io id
+    Unmasked              -> block $ io unblock
+    MaskedInterruptible   -> io block
+    MaskedUninterruptible -> io blockUninterruptible
 
 uninterruptibleMask_ io = uninterruptibleMask $ \_ -> io
 
@@ -446,7 +447,7 @@ uninterruptibleMask io = do
   case b of
     Unmasked              -> blockUninterruptible $ io unblock
     MaskedInterruptible   -> blockUninterruptible $ io block
-    MaskedUninterruptible -> io id
+    MaskedUninterruptible -> io blockUninterruptible
 
 bracket
         :: IO a         -- ^ computation to run first (\"acquire resource\")
diff --git a/libraries/base/changelog.md b/libraries/base/changelog.md
index 4297b0ad97..ebdbf0142e 100644
--- a/libraries/base/changelog.md
+++ b/libraries/base/changelog.md
@@ -4,6 +4,9 @@
 
   * Bundled with GHC 7.10.3
 
+  * The restore operation provided by `mask` and `uninterruptibleMask` now
+    restores the previous masking state whatever the current masking state is.
+
   * Exported `GiveGCStats`, `DoCostCentres`, `DoHeapProfile`, `DoTrace`,
     `RtsTime`, and `RtsNat` from `GHC.RTS.Flags`
 
diff --git a/libraries/base/tests/T10149.hs b/libraries/base/tests/T10149.hs
new file mode 100644
index 0000000000..d15b0d766a
--- /dev/null
+++ b/libraries/base/tests/T10149.hs
@@ -0,0 +1,19 @@
+import Control.Concurrent
+import Control.Exception
+
+main :: IO ()
+main = do
+    mask $ \unmask -> mask $ \restore ->
+      unmask $ restore $ getMaskingState >>= print
+    uninterruptibleMask $ \unmask -> uninterruptibleMask $ \restore ->
+      unmask $ restore $ getMaskingState >>= print
+
+    mv <- newEmptyMVar
+    mask_ $ -- start with exceptions masked
+      mask $ \restore -> forkIOWithUnmask $ \unmask -> unmask $
+        restore $ getMaskingState >>= print >> putMVar mv ()
+    takeMVar mv
+    uninterruptibleMask_ $ -- start with exceptions uninterruptibly masked
+      uninterruptibleMask $ \restore -> forkIOWithUnmask $ \unmask -> unmask $
+        restore $ getMaskingState >>= print >> putMVar mv ()
+    takeMVar mv
diff --git a/libraries/base/tests/T10149.stdout b/libraries/base/tests/T10149.stdout
new file mode 100644
index 0000000000..f78328dd88
--- /dev/null
+++ b/libraries/base/tests/T10149.stdout
@@ -0,0 +1,4 @@
+MaskedInterruptible
+MaskedUninterruptible
+MaskedInterruptible
+MaskedUninterruptible
diff --git a/libraries/base/tests/all.T b/libraries/base/tests/all.T
index 1c90d14e99..8d9889c8aa 100644
--- a/libraries/base/tests/all.T
+++ b/libraries/base/tests/all.T
@@ -180,3 +180,4 @@ test('T9586', normal, compile, [''])
 test('T9681', normal, compile_fail, [''])
 test('T8089', normal, compile_and_run, [''])
 test('T9826',normal, compile_and_run,[''])
+test('T10149',normal, compile_and_run,[''])