X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=9fa7299dd5ec522c8c0a504a5ee3b17ad1e002ed;hb=41e8fba828acbae1751628af50849f5352b27873;hp=f2ccc7d5b974047d2bc20c7e981cc61cf149017a;hpb=7e8f2da24a671fa3b314e49f244cabe37af7ccd2;p=ghc-base.git diff --git a/GHC/IO.hs b/GHC/IO.hs index f2ccc7d..9fa7299 100644 --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -1,5 +1,10 @@ -{-# OPTIONS_GHC -fno-warn-orphans #-} -{-# OPTIONS_GHC -XNoImplicitPrelude -funbox-strict-fields #-} +{-# LANGUAGE NoImplicitPrelude + , BangPatterns + , RankNTypes + , MagicHash + , UnboxedTuples + #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | @@ -28,13 +33,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 ) @@ -102,11 +110,15 @@ This is the \"back door\" into the 'IO' monad, allowing this to be safe, the 'IO' computation should be free of side effects and independent of its environment. -If the I\/O computation wrapped in 'unsafePerformIO' -performs side effects, then the relative order in which those side -effects take place (relative to the main I\/O trunk, or other calls to -'unsafePerformIO') is indeterminate. You have to be careful when -writing and compiling modules that use 'unsafePerformIO': +If the I\/O computation wrapped in 'unsafePerformIO' performs side +effects, then the relative order in which those side effects take +place (relative to the main I\/O trunk, or other calls to +'unsafePerformIO') is indeterminate. Furthermore, when using +'unsafePerformIO' to cause side-effects, you should take the following +precautions to ensure the side effects are performed as many times as +you expect them to be. Note that these precautions are necessary for +GHC, but may not be sufficient, and other compilers may require +different precautions: * Use @{\-\# NOINLINE foo \#-\}@ as a pragma on any function @foo@ that calls 'unsafePerformIO'. If the call is inlined, @@ -117,7 +129,7 @@ writing and compiling modules that use 'unsafePerformIO': two side effects that were meant to be separate. A good example is using multiple global variables (like @test@ in the example below). - * Make sure that the either you switch off let-floating, or that the + * Make sure that the either you switch off let-floating (@-fno-full-laziness@), or that the call to 'unsafePerformIO' cannot float outside a lambda. For example, if you say: @ @@ -247,7 +259,7 @@ catchException :: Exception e => IO a -> (e -> IO a) -> IO a catchException (IO io) handler = IO $ catch# io handler' where handler' e = case fromException e of Just e' -> unIO (handler e') - Nothing -> raise# e + Nothing -> raiseIO# e catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a catchAny (IO io) handler = IO $ catch# io handler' @@ -274,11 +286,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'. @@ -289,37 +304,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) + throwIO (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 @@ -336,7 +456,4 @@ a `finally` sequel = -- > evaluate x = (return $! x) >>= return -- evaluate :: a -> IO a -evaluate a = IO $ \s -> case a `seq` () of () -> (# s, a #) - -- NB. can't write - -- a `seq` (# s, a #) - -- because we can't have an unboxed tuple as a function argument +evaluate a = IO $ \s -> let !va = a in (# s, va #) -- NB. see #2273