From 897d66ad9d77d17dae1b5ac94af792e671a76c13 Mon Sep 17 00:00:00 2001
From: Herbert Valerio Riedel <hvr@gnu.org>
Date: Fri, 8 Nov 2013 12:42:56 +0100
Subject: [PATCH] Fix `forkProcess` to inherit caller's `MaskingState`
...and while at it, use `bracket` to fix a potential resource leak due
to `freeStablePtr` not being called if `throwErrnoIfMinus1` throws an
exception.
This fixes #8433
Signed-off-by: Herbert Valerio Riedel <hvr@gnu.org>
---
System/Posix/Process/Common.hsc | 22 ++++++++++++++++++----
changelog | 4 +++-
2 files changed, 21 insertions(+), 5 deletions(-)
diff --git a/System/Posix/Process/Common.hsc b/System/Posix/Process/Common.hsc
index 51c75b3..1b504df 100644
--- a/System/Posix/Process/Common.hsc
+++ b/System/Posix/Process/Common.hsc
@@ -81,7 +81,9 @@ import System.Posix.Types
import Control.Monad
#ifdef __GLASGOW_HASKELL__
+import Control.Exception.Base ( bracket, getMaskingState, MaskingState(..) ) -- used by forkProcess
import GHC.TopHandler ( runIO )
+import GHC.IO ( unsafeUnmask, uninterruptibleMask_ )
#endif
#ifdef __HUGS__
@@ -278,6 +280,9 @@ threads will be copied to the child process.
On success, 'forkProcess' returns the child's 'ProcessID' to the parent process;
in case of an error, an exception is thrown.
+The exception masking state of the executed action is inherited
+(c.f. 'forkIO'), see also 'forkProcessWithUnmask' (/since: 2.7.0.0/).
+
'forkProcess' comes with a giant warning: since any other running
threads are not copied into the child process, it's easy to go wrong:
e.g. by accessing some shared resource that was held by another thread
@@ -286,10 +291,19 @@ in the parent.
forkProcess :: IO () -> IO ProcessID
forkProcess action = do
- stable <- newStablePtr (runIO action)
- pid <- throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable)
- freeStablePtr stable
- return pid
+ -- wrap action to re-establish caller's masking state, as
+ -- 'forkProcessPrim' starts in 'MaskedInterruptible' state by
+ -- default; see also #1048
+ mstate <- getMaskingState
+ let action' = case mstate of
+ Unmasked -> unsafeUnmask action
+ MaskedInterruptible -> action
+ MaskedUninterruptible -> uninterruptibleMask_ action
+
+ bracket
+ (newStablePtr (runIO action'))
+ freeStablePtr
+ (\stable -> throwErrnoIfMinus1 "forkProcess" (forkProcessPrim stable))
foreign import ccall "forkProcess" forkProcessPrim :: StablePtr (IO ()) -> IO CPid
#endif /* __GLASGOW_HASKELL__ */
diff --git a/changelog b/changelog
index 165cf82..ec0fbc8 100644
--- a/changelog
+++ b/changelog
@@ -1,6 +1,8 @@
-*-changelog-*-
-2.7.0.0 Oct 2013
+2.7.0.0 Nov 2013
+
+ * Change `forkProcess` to inherit the exception masking state of its caller
* Add new `Bool` flag to `ProcessStatus(Terminated)` constructor
indicating whether a core dump occured
--
GitLab