From 4c29f6f110d23b890567b8696a964bb212eba52e Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 8 Jul 2010 15:27:35 +0000 Subject: [PATCH] New asynchronous exception control API (base parts) As discussed on the libraries/haskell-cafe mailing lists http://www.haskell.org/pipermail/libraries/2010-April/013420.html This is a replacement for block/unblock in the asychronous exceptions API to fix a problem whereby a function could unblock asynchronous exceptions even if called within a blocked context. The new terminology is "mask" rather than "block" (to avoid confusion due to overloaded meanings of the latter). The following is the new API; the old API is deprecated but still available for the time being. Control.Exception ----------------- mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b mask_ :: IO a -> IO a uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b uninterruptibleMask_ :: IO a -> IO getMaskingState :: IO MaskingState data MaskingState = Unmasked | MaskedInterruptible | MaskedUninterruptible Control.Concurrent ------------------ forkIOUnmasked :: IO () -> IO ThreadId --- Control/Concurrent.hs | 23 ++++--- Control/Concurrent/MVar.hs | 16 ++--- Control/Concurrent/QSem.hs | 6 +- Control/Concurrent/QSemN.hs | 6 +- Control/Concurrent/SampleVar.hs | 10 +-- Control/Exception.hs | 27 +++++--- Control/Exception/Base.hs | 24 ++++--- Control/OldException.hs | 33 ++++------ Data/HashTable.hs | 2 +- Data/Typeable.hs | 4 +- Foreign/Marshal/Pool.hs | 6 +- GHC/Conc.lhs | 28 +++++--- GHC/IO.hs | 138 +++++++++++++++++++++++++++++++++++---- GHC/IO/Handle/Internals.hs | 4 +- 14 files changed, 231 insertions(+), 96 deletions(-) diff --git a/Control/Concurrent.hs b/Control/Concurrent.hs index a25e659..6122a10 100644 --- a/Control/Concurrent.hs +++ b/Control/Concurrent.hs @@ -28,6 +28,7 @@ module Control.Concurrent ( forkIO, #ifdef __GLASGOW_HASKELL__ + forkIOUnmasked, killThread, throwTo, #endif @@ -98,9 +99,9 @@ import Control.Exception.Base as Exception #ifdef __GLASGOW_HASKELL__ import GHC.Exception import GHC.Conc ( ThreadId(..), myThreadId, killThread, yield, - threadDelay, forkIO, childHandler ) + threadDelay, forkIO, forkIOUnmasked, childHandler ) import qualified GHC.Conc -import GHC.IO ( IO(..), unsafeInterleaveIO ) +import GHC.IO ( IO(..), unsafeInterleaveIO, unsafeUnmask ) import GHC.IORef ( newIORef, readIORef, writeIORef ) import GHC.Base @@ -357,13 +358,15 @@ failNonThreaded = fail $ "RTS doesn't support multiple OS threads " forkOS action0 | rtsSupportsBoundThreads = do mv <- newEmptyMVar - b <- Exception.blocked + b <- Exception.getMaskingState let - -- async exceptions are blocked in the child if they are blocked + -- async exceptions are masked in the child if they are masked -- in the parent, as for forkIO (see #1048). forkOS_createThread - -- creates a thread with exceptions blocked by default. - action1 | b = action0 - | otherwise = unblock action0 + -- creates a thread with exceptions masked by default. + action1 = case b of + Unmasked -> unsafeUnmask action0 + MaskedInterruptible -> action0 + MaskedUninterruptible -> uninterruptibleMask_ action0 action_plus = Exception.catch action1 childHandler @@ -431,8 +434,8 @@ runInUnboundThread action = do then do mv <- newEmptyMVar b <- blocked - _ <- block $ forkIO $ - Exception.try (if b then action else unblock action) >>= + _ <- mask $ \restore -> forkIO $ + Exception.try (if b then action else restore action) >>= putMVar mv takeMVar mv >>= \ei -> case ei of Left exception -> Exception.throw (exception :: SomeException) @@ -482,7 +485,7 @@ foreign import ccall unsafe "rtsSupportsBoundThreads" threaded :: Bool withThread :: IO a -> IO a withThread io = do m <- newEmptyMVar - _ <- block $ forkIO $ try io >>= putMVar m + _ <- mask_ $ forkIO $ try io >>= putMVar m x <- takeMVar m case x of Right a -> return a diff --git a/Control/Concurrent/MVar.hs b/Control/Concurrent/MVar.hs index 352d01e..b2b688a 100644 --- a/Control/Concurrent/MVar.hs +++ b/Control/Concurrent/MVar.hs @@ -60,7 +60,7 @@ import Control.Exception.Base -} readMVar :: MVar a -> IO a readMVar m = - block $ do + mask_ $ do a <- takeMVar m putMVar m a return a @@ -73,7 +73,7 @@ readMVar m = -} swapMVar :: MVar a -> a -> IO a swapMVar mvar new = - block $ do + mask_ $ do old <- takeMVar mvar putMVar mvar new return old @@ -89,9 +89,9 @@ swapMVar mvar new = -- http://www.haskell.org//pipermail/haskell/2006-May/017907.html withMVar :: MVar a -> (a -> IO b) -> IO b withMVar m io = - block $ do + mask $ \restore -> do a <- takeMVar m - b <- unblock (io a) `onException` putMVar m a + b <- restore (io a) `onException` putMVar m a putMVar m a return b @@ -103,9 +103,9 @@ withMVar m io = {-# INLINE modifyMVar_ #-} modifyMVar_ :: MVar a -> (a -> IO a) -> IO () modifyMVar_ m io = - block $ do + mask $ \restore -> do a <- takeMVar m - a' <- unblock (io a) `onException` putMVar m a + a' <- restore (io a) `onException` putMVar m a putMVar m a' {-| @@ -115,8 +115,8 @@ modifyMVar_ m io = {-# INLINE modifyMVar #-} modifyMVar :: MVar a -> (a -> IO (a,b)) -> IO b modifyMVar m io = - block $ do + mask $ \restore -> do a <- takeMVar m - (a',b) <- unblock (io a) `onException` putMVar m a + (a',b) <- restore (io a) `onException` putMVar m a putMVar m a' return b diff --git a/Control/Concurrent/QSem.hs b/Control/Concurrent/QSem.hs index c009aaf..59ffbc7 100644 --- a/Control/Concurrent/QSem.hs +++ b/Control/Concurrent/QSem.hs @@ -22,7 +22,7 @@ module Control.Concurrent.QSem import Prelude import Control.Concurrent.MVar -import Control.Exception ( block ) +import Control.Exception ( mask_ ) import Data.Typeable #include "Typeable.h" @@ -51,7 +51,7 @@ newQSem initial = -- |Wait for a unit to become available waitQSem :: QSem -> IO () -waitQSem (QSem sem) = block $ do +waitQSem (QSem sem) = mask_ $ do (avail,blocked) <- takeMVar sem -- gain ex. access if avail > 0 then let avail' = avail-1 @@ -72,7 +72,7 @@ waitQSem (QSem sem) = block $ do -- |Signal that a unit of the 'QSem' is available signalQSem :: QSem -> IO () -signalQSem (QSem sem) = block $ do +signalQSem (QSem sem) = mask_ $ do (avail,blocked) <- takeMVar sem case blocked of [] -> let avail' = avail+1 diff --git a/Control/Concurrent/QSemN.hs b/Control/Concurrent/QSemN.hs index df3fa42..30c6785 100644 --- a/Control/Concurrent/QSemN.hs +++ b/Control/Concurrent/QSemN.hs @@ -24,7 +24,7 @@ module Control.Concurrent.QSemN import Prelude import Control.Concurrent.MVar -import Control.Exception ( block ) +import Control.Exception ( mask_ ) import Data.Typeable #include "Typeable.h" @@ -46,7 +46,7 @@ newQSemN initial = -- |Wait for the specified quantity to become available waitQSemN :: QSemN -> Int -> IO () -waitQSemN (QSemN sem) sz = block $ do +waitQSemN (QSemN sem) sz = mask_ $ do (avail,blocked) <- takeMVar sem -- gain ex. access let remaining = avail - sz if remaining >= 0 then @@ -60,7 +60,7 @@ waitQSemN (QSemN sem) sz = block $ do -- |Signal that a given quantity is now available from the 'QSemN'. signalQSemN :: QSemN -> Int -> IO () -signalQSemN (QSemN sem) n = block $ do +signalQSemN (QSemN sem) n = mask_ $ do (avail,blocked) <- takeMVar sem (avail',blocked') <- free (avail+n) blocked avail' `seq` putMVar sem (avail',blocked') diff --git a/Control/Concurrent/SampleVar.hs b/Control/Concurrent/SampleVar.hs index ad89a95..c66241e 100644 --- a/Control/Concurrent/SampleVar.hs +++ b/Control/Concurrent/SampleVar.hs @@ -30,7 +30,7 @@ import Prelude import Control.Concurrent.MVar -import Control.Exception ( block ) +import Control.Exception ( mask_ ) import Data.Functor ( (<$>) ) @@ -72,8 +72,8 @@ newSampleVar a = do -- |If the SampleVar is full, leave it empty. Otherwise, do nothing. emptySampleVar :: SampleVar a -> IO () -emptySampleVar (SampleVar v) = block $ do - s@(readers, var) <- block $ takeMVar v +emptySampleVar (SampleVar v) = mask_ $ do + s@(readers, var) <- takeMVar v if readers > 0 then do _ <- takeMVar var putMVar v (0,var) @@ -82,7 +82,7 @@ emptySampleVar (SampleVar v) = block $ do -- |Wait for a value to become available, then take it and return. readSampleVar :: SampleVar a -> IO a -readSampleVar (SampleVar svar) = block $ do +readSampleVar (SampleVar svar) = mask_ $ do -- -- filled => make empty and grab sample -- not filled => try to grab value, empty when read val. @@ -95,7 +95,7 @@ readSampleVar (SampleVar svar) = block $ do -- |Write a value into the 'SampleVar', overwriting any previous value that -- was there. writeSampleVar :: SampleVar a -> a -> IO () -writeSampleVar (SampleVar svar) v = block $ do +writeSampleVar (SampleVar svar) v = mask_ $ do -- -- filled => overwrite -- not filled => fill, write val diff --git a/Control/Exception.hs b/Control/Exception.hs index 47bb057..bbcc490 100644 --- a/Control/Exception.hs +++ b/Control/Exception.hs @@ -104,9 +104,18 @@ module Control.Exception ( -- ** Asynchronous exception control - -- |The following two functions allow a thread to control delivery of + -- |The following functions allow a thread to control delivery of -- asynchronous exceptions during a critical region. + mask, + mask_, + uninterruptibleMask, + uninterruptibleMask_, + MaskingState(..), + getMaskingState, + + -- ** (deprecated) Asynchronous exception control + block, unblock, blocked, @@ -138,7 +147,6 @@ import Control.Exception.Base #ifdef __GLASGOW_HASKELL__ import GHC.Base --- import GHC.IO hiding ( onException, finally ) import Data.Maybe #else import Prelude hiding (catch) @@ -243,7 +251,7 @@ easy to introduce race conditions by the over zealous use of -} {- $block_handler -There\'s an implied 'block' around every exception handler in a call +There\'s an implied 'mask' around every exception handler in a call to one of the 'catch' family of functions. This is because that is what you want most of the time - it eliminates a common race condition in starting an exception handler, because there may be no exception @@ -253,10 +261,9 @@ handler, though, we have time to install a new exception handler before being interrupted. If this weren\'t the default, one would have to write something like -> block ( -> catch (unblock (...)) -> (\e -> handler) -> ) +> block $ \restore -> +> catch (restore (...)) +> (\e -> handler) If you need to unblock asynchronous exceptions again in the exception handler, just use 'unblock' as normal. @@ -268,6 +275,7 @@ recovering from an asynchronous exception. {- $interruptible + #interruptible# Some operations are /interruptible/, which means that they can receive asynchronous exceptions even in the scope of a 'block'. Any function which may itself block is defined as interruptible; this includes @@ -277,11 +285,10 @@ and most operations which perform some I\/O with the outside world. The reason for having interruptible operations is so that we can write things like -> block ( +> mask $ \restore -> do > a <- takeMVar m -> catch (unblock (...)) +> catch (restore (...)) > (\e -> ...) -> ) if the 'Control.Concurrent.MVar.takeMVar' was not interruptible, then this particular diff --git a/Control/Exception/Base.hs b/Control/Exception/Base.hs index 5794de3..a11ff68 100644 --- a/Control/Exception/Base.hs +++ b/Control/Exception/Base.hs @@ -79,6 +79,15 @@ module Control.Exception.Base ( -- ** Asynchronous exception control + mask, + mask_, + uninterruptibleMask, + uninterruptibleMask_, + MaskingState(..), + getMaskingState, + + -- ** (deprecated) Asynchronous exception control + block, unblock, blocked, @@ -505,12 +514,11 @@ bracket -> (a -> IO c) -- ^ computation to run in-between -> IO c -- returns the value from the in-between computation bracket before after thing = - block (do + mask $ \restore -> do a <- before - r <- unblock (thing a) `onException` after a + r <- restore (thing a) `onException` after a _ <- after a return r - ) #endif -- | A specialised variant of 'bracket' with just a computation to run @@ -521,11 +529,10 @@ finally :: IO a -- ^ computation to run first -- was raised) -> IO a -- returns the value from the first computation a `finally` sequel = - block (do - r <- unblock a `onException` sequel + mask $ \restore -> do + r <- restore a `onException` sequel _ <- sequel return r - ) -- | A variant of 'bracket' where the return value from the first computation -- is not required. @@ -540,10 +547,9 @@ bracketOnError -> (a -> IO c) -- ^ computation to run in-between -> IO c -- returns the value from the in-between computation bracketOnError before after thing = - block (do + mask $ \restore -> do a <- before - unblock (thing a) `onException` after a - ) + restore (thing a) `onException` after a #if !(__GLASGOW_HASKELL__ || __NHC__) assert :: Bool -> a -> a diff --git a/Control/OldException.hs b/Control/OldException.hs index f215432..f0435d6 100644 --- a/Control/OldException.hs +++ b/Control/OldException.hs @@ -151,7 +151,7 @@ import Hugs.Prelude as New (ExitCode(..)) #endif import qualified Control.Exception as New -import Control.Exception ( toException, fromException, throw, block, unblock, evaluate, throwIO ) +import Control.Exception ( toException, fromException, throw, block, unblock, mask, evaluate, throwIO ) import System.IO.Error hiding ( catch, try ) import System.IO.Unsafe (unsafePerformIO) import Data.Dynamic @@ -452,14 +452,13 @@ bracket -> (a -> IO c) -- ^ computation to run in-between -> IO c -- returns the value from the in-between computation bracket before after thing = - block (do + mask $ \restore -> do a <- before r <- catch - (unblock (thing a)) + (restore (thing a)) (\e -> do { _ <- after a; throw e }) _ <- after a return r - ) #endif -- | A specialised variant of 'bracket' with just a computation to run @@ -470,13 +469,12 @@ finally :: IO a -- ^ computation to run first -- was raised) -> IO a -- returns the value from the first computation a `finally` sequel = - block (do + mask $ \restore -> do r <- catch - (unblock a) + (restore a) (\e -> do { _ <- sequel; throw e }) _ <- sequel return r - ) -- | A variant of 'bracket' where the return value from the first computation -- is not required. @@ -491,12 +489,11 @@ bracketOnError -> (a -> IO c) -- ^ computation to run in-between -> IO c -- returns the value from the in-between computation bracketOnError before after thing = - block (do + mask $ \restore -> do a <- before catch - (unblock (thing a)) + (restore (thing a)) (\e -> do { _ <- after a; throw e }) - ) -- ----------------------------------------------------------------------------- -- Asynchronous exceptions @@ -523,7 +520,7 @@ easy to introduce race conditions by the over zealous use of -} {- $block_handler -There\'s an implied 'block' around every exception handler in a call +There\'s an implied 'mask_' around every exception handler in a call to one of the 'catch' family of functions. This is because that is what you want most of the time - it eliminates a common race condition in starting an exception handler, because there may be no exception @@ -533,10 +530,9 @@ handler, though, we have time to install a new exception handler before being interrupted. If this weren\'t the default, one would have to write something like -> block ( -> catch (unblock (...)) +> mask $ \restore -> +> catch (restore (...)) > (\e -> handler) -> ) If you need to unblock asynchronous exceptions again in the exception handler, just use 'unblock' as normal. @@ -544,13 +540,13 @@ handler, just use 'unblock' as normal. Note that 'try' and friends /do not/ have a similar default, because there is no exception handler in this case. If you want to use 'try' in an asynchronous-exception-safe way, you will need to use -'block'. +'mask'. -} {- $interruptible Some operations are /interruptible/, which means that they can receive -asynchronous exceptions even in the scope of a 'block'. Any function +asynchronous exceptions even in the scope of a 'mask'. Any function which may itself block is defined as interruptible; this includes 'Control.Concurrent.MVar.takeMVar' (but not 'Control.Concurrent.MVar.tryTakeMVar'), @@ -558,11 +554,10 @@ and most operations which perform some I\/O with the outside world. The reason for having interruptible operations is so that we can write things like -> block ( +> mask $ \restore -> do > a <- takeMVar m -> catch (unblock (...)) +> catch (restore (...)) > (\e -> ...) -> ) if the 'Control.Concurrent.MVar.takeMVar' was not interruptible, then this particular diff --git a/Data/HashTable.hs b/Data/HashTable.hs index 07162d4..8680602 100644 --- a/Data/HashTable.hs +++ b/Data/HashTable.hs @@ -1,4 +1,4 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields -fno-warn-name-shadowing #-} ----------------------------------------------------------------------------- -- | diff --git a/Data/Typeable.hs b/Data/Typeable.hs index 40d07ac..3fec639 100644 --- a/Data/Typeable.hs +++ b/Data/Typeable.hs @@ -96,7 +96,7 @@ import GHC.Err (undefined) import GHC.Num (Integer, fromInteger, (+)) import GHC.Real ( rem, Ratio ) import GHC.IORef (IORef,newIORef) -import GHC.IO (unsafePerformIO,block) +import GHC.IO (unsafePerformIO,mask_) -- These imports are so we can define Typeable instances -- It'd be better to give Typeable instances in the modules themselves @@ -681,7 +681,7 @@ cache = unsafePerformIO $ do tc_tbl = empty_tc_tbl, ap_tbl = empty_ap_tbl } #ifdef __GLASGOW_HASKELL__ - block $ do + mask_ $ do stable_ref <- newStablePtr ret let ref = castStablePtrToPtr stable_ref ref2 <- getOrSetTypeableStore ref diff --git a/Foreign/Marshal/Pool.hs b/Foreign/Marshal/Pool.hs index 47e4f86..f15d048 100644 --- a/Foreign/Marshal/Pool.hs +++ b/Foreign/Marshal/Pool.hs @@ -48,7 +48,7 @@ module Foreign.Marshal.Pool ( import GHC.Base ( Int, Monad(..), (.), not ) import GHC.Err ( undefined ) import GHC.Exception ( throw ) -import GHC.IO ( IO, block, unblock, catchAny ) +import GHC.IO ( IO, mask, catchAny ) import GHC.IORef ( IORef, newIORef, readIORef, writeIORef ) import GHC.List ( elem, length ) import GHC.Num ( Num(..) ) @@ -97,10 +97,10 @@ freePool (Pool pool) = readIORef pool >>= freeAll withPool :: (Pool -> IO b) -> IO b #ifdef __GLASGOW_HASKELL__ withPool act = -- ATTENTION: cut-n-paste from Control.Exception below! - block (do + mask (\restore -> do pool <- newPool val <- catchAny - (unblock (act pool)) + (restore (act pool)) (\e -> do freePool pool; throw e) freePool pool return val) diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index ec6e064..d676a1a 100644 --- a/GHC/Conc.lhs +++ b/GHC/Conc.lhs @@ -29,7 +29,9 @@ module GHC.Conc -- * Forking and suchlike , forkIO -- :: IO a -> IO ThreadId + , forkIOUnmasked , forkOnIO -- :: Int -> IO a -> IO ThreadId + , forkOnIOUnmasked , numCapabilities -- :: Int , childHandler -- :: Exception -> IO () , myThreadId -- :: IO ThreadId @@ -211,8 +213,8 @@ thread. The new thread will be a lightweight thread; if you want to use a foreign library that uses thread-local storage, use 'Control.Concurrent.forkOS' instead. -GHC note: the new thread inherits the /blocked/ state of the parent -(see 'Control.Exception.block'). +GHC note: the new thread inherits the /masked/ state of the parent +(see 'Control.Exception.mask'). The newly created thread has an exception handler that discards the exceptions 'BlockedIndefinitelyOnMVar', 'BlockedIndefinitelyOnSTM', and @@ -225,6 +227,11 @@ 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'). +forkIOUnmasked :: IO () -> IO ThreadId +forkIOUnmasked io = forkIO (unsafeUnmask io) + {- | Like 'forkIO', but lets you specify on which CPU the thread is created. Unlike a `forkIO` thread, a thread created by `forkOnIO` @@ -244,6 +251,11 @@ 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'). +forkOnIOUnmasked :: Int -> IO () -> IO ThreadId +forkOnIOUnmasked cpu io = forkOnIO cpu (unsafeUnmask io) + -- | 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 @@ -301,7 +313,7 @@ another thread. If the target thread is currently making a foreign call, then the exception will not be raised (and hence 'throwTo' will not return) until the call has completed. This is the case regardless of whether -the call is inside a 'block' or not. +the call is inside a 'mask' or not. Important note: the behaviour of 'throwTo' differs from that described in the paper \"Asynchronous exceptions in Haskell\" @@ -611,18 +623,18 @@ MVar utilities \begin{code} withMVar :: MVar a -> (a -> IO b) -> IO b withMVar m io = - block $ do + mask $ \restore -> do a <- takeMVar m - b <- catchAny (unblock (io a)) + b <- catchAny (restore (io a)) (\e -> do putMVar m a; throw e) putMVar m a return b modifyMVar_ :: MVar a -> (a -> IO a) -> IO () modifyMVar_ m io = - block $ do + mask $ \restore -> do a <- takeMVar m - a' <- catchAny (unblock (io a)) + a' <- catchAny (restore (io a)) (\e -> do putMVar m a; throw e) putMVar m a' return () @@ -861,7 +873,7 @@ prodServiceThread = do -- sharedCAF :: a -> (Ptr a -> IO (Ptr a)) -> IO a sharedCAF a get_or_set = - block $ do + mask_ $ do stable_ref <- newStablePtr a let ref = castPtr (castStablePtrToPtr stable_ref) ref2 <- get_or_set ref diff --git a/GHC/IO.hs b/GHC/IO.hs index 8a2dd59..c57abdc 100644 --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -1,4 +1,5 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields -XBangPatterns #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# LANGUAGE NoImplicitPrelude, BangPatterns, RankNTypes #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -27,13 +28,16 @@ module GHC.IO ( FilePath, catchException, catchAny, throwIO, - block, unblock, blocked, + mask, mask_, uninterruptibleMask, uninterruptibleMask_, + MaskingState(..), getMaskingState, + block, unblock, blocked, unsafeUnmask, onException, finally, evaluate ) where import GHC.Base import GHC.ST import GHC.Exception +import GHC.Show import Data.Maybe import {-# SOURCE #-} GHC.IO.Exception ( userError ) @@ -277,11 +281,14 @@ throwIO e = IO (raiseIO# (toException e)) -- ----------------------------------------------------------------------------- -- Controlling asynchronous exception delivery --- | Applying 'block' to a computation will +{-# DEPRECATED block "use Control.Exception.mask instead" #-} +-- | Note: this function is deprecated, please use 'mask' instead. +-- +-- Applying 'block' to a computation will -- execute that computation with asynchronous exceptions -- /blocked/. That is, any thread which -- attempts to raise an exception in the current thread with 'Control.Exception.throwTo' will be --- blocked until asynchronous exceptions are enabled again. There\'s +-- blocked until asynchronous exceptions are unblocked again. There\'s -- no need to worry about re-enabling asynchronous exceptions; that is -- done automatically on exiting the scope of -- 'block'. @@ -292,37 +299,142 @@ throwIO e = IO (raiseIO# (toException e)) -- establish an exception handler in the forked thread before any -- asynchronous exceptions are received. block :: IO a -> IO a +block (IO io) = IO $ maskAsyncExceptions# io --- | To re-enable asynchronous exceptions inside the scope of +{-# DEPRECATED unblock "use Control.Exception.mask instead" #-} +-- | Note: this function is deprecated, please use 'mask' instead. +-- +-- To re-enable asynchronous exceptions inside the scope of -- 'block', 'unblock' can be -- used. It scopes in exactly the same way, so on exit from -- 'unblock' asynchronous exception delivery will -- be disabled again. unblock :: IO a -> IO a - -block (IO io) = IO $ blockAsyncExceptions# io -unblock (IO io) = IO $ unblockAsyncExceptions# io +unblock = unsafeUnmask + +unsafeUnmask :: IO a -> IO a +unsafeUnmask (IO io) = IO $ unmaskAsyncExceptions# io + +blockUninterruptible :: IO a -> IO a +blockUninterruptible (IO io) = IO $ maskUninterruptible# io + +-- | Describes the behaviour of a thread when an asynchronous +-- exception is received. +data MaskingState + = Unmasked -- ^ asynchronous exceptions are unmasked (the normal state) + | MaskedInterruptible + -- ^ the state during 'mask': asynchronous exceptions are masked, but blocking operations may still be interrupted + | MaskedUninterruptible + -- ^ the state during 'uninterruptibleMask': asynchronous exceptions are masked, and blocking operations may not be interrupted + deriving (Eq,Show) + +-- | Returns the 'MaskingState' for the current thread. +getMaskingState :: IO MaskingState +getMaskingState = IO $ \s -> + case getMaskingState# s of + (# s', i #) -> (# s', case i of + 0# -> Unmasked + 1# -> MaskedUninterruptible + _ -> MaskedInterruptible #) -- | returns True if asynchronous exceptions are blocked in the -- current thread. blocked :: IO Bool -blocked = IO $ \s -> case asyncExceptionsBlocked# s of - (# s', i #) -> (# s', i /=# 0# #) +blocked = fmap (/= Unmasked) getMaskingState onException :: IO a -> IO b -> IO a onException io what = io `catchException` \e -> do _ <- what throw (e :: SomeException) +-- | Executes an IO computation with asynchronous +-- exceptions /masked/. That is, any thread which attempts to raise +-- an exception in the current thread with 'Control.Exception.throwTo' +-- will be blocked until asynchronous exceptions are unmasked again. +-- +-- The argument passed to 'mask' is a function that takes as its +-- argument another function, which can be used to restore the +-- prevailing masking state within the context of the masked +-- computation. For example, a common way to use 'mask' is to protect +-- the acquisition of a resource: +-- +-- > mask $ \restore -> do +-- > x <- acquire +-- > restore (do_something_with x) `onException` release +-- > release +-- +-- This code guarantees that @acquire@ is paired with @release@, by masking +-- asynchronous exceptions for the critical parts. (Rather than write +-- this code yourself, it would be better to use +-- 'Control.Exception.bracket' which abstracts the general pattern). +-- +-- Note that the @restore@ action passed to the argument to 'mask' +-- does not necessarily unmask asynchronous exceptions, it just +-- restores the masking state to that of the enclosing context. Thus +-- if asynchronous exceptions are already masked, 'mask' cannot be used +-- to unmask exceptions again. This is so that if you call a library function +-- with exceptions masked, you can be sure that the library call will not be +-- able to unmask exceptions again. If you are writing library code and need +-- to use asynchronous exceptions, the only way is to create a new thread; +-- see 'Control.Concurrent.forkIOUnmasked'. +-- +-- Asynchronous exceptions may still be received while in the masked +-- state if the masked thread /blocks/ in certain ways; see +-- "Control.Exception#interruptible". +-- +-- Threads created by 'Control.Concurrent.forkIO' inherit the masked +-- state from the parent; that is, to start a thread in blocked mode, +-- use @mask_ $ forkIO ...@. This is particularly useful if you need +-- to establish an exception handler in the forked thread before any +-- asynchronous exceptions are received. To create a a new thread in +-- an unmasked state use 'Control.Concurrent.forkIOUnmasked'. +-- +mask :: ((forall a. IO a -> IO a) -> IO b) -> IO b + +-- | Like 'mask', but does not pass a @restore@ action to the argument. +mask_ :: IO a -> IO a + +-- | Like 'mask', but the masked computation is not interruptible (see +-- "Control.Exception#interruptible"). THIS SHOULD BE USED WITH +-- GREAT CARE, because if a thread executing in 'uninterruptibleMask' +-- blocks for any reason, then the thread (and possibly the program, +-- if this is the main thread) will be unresponsive and unkillable. +-- This function should only be necessary if you need to mask +-- exceptions around an interruptible operation, and you can guarantee +-- that the interruptible operation will only block for a short period +-- of time. +-- +uninterruptibleMask :: ((forall a. IO a -> IO a) -> IO b) -> IO b + +-- | Like 'uninterruptibleMask', but does not pass a @restore@ action +-- to the argument. +uninterruptibleMask_ :: IO a -> IO a + +mask_ io = mask $ \_ -> io + +mask io = do + b <- getMaskingState + case b of + Unmasked -> block $ io unblock + _ -> io id + +uninterruptibleMask_ io = uninterruptibleMask $ \_ -> io + +uninterruptibleMask io = do + b <- getMaskingState + case b of + Unmasked -> blockUninterruptible $ io unblock + MaskedInterruptible -> blockUninterruptible $ io block + MaskedUninterruptible -> io id + finally :: IO a -- ^ computation to run first -> IO b -- ^ computation to run afterward (even if an exception -- was raised) -> IO a -- returns the value from the first computation a `finally` sequel = - block (do - r <- unblock a `onException` sequel + mask $ \restore -> do + r <- restore a `onException` sequel _ <- sequel return r - ) -- | Forces its argument to be evaluated to weak head normal form when -- the resultant 'IO' action is executed. It can be used to order diff --git a/GHC/IO/Handle/Internals.hs b/GHC/IO/Handle/Internals.hs index 2c0523f..5568855 100644 --- a/GHC/IO/Handle/Internals.hs +++ b/GHC/IO/Handle/Internals.hs @@ -124,7 +124,7 @@ withHandle fun h@(DuplexHandle _ m _) act = withHandle' fun h m act withHandle' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO (Handle__,a)) -> IO a withHandle' fun h m act = - block $ do + mask_ $ do (h',v) <- do_operation fun h act m checkHandleInvariants h' putMVar m h' @@ -149,7 +149,7 @@ withAllHandles__ fun h@(DuplexHandle _ r w) act = do withHandle__' :: String -> Handle -> MVar Handle__ -> (Handle__ -> IO Handle__) -> IO () withHandle__' fun h m act = - block $ do + mask_ $ do h' <- do_operation fun h act m checkHandleInvariants h' putMVar m h' -- 1.7.10.4