[commit: ghc] ghc-7.10: base: Have the argument of mask restore the state. (c3a496d)

[git at git.haskell.org]

Repository : ssh://git@git.haskell.org/ghc

On branch  : ghc-7.10
Link       : http://ghc.haskell.org/trac/ghc/changeset/c3a496d7a36bbe0a7ae93c0478dd4bdf47a71397/ghc

>---------------------------------------------------------------

commit c3a496d7a36bbe0a7ae93c0478dd4bdf47a71397
Author: Facundo Domínguez <facundo.dominguez at tweag.io>
Date:   Mon Oct 19 18:16:55 2015 +0200

    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


>---------------------------------------------------------------

c3a496d7a36bbe0a7ae93c0478dd4bdf47a71397
 libraries/base/GHC/IO.hs           |  7 ++++---
 libraries/base/changelog.md        |  3 +++
 libraries/base/tests/T10149.hs     | 19 +++++++++++++++++++
 libraries/base/tests/T10149.stdout |  4 ++++
 libraries/base/tests/all.T         |  1 +
 5 files changed, 31 insertions(+), 3 deletions(-)

diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index e9ac941..0e3ac24e 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 4297b0a..ebdbf01 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 0000000..d15b0d7
--- /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 0000000..f78328d
--- /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 1c90d14..8d9889c 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,[''])