From c3a496d7a36bbe0a7ae93c0478dd4bdf47a71397 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Facundo=20Dom=C3=ADnguez?= <facundo.dominguez@tweag.io>
Date: Mon, 19 Oct 2015 18:16:55 +0200
Subject: [PATCH] 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
---
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(-)
create mode 100644 libraries/base/tests/T10149.hs
create mode 100644 libraries/base/tests/T10149.stdout
diff --git a/libraries/base/GHC/IO.hs b/libraries/base/GHC/IO.hs
index e9ac94103db8..0e3ac24e16b3 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 4297b0ad97b9..ebdbf0142e8e 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 000000000000..d15b0d766a8d
--- /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 000000000000..f78328dd88a6
--- /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 1c90d14e99e3..8d9889c8aafa 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,[''])
--
GitLab