From 44d225ad421ce4aefa36f63936c9802efa5c9017 Mon Sep 17 00:00:00 2001
From: Simon Marlow <marlowsd@gmail.com>
Date: Tue, 29 Mar 2011 13:56:39 +0000
Subject: [PATCH] add forkIOWithUnmask, forkOnIOWithUnmask; deprecate
 forkIOUnmasked

With forkIOUnmasked it wasn't possible to reliably set up an exception
handler in the child thread, because exceptions were immediately
unmasked.

forkIOWithUnmask   ::        ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
forkOnIOWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
---
 Control/Concurrent.hs |   11 +++++++----
 GHC/Conc.lhs          |    2 ++
 GHC/Conc/Sync.lhs     |   34 ++++++++++++++++++++++++++++++----
 3 files changed, 39 insertions(+), 8 deletions(-)

diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs
index 514e2e9..732255b 100644
--- a/Control/Concurrent.hs
+++ b/Control/Concurrent.hs
@@ -35,7 +35,7 @@ module Control.Concurrent (
 
         forkIO,
 #ifdef __GLASGOW_HASKELL__
-        forkIOUnmasked,
+        forkIOWithUnmask,
         killThread,
         throwTo,
 #endif
@@ -78,7 +78,7 @@ module Control.Concurrent (
         forkOS,
         isCurrentThreadBound,
         runInBoundThread,
-        runInUnboundThread
+        runInUnboundThread,
 #endif
 
         -- * GHC's implementation of concurrency
@@ -97,6 +97,10 @@ module Control.Concurrent (
         -- ** Pre-emption
 
         -- $preemption
+
+        -- * Deprecated functions
+        forkIOUnmasked
+
     ) where
 
 import Prelude
@@ -105,8 +109,7 @@ import Control.Exception.Base as Exception
 
 #ifdef __GLASGOW_HASKELL__
 import GHC.Exception
-import GHC.Conc         ( ThreadId(..), myThreadId, killThread, yield,
-                          threadDelay, forkIO, forkIOUnmasked, childHandler )
+import GHC.Conc hiding (threadWaitRead, threadWaitWrite)
 import qualified GHC.Conc
 import GHC.IO           ( IO(..), unsafeInterleaveIO, unsafeUnmask )
 import GHC.IORef        ( newIORef, readIORef, writeIORef )
diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 1332fca..11a9324 100644
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -31,8 +31,10 @@ module GHC.Conc
         -- * Forking and suchlike
         , forkIO        -- :: IO a -> IO ThreadId
         , forkIOUnmasked
+        , forkIOWithUnmask
         , forkOnIO      -- :: Int -> IO a -> IO ThreadId
         , forkOnIOUnmasked
+        , forkOnIOWithUnmask
         , numCapabilities -- :: Int
         , getNumCapabilities -- :: IO Int
         , numSparks       -- :: IO Int
diff --git a/GHC/Conc/Sync.lhs b/GHC/Conc/Sync.lhs
index 370bfd9..027744b 100644
--- a/GHC/Conc/Sync.lhs
+++ b/GHC/Conc/Sync.lhs
@@ -7,6 +7,7 @@
            , UnliftedFFITypes
            , ForeignFunctionInterface
            , DeriveDataTypeable
+           , RankNTypes
   #-}
 {-# OPTIONS_GHC -fno-warn-missing-signatures #-}
 {-# OPTIONS_HADDOCK not-home #-}
@@ -39,8 +40,10 @@ module GHC.Conc.Sync
         -- * Forking and suchlike
         , forkIO        -- :: IO a -> IO ThreadId
         , forkIOUnmasked
+        , forkIOWithUnmask
         , forkOnIO      -- :: Int -> IO a -> IO ThreadId
         , forkOnIOUnmasked
+        , forkOnIOWithUnmask
         , numCapabilities -- :: Int
         , getNumCapabilities -- :: IO Int
         , numSparks      -- :: IO Int
@@ -195,11 +198,29 @@ forkIO action = IO $ \ s ->
  where
   action_plus = catchException action childHandler
 
--- | Like 'forkIO', but the child thread is created with asynchronous exceptions
--- unmasked (see 'Control.Exception.mask').
+{-# DEPRECATED forkIOUnmasked "use forkIOWithUnmask instead" #-}
+-- | This function is deprecated; use 'forkIOWIthUnmask' instead
 forkIOUnmasked :: IO () -> IO ThreadId
 forkIOUnmasked io = forkIO (unsafeUnmask io)
 
+-- | Like 'forkIO', but the child thread is passed a function that can
+-- be used to unmask asynchronous exceptions.  This function is
+-- typically used in the following way
+--
+-- >  ... mask_ $ forkIOWithUnmask $ \unmask ->
+-- >                 catch (unmask ...) handler
+--
+-- so that the exception handler in the child thread is established
+-- with asynchronous exceptions masked, meanwhile the main body of
+-- the child thread is executed in the unmasked state.
+--
+-- Note that the unmask function passed to the child thread should
+-- only be used in that thread; the behaviour is undefined if it is
+-- invoked in a different thread.
+--
+forkIOWithUnmask :: ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
+forkIOWithUnmask io = forkIO (io unsafeUnmask)
+
 {- |
 Like 'forkIO', but lets you specify on which CPU the thread is
 created.  Unlike a `forkIO` thread, a thread created by `forkOnIO`
@@ -217,11 +238,16 @@ forkOnIO (I# cpu) action = IO $ \ s ->
  where
   action_plus = catchException action childHandler
 
--- | Like 'forkOnIO', but the child thread is created with
--- asynchronous exceptions unmasked (see 'Control.Exception.mask').
+{-# DEPRECATED forkOnIOUnmasked "use forkOnIOWithUnmask instead" #-}
+-- | This function is deprecated; use 'forkOnIOWIthUnmask' instead
 forkOnIOUnmasked :: Int -> IO () -> IO ThreadId
 forkOnIOUnmasked cpu io = forkOnIO cpu (unsafeUnmask io)
 
+-- | Like 'forkIOWithUnmask', but the child thread is pinned to the
+-- given CPU, as with 'forkOnIO'.
+forkOnIOWithUnmask :: Int -> ((forall a . IO a -> IO a) -> IO ()) -> IO ThreadId
+forkOnIOWithUnmask cpu io = forkOnIO cpu (io unsafeUnmask)
+
 -- | the value passed to the @+RTS -N@ flag.  This is the number of
 -- Haskell threads that can run truly simultaneously at any given
 -- time, and is typically set to the number of physical CPU cores on
-- 
1.7.10.4