X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=ad98a5ebf5460392c3e8523d65cffe74388a6f50;hb=HEAD;hp=830889ea1047263391a418baf605f8b913dafd7d;hpb=5ca4b4302f3e41760081ebd1ad9c193d59865698;p=ghc-base.git diff --git a/GHC/IO.hs b/GHC/IO.hs index 830889e..ad98a5e 100644 --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -1,988 +1,472 @@ -{-# OPTIONS -fno-implicit-prelude -#include "HsBase.h" #-} - -#undef DEBUG_DUMP - +{-# LANGUAGE NoImplicitPrelude + , BangPatterns + , RankNTypes + , MagicHash + , UnboxedTuples + #-} +{-# OPTIONS_GHC -funbox-strict-fields #-} +{-# OPTIONS_HADDOCK hide #-} ----------------------------------------------------------------------------- -- | -- Module : GHC.IO --- Copyright : (c) The University of Glasgow, 1992-2001 +-- Copyright : (c) The University of Glasgow 1994-2002 -- License : see libraries/base/LICENSE -- --- Maintainer : libraries@haskell.org +-- Maintainer : cvs-ghc@haskell.org -- Stability : internal --- Portability : non-portable +-- Portability : non-portable (GHC Extensions) -- --- String I\/O functions +-- Definitions for the 'IO' monad and its friends. -- ----------------------------------------------------------------------------- -module GHC.IO ( - hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr, - commitBuffer', -- hack, see below - hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs - hGetBuf, hGetBufNonBlocking, hPutBuf, hPutBufNonBlocking, slurpFile, -{- NOTE: As far as I can tell, not defined. - createPipe, createPipeEx, --} - memcpy_ba_baoff, - memcpy_ptr_baoff, - memcpy_baoff_ba, - memcpy_baoff_ptr, - ) where +-- #hide +module GHC.IO ( + IO(..), unIO, failIO, liftIO, + unsafePerformIO, unsafeInterleaveIO, + unsafeDupablePerformIO, unsafeDupableInterleaveIO, + noDuplicate, -#include "config.h" + -- To and from from ST + stToIO, ioToST, unsafeIOToST, unsafeSTToIO, -import Foreign -import Foreign.C + FilePath, -import System.IO.Error -import Data.Maybe -import Control.Monad -import System.Posix.Internals + catchException, catchAny, throwIO, + mask, mask_, uninterruptibleMask, uninterruptibleMask_, + MaskingState(..), getMaskingState, + block, unblock, blocked, unsafeUnmask, + onException, bracket, finally, evaluate + ) where -import GHC.Enum import GHC.Base -import GHC.IOBase -import GHC.Handle -- much of the real stuff is in here -import GHC.Real -import GHC.Num +import GHC.ST +import GHC.Exception import GHC.Show -import GHC.List -import GHC.Exception ( ioError, catch ) -import GHC.Conc +import Data.Maybe + +import {-# SOURCE #-} GHC.IO.Exception ( userError ) -- --------------------------------------------------------------------------- --- Simple input operations +-- The IO Monad --- If hWaitForInput finds anything in the Handle's buffer, it --- immediately returns. If not, it tries to read from the underlying --- OS handle. Notice that for buffered Handles connected to terminals --- this means waiting until a complete line is available. +{- +The IO Monad is just an instance of the ST monad, where the state is +the real world. We use the exception mechanism (in GHC.Exception) to +implement IO exceptions. --- | Computation 'hWaitForInput' @hdl t@ --- waits until input is available on handle @hdl@. --- It returns 'True' as soon as input is available on @hdl@, --- or 'False' if no input is available within @t@ milliseconds. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. +NOTE: The IO representation is deeply wired in to various parts of the +system. The following list may or may not be exhaustive: -hWaitForInput :: Handle -> Int -> IO Bool -hWaitForInput h msecs = do - wantReadableHandle "hWaitForInput" h $ \ handle_ -> do - let ref = haBuffer handle_ - buf <- readIORef ref +Compiler - types of various primitives in PrimOp.lhs - if not (bufferEmpty buf) - then return True - else do +RTS - forceIO (StgMiscClosures.hc) + - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast + (Exceptions.hc) + - raiseAsync (Schedule.c) - r <- throwErrnoIfMinus1Retry "hWaitForInput" - (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs) (haIsStream handle_)) - return (r /= 0) +Prelude - GHC.IO.lhs, and several other places including + GHC.Exception.lhs. -foreign import ccall unsafe "inputReady" - inputReady :: CInt -> CInt -> Bool -> IO CInt - --- --------------------------------------------------------------------------- --- hGetChar +Libraries - parts of hslibs/lang. --- | Computation 'hGetChar' @hdl@ reads a character from the file or --- channel managed by @hdl@, blocking until a character is available. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. - -hGetChar :: Handle -> IO Char -hGetChar handle = - wantReadableHandle "hGetChar" handle $ \handle_ -> do - - let fd = haFD handle_ - ref = haBuffer handle_ - - buf <- readIORef ref - if not (bufferEmpty buf) - then hGetcBuffered fd ref buf - else do - - -- buffer is empty. - case haBufferMode handle_ of - LineBuffering -> do - new_buf <- fillReadBuffer fd True (haIsStream handle_) buf - hGetcBuffered fd ref new_buf - BlockBuffering _ -> do - new_buf <- fillReadBuffer fd True (haIsStream handle_) buf - -- ^^^^ - -- don't wait for a completely full buffer. - hGetcBuffered fd ref new_buf - NoBuffering -> do - -- make use of the minimal buffer we already have - let raw = bufBuf buf - r <- readRawBuffer "hGetChar" (fromIntegral fd) (haIsStream handle_) raw 0 1 - if r == 0 - then ioe_EOF - else do (c,_) <- readCharFromBuffer raw 0 - return c - -hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } - = do (c,r) <- readCharFromBuffer b r - let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 } - | otherwise = buf{ bufRPtr=r } - writeIORef ref new_buf - return c +--SDM +-} --- --------------------------------------------------------------------------- --- hGetLine +liftIO :: IO a -> State# RealWorld -> STret RealWorld a +liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r --- ToDo: the unbuffered case is wrong: it doesn't lock the handle for --- the duration. +failIO :: String -> IO a +failIO s = IO (raiseIO# (toException (userError s))) --- | Computation 'hGetLine' @hdl@ reads a line from the file or --- channel managed by @hdl@. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file is encountered when reading --- the /first/ character of the line. --- --- If 'hGetLine' encounters end-of-file at any other point while reading --- in a line, it is treated as a line terminator and the (partial) --- line is returned. - -hGetLine :: Handle -> IO String -hGetLine h = do - m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do - case haBufferMode handle_ of - NoBuffering -> return Nothing - LineBuffering -> do - l <- hGetLineBuffered handle_ - return (Just l) - BlockBuffering _ -> do - l <- hGetLineBuffered handle_ - return (Just l) - case m of - Nothing -> hGetLineUnBuffered h - Just l -> return l - - -hGetLineBuffered handle_ = do - let ref = haBuffer handle_ - buf <- readIORef ref - hGetLineBufferedLoop handle_ ref buf [] - - -hGetLineBufferedLoop handle_ ref - buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss = - let - -- find the end-of-line character, if there is one - loop raw r - | r == w = return (False, w) - | otherwise = do - (c,r') <- readCharFromBuffer raw r - if c == '\n' - then return (True, r) -- NB. not r': don't include the '\n' - else loop raw r' - in do - (eol, off) <- loop raw r - -#ifdef DEBUG_DUMP - puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n") -#endif - - xs <- unpack raw r off - - -- if eol == True, then off is the offset of the '\n' - -- otherwise off == w and the buffer is now empty. - if eol - then do if (w == off + 1) - then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - else writeIORef ref buf{ bufRPtr = off + 1 } - return (concat (reverse (xs:xss))) - else do - maybe_buf <- maybeFillReadBuffer (haFD handle_) True (haIsStream handle_) - buf{ bufWPtr=0, bufRPtr=0 } - case maybe_buf of - -- Nothing indicates we caught an EOF, and we may have a - -- partial line to return. - Nothing -> do - writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - let str = concat (reverse (xs:xss)) - if not (null str) - then return str - else ioe_EOF - Just new_buf -> - hGetLineBufferedLoop handle_ ref new_buf (xs:xss) - - -maybeFillReadBuffer fd is_line is_stream buf - = catch - (do buf <- fillReadBuffer fd is_line is_stream buf - return (Just buf) - ) - (\e -> do if isEOFError e - then return Nothing - else ioError e) - - -unpack :: RawBuffer -> Int -> Int -> IO [Char] -unpack buf r 0 = return "" -unpack buf (I# r) (I# len) = IO $ \s -> unpack [] (len -# 1#) s - where - unpack acc i s - | i <# r = (# s, acc #) - | otherwise = - case readCharArray# buf i s of - (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s - - -hGetLineUnBuffered :: Handle -> IO String -hGetLineUnBuffered h = do - c <- hGetChar h - if c == '\n' then - return "" - else do - l <- getRest - return (c:l) - where - getRest = do - c <- - catch - (hGetChar h) - (\ err -> do - if isEOFError err then - return '\n' - else - ioError err) - if c == '\n' then - return "" - else do - s <- getRest - return (c:s) +-- --------------------------------------------------------------------------- +-- Coercions between IO and ST --- ----------------------------------------------------------------------------- --- hGetContents +-- | A monad transformer embedding strict state transformers in the 'IO' +-- monad. The 'RealWorld' parameter indicates that the internal state +-- used by the 'ST' computation is a special one supplied by the 'IO' +-- monad, and thus distinct from those used by invocations of 'runST'. +stToIO :: ST RealWorld a -> IO a +stToIO (ST m) = IO m --- hGetContents on a DuplexHandle only affects the read side: you can --- carry on writing to it afterwards. +ioToST :: IO a -> ST RealWorld a +ioToST (IO m) = (ST m) --- | Computation 'hGetContents' @hdl@ returns the list of characters --- corresponding to the unread portion of the channel or file managed --- by @hdl@, which is put into an intermediate state, /semi-closed/. --- In this state, @hdl@ is effectively closed, --- but items are read from @hdl@ on demand and accumulated in a special --- list returned by 'hGetContents' @hdl@. +-- This relies on IO and ST having the same representation modulo the +-- constraint on the type of the state -- --- Any operation that fails because a handle is closed, --- also fails if a handle is semi-closed. The only exception is 'hClose'. --- A semi-closed handle becomes closed: --- --- * if 'hClose' is applied to it; --- --- * if an I\/O error occurs when reading an item from the handle; --- --- * or once the entire contents of the handle has been read. --- --- Once a semi-closed handle becomes closed, the contents of the --- associated list becomes fixed. The contents of this final list is --- only partially specified: it will contain at least all the items of --- the stream that were evaluated prior to the handle becoming closed. --- --- Any I\/O errors encountered while a handle is semi-closed are simply --- discarded. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. - -hGetContents :: Handle -> IO String -hGetContents handle = - withHandle "hGetContents" handle $ \handle_ -> - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notReadable - WriteHandle -> ioe_notReadable - _ -> do xs <- lazyRead handle - return (handle_{ haType=SemiClosedHandle}, xs ) - --- Note that someone may close the semi-closed handle (or change its --- buffering), so each time these lazy read functions are pulled on, --- they have to check whether the handle has indeed been closed. - -lazyRead :: Handle -> IO String -lazyRead handle = - unsafeInterleaveIO $ - withHandle "lazyRead" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return (handle_, "") - SemiClosedHandle -> lazyRead' handle handle_ - _ -> ioException - (IOError (Just handle) IllegalOperation "lazyRead" - "illegal handle type" Nothing) - -lazyRead' h handle_ = do - let ref = haBuffer handle_ - fd = haFD handle_ - - -- even a NoBuffering handle can have a char in the buffer... - -- (see hLookAhead) - buf <- readIORef ref - if not (bufferEmpty buf) - then lazyReadHaveBuffer h handle_ fd ref buf - else do - - case haBufferMode handle_ of - NoBuffering -> do - -- make use of the minimal buffer we already have - let raw = bufBuf buf - r <- readRawBuffer "lazyRead" (fromIntegral fd) (haIsStream handle_) raw 0 1 - if r == 0 - then do handle_ <- hClose_help handle_ - return (handle_, "") - else do (c,_) <- readCharFromBuffer raw 0 - rest <- lazyRead h - return (handle_, c : rest) - - LineBuffering -> lazyReadBuffered h handle_ fd ref buf - BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf - --- we never want to block during the read, so we call fillReadBuffer with --- is_line==True, which tells it to "just read what there is". -lazyReadBuffered h handle_ fd ref buf = do - catch - (do buf <- fillReadBuffer fd True{-is_line-} (haIsStream handle_) buf - lazyReadHaveBuffer h handle_ fd ref buf - ) - -- all I/O errors are discarded. Additionally, we close the handle. - (\e -> do handle_ <- hClose_help handle_ - return (handle_, "") - ) - -lazyReadHaveBuffer h handle_ fd ref buf = do - more <- lazyRead h - writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more - return (handle_, s) - - -unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char] -unpackAcc buf r 0 acc = return acc -unpackAcc buf (I# r) (I# len) acc = IO $ \s -> unpack acc (len -# 1#) s - where - unpack acc i s - | i <# r = (# s, acc #) - | otherwise = - case readCharArray# buf i s of - (# s, ch #) -> unpack (C# ch : acc) (i -# 1#) s - --- --------------------------------------------------------------------------- --- hPutChar +unsafeIOToST :: IO a -> ST s a +unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s --- | Computation 'hPutChar' @hdl ch@ writes the character @ch@ to the --- file or channel managed by @hdl@. Characters may be buffered if --- buffering is enabled for @hdl@. --- --- This operation may fail with: --- --- * 'isFullError' if the device is full; or --- --- * 'isPermissionError' if another system resource limit would be exceeded. - -hPutChar :: Handle -> Char -> IO () -hPutChar handle c = - c `seq` do -- must evaluate c before grabbing the handle lock - wantWritableHandle "hPutChar" handle $ \ handle_ -> do - let fd = haFD handle_ - case haBufferMode handle_ of - LineBuffering -> hPutcBuffered handle_ True c - BlockBuffering _ -> hPutcBuffered handle_ False c - NoBuffering -> - withObject (castCharToCChar c) $ \buf -> do - writeRawBufferPtr "hPutChar" (fromIntegral fd) (haIsStream handle_) buf 0 1 - return () - -hPutcBuffered handle_ is_line c = do - let ref = haBuffer handle_ - buf <- readIORef ref - let w = bufWPtr buf - w' <- writeCharIntoBuffer (bufBuf buf) w c - let new_buf = buf{ bufWPtr = w' } - if bufferFull new_buf || is_line && c == '\n' - then do - flushed_buf <- flushWriteBuffer (haFD handle_) (haIsStream handle_) new_buf - writeIORef ref flushed_buf - else do - writeIORef ref new_buf - - -hPutChars :: Handle -> [Char] -> IO () -hPutChars handle [] = return () -hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs +unsafeSTToIO :: ST s a -> IO a +unsafeSTToIO (ST m) = IO (unsafeCoerce# m) -- --------------------------------------------------------------------------- --- hPutStr +-- Unsafe IO operations + +{-| +This is the \"back door\" into the 'IO' monad, allowing +'IO' computation to be performed at any time. For +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. 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, + the I\/O may be performed more than once. + + * Use the compiler flag @-fno-cse@ to prevent common sub-expression + elimination being performed on the module, which might combine + 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 (@-fno-full-laziness@), or that the + call to 'unsafePerformIO' cannot float outside a lambda. For example, + if you say: + @ + f x = unsafePerformIO (newIORef []) + @ + you may get only one reference cell shared between all calls to @f@. + Better would be + @ + f x = unsafePerformIO (newIORef [x]) + @ + because now it can't float outside the lambda. + +It is less well known that +'unsafePerformIO' is not type safe. For example: + +> test :: IORef [a] +> test = unsafePerformIO $ newIORef [] +> +> main = do +> writeIORef test [42] +> bang <- readIORef test +> print (bang :: [Char]) + +This program will core dump. This problem with polymorphic references +is well known in the ML community, and does not arise with normal +monadic use of references. There is no easy way to make it impossible +once you use 'unsafePerformIO'. Indeed, it is +possible to write @coerce :: a -> b@ with the +help of 'unsafePerformIO'. So be careful! +-} +unsafePerformIO :: IO a -> a +unsafePerformIO m = unsafeDupablePerformIO (noDuplicate >> m) --- We go to some trouble to avoid keeping the handle locked while we're --- evaluating the string argument to hPutStr, in case doing so triggers another --- I/O operation on the same handle which would lead to deadlock. The classic --- case is --- --- putStr (trace "hello" "world") --- --- so the basic scheme is this: --- --- * copy the string into a fresh buffer, --- * "commit" the buffer to the handle. --- --- Committing may involve simply copying the contents of the new --- buffer into the handle's buffer, flushing one or both buffers, or --- maybe just swapping the buffers over (if the handle's buffer was --- empty). See commitBuffer below. +{-| +This version of 'unsafePerformIO' is slightly more efficient, +because it omits the check that the IO is only being performed by a +single thread. Hence, when you write 'unsafeDupablePerformIO', +there is a possibility that the IO action may be performed multiple +times (on a multiprocessor), and you should therefore ensure that +it gives the same results each time. +-} +{-# NOINLINE unsafeDupablePerformIO #-} +unsafeDupablePerformIO :: IO a -> a +unsafeDupablePerformIO (IO m) = lazy (case m realWorld# of (# _, r #) -> r) + +-- Why do we NOINLINE unsafeDupablePerformIO? See the comment with +-- GHC.ST.runST. Essentially the issue is that the IO computation +-- inside unsafePerformIO must be atomic: it must either all run, or +-- not at all. If we let the compiler see the application of the IO +-- to realWorld#, it might float out part of the IO. + +-- Why is there a call to 'lazy' in unsafeDupablePerformIO? +-- If we don't have it, the demand analyser discovers the following strictness +-- for unsafeDupablePerformIO: C(U(AV)) +-- But then consider +-- unsafeDupablePerformIO (\s -> let r = f x in +-- case writeIORef v r s of (# s1, _ #) -> +-- (# s1, r #) +-- The strictness analyser will find that the binding for r is strict, +-- (becuase of uPIO's strictness sig), and so it'll evaluate it before +-- doing the writeIORef. This actually makes tests/lib/should_run/memo002 +-- get a deadlock! +-- +-- Solution: don't expose the strictness of unsafeDupablePerformIO, +-- by hiding it with 'lazy' + +{-| +'unsafeInterleaveIO' allows 'IO' computation to be deferred lazily. +When passed a value of type @IO a@, the 'IO' will only be performed +when the value of the @a@ is demanded. This is used to implement lazy +file reading, see 'System.IO.hGetContents'. +-} +{-# INLINE unsafeInterleaveIO #-} +unsafeInterleaveIO :: IO a -> IO a +unsafeInterleaveIO m = unsafeDupableInterleaveIO (noDuplicate >> m) + +-- We believe that INLINE on unsafeInterleaveIO is safe, because the +-- state from this IO thread is passed explicitly to the interleaved +-- IO, so it cannot be floated out and shared. + +{-# INLINE unsafeDupableInterleaveIO #-} +unsafeDupableInterleaveIO :: IO a -> IO a +unsafeDupableInterleaveIO (IO m) + = IO ( \ s -> let + r = case m s of (# _, res #) -> res + in + (# s, r #)) --- | Computation 'hPutStr' @hdl s@ writes the string --- @s@ to the file or channel managed by @hdl@. --- --- This operation may fail with: --- --- * 'isFullError' if the device is full; or --- --- * 'isPermissionError' if another system resource limit would be exceeded. - -hPutStr :: Handle -> String -> IO () -hPutStr handle str = do - buffer_mode <- wantWritableHandle "hPutStr" handle - (\ handle_ -> do getSpareBuffer handle_) - case buffer_mode of - (NoBuffering, _) -> do - hPutChars handle str -- v. slow, but we don't care - (LineBuffering, buf) -> do - writeLines handle buf str - (BlockBuffering _, buf) -> do - writeBlocks handle buf str - - -getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer) -getSpareBuffer Handle__{haBuffer=ref, - haBuffers=spare_ref, - haBufferMode=mode} - = do - case mode of - NoBuffering -> return (mode, error "no buffer!") - _ -> do - bufs <- readIORef spare_ref - buf <- readIORef ref - case bufs of - BufferListCons b rest -> do - writeIORef spare_ref rest - return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf)) - BufferListNil -> do - new_buf <- allocateBuffer (bufSize buf) WriteBuffer - return (mode, new_buf) - - -writeLines :: Handle -> Buffer -> String -> IO () -writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s = - let - shoveString :: Int -> [Char] -> IO () - -- check n == len first, to ensure that shoveString is strict in n. - shoveString n cs | n == len = do - new_buf <- commitBuffer hdl raw len n True{-needs flush-} False - writeLines hdl new_buf cs - shoveString n [] = do - commitBuffer hdl raw len n False{-no flush-} True{-release-} - return () - shoveString n (c:cs) = do - n' <- writeCharIntoBuffer raw n c - if (c == '\n') - then do - new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False - writeLines hdl new_buf cs - else - shoveString n' cs - in - shoveString 0 s - -writeBlocks :: Handle -> Buffer -> String -> IO () -writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s = - let - shoveString :: Int -> [Char] -> IO () - -- check n == len first, to ensure that shoveString is strict in n. - shoveString n cs | n == len = do - new_buf <- commitBuffer hdl raw len n True{-needs flush-} False - writeBlocks hdl new_buf cs - shoveString n [] = do - commitBuffer hdl raw len n False{-no flush-} True{-release-} - return () - shoveString n (c:cs) = do - n' <- writeCharIntoBuffer raw n c - shoveString n' cs - in - shoveString 0 s +{-| +Ensures that the suspensions under evaluation by the current thread +are unique; that is, the current thread is not evaluating anything +that is also under evaluation by another thread that has also executed +'noDuplicate'. + +This operation is used in the definition of 'unsafePerformIO' to +prevent the IO action from being executed multiple times, which is usually +undesirable. +-} +noDuplicate :: IO () +noDuplicate = IO $ \s -> case noDuplicate# s of s' -> (# s', () #) -- ----------------------------------------------------------------------------- --- commitBuffer handle buf sz count flush release --- --- Write the contents of the buffer 'buf' ('sz' bytes long, containing --- 'count' bytes of data) to handle (handle must be block or line buffered). --- --- Implementation: --- --- for block/line buffering, --- 1. If there isn't room in the handle buffer, flush the handle --- buffer. --- --- 2. If the handle buffer is empty, --- if flush, --- then write buf directly to the device. --- else swap the handle buffer with buf. --- --- 3. If the handle buffer is non-empty, copy buf into the --- handle buffer. Then, if flush != 0, flush --- the buffer. - -commitBuffer - :: Handle -- handle to commit to - -> RawBuffer -> Int -- address and size (in bytes) of buffer - -> Int -- number of bytes of data in buffer - -> Bool -- True <=> flush the handle afterward - -> Bool -- release the buffer? - -> IO Buffer - -commitBuffer hdl raw sz@(I# _) count@(I# _) flush release = do - wantWritableHandle "commitAndReleaseBuffer" hdl $ - commitBuffer' hdl raw sz count flush release - --- Explicitly lambda-lift this function to subvert GHC's full laziness --- optimisations, which otherwise tends to float out subexpressions --- past the \handle, which is really a pessimisation in this case because --- that lambda is a one-shot lambda. --- --- Don't forget to export the function, to stop it being inlined too --- (this appears to be better than NOINLINE, because the strictness --- analyser still gets to worker-wrapper it). --- --- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001 --- -commitBuffer' hdl raw sz@(I# _) count@(I# _) flush release - handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do - -#ifdef DEBUG_DUMP - puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count - ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n") -#endif - - old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size } - <- readIORef ref - - buf_ret <- - -- enough room in handle buffer? - if (not flush && (size - w > count)) - -- The > is to be sure that we never exactly fill - -- up the buffer, which would require a flush. So - -- if copying the new data into the buffer would - -- make the buffer full, we just flush the existing - -- buffer and the new data immediately, rather than - -- copying before flushing. - - -- not flushing, and there's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_baoff_ba old_raw w raw (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return (newEmptyBuffer raw WriteBuffer sz) - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd (haIsStream handle_) old_buf - - let this_buf = - Buffer{ bufBuf=raw, bufState=WriteBuffer, - bufRPtr=0, bufWPtr=count, bufSize=sz } - - -- if: (a) we don't have to flush, and - -- (b) size(new buffer) == size(old buffer), and - -- (c) new buffer is not full, - -- we can just just swap them over... - if (not flush && sz == size && count /= sz) - then do - writeIORef ref this_buf - return flushed_buf - - -- otherwise, we have to flush the new data too, - -- and start with a fresh buffer - else do - flushWriteBuffer fd (haIsStream handle_) this_buf - writeIORef ref flushed_buf - -- if the sizes were different, then allocate - -- a new buffer of the correct size. - if sz == size - then return (newEmptyBuffer raw WriteBuffer sz) - else allocateBuffer size WriteBuffer - - -- release the buffer if necessary - case buf_ret of - Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do - if release && buf_ret_sz == size - then do - spare_bufs <- readIORef spare_buf_ref - writeIORef spare_buf_ref - (BufferListCons buf_ret_raw spare_bufs) - return buf_ret - else - return buf_ret - --- --------------------------------------------------------------------------- --- Reading/writing sequences of bytes. - --- --------------------------------------------------------------------------- --- hPutBuf +-- | File and directory names are values of type 'String', whose precise +-- meaning is operating system dependent. Files can be opened, yielding a +-- handle which can then be used to operate on the contents of that file. --- | 'hPutBuf' @hdl buf count@ writes @count@ 8-bit bytes from the --- buffer @buf@ to the handle @hdl@. It returns (). --- --- This operation may fail with: --- --- * 'ResourceVanished' if the handle is a pipe or socket, and the --- reading end is closed. (If this is a POSIX system, and the program --- has not asked to ignore SIGPIPE, then a SIGPIPE may be delivered --- instead, whose default action is to terminate the program). - -hPutBuf :: Handle -- handle to write to - -> Ptr a -- address of buffer - -> Int -- number of bytes of data in buffer - -> IO () -hPutBuf h ptr count = do hPutBuf' h ptr count True; return () - -hPutBufNonBlocking - :: Handle -- handle to write to - -> Ptr a -- address of buffer - -> Int -- number of bytes of data in buffer - -> IO Int -- returns: number of bytes written -hPutBufNonBlocking h ptr count = hPutBuf' h ptr count False - -hPutBuf':: Handle -- handle to write to - -> Ptr a -- address of buffer - -> Int -- number of bytes of data in buffer - -> Bool -- allow blocking? - -> IO Int -hPutBuf' handle ptr count can_block - | count == 0 = return 0 - | count < 0 = illegalBufferSize handle "hPutBuf" count - | otherwise = - wantWritableHandle "hPutBuf" handle $ - \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> - bufWrite fd ref is_stream ptr count can_block - -bufWrite fd ref is_stream ptr count can_block = - seq count $ seq fd $ do -- strictness hack - old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size } - <- readIORef ref - - -- enough room in handle buffer? - if (size - w > count) - -- There's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_baoff_ptr old_raw w ptr (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return count - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd is_stream old_buf - -- TODO: we should do a non-blocking flush here - writeIORef ref flushed_buf - -- if we can fit in the buffer, then just loop - if count < size - then bufWrite fd ref is_stream ptr count can_block - else if can_block - then do writeChunk fd is_stream (castPtr ptr) count - return count - else writeChunkNonBlocking fd is_stream ptr count - -writeChunk :: FD -> Bool -> Ptr CChar -> Int -> IO () -writeChunk fd is_stream ptr bytes = loop 0 bytes - where - loop :: Int -> Int -> IO () - loop _ bytes | bytes <= 0 = return () - loop off bytes = do - r <- fromIntegral `liftM` - writeRawBufferPtr "writeChunk" (fromIntegral fd) is_stream ptr - off (fromIntegral bytes) - -- write can't return 0 - loop (off + r) (bytes - r) - -writeChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int -writeChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return off - loop off bytes = do -#ifndef mingw32_TARGET_OS - ssize <- c_write (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes) - let r = fromIntegral ssize :: Int - if (r == -1) - then do errno <- getErrno - if (errno == eAGAIN || errno == eWOULDBLOCK) - then return off - else throwErrno "writeChunk" - else loop (off + r) (bytes - r) -#else - (ssize, rc) <- asyncWrite fd (fromIntegral $ fromEnum is_stream) - (fromIntegral bytes) - (ptr `plusPtr` off) - let r = fromIntegral ssize :: Int - if r == (-1) - then ioError (errnoToIOError "hPutBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing) - else loop (off + r) (bytes - r) -#endif +type FilePath = String --- --------------------------------------------------------------------------- --- hGetBuf +-- ----------------------------------------------------------------------------- +-- Primitive catch and throwIO --- | 'hGetBuf' @hdl buf count@ reads data from the handle @hdl@ --- into the buffer @buf@ until either EOF is reached or --- @count@ 8-bit bytes have been read. --- It returns the number of bytes actually read. This may be zero if --- EOF was reached before any data was read (or if @count@ is zero). --- --- 'hGetBuf' never raises an EOF exception, instead it returns a value --- smaller than @count@. --- --- If the handle is a pipe or socket, and the writing end --- is closed, 'hGetBuf' will behave as if EOF was reached. - -hGetBuf :: Handle -> Ptr a -> Int -> IO Int -hGetBuf h ptr count = hGetBuf' h ptr count True - -hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int -hGetBufNonBlocking h ptr count = hGetBuf' h ptr count False - -hGetBuf' :: Handle -> Ptr a -> Int -> Bool -> IO Int -hGetBuf' handle ptr count can_block - | count == 0 = return 0 - | count < 0 = illegalBufferSize handle "hGetBuf" count - | otherwise = - wantReadableHandle "hGetBuf" handle $ - \ handle_@Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - bufRead fd ref is_stream ptr 0 count can_block - -bufRead fd ref is_stream ptr so_far count can_block = - seq fd $ seq so_far $ seq count $ do -- strictness hack - buf@Buffer{ bufBuf=raw, bufWPtr=w, bufRPtr=r, bufSize=sz } <- readIORef ref - if bufferEmpty buf - then if so_far > 0 then return so_far else - if count < sz - then do - mb_buf <- maybeFillReadBuffer fd (not can_block) is_stream buf - case mb_buf of - Nothing -> return 0 - Just new_buf -> do - writeIORef ref new_buf - bufRead fd ref is_stream ptr so_far count can_block - else if can_block - then readChunk fd is_stream ptr count - else readChunkNonBlocking fd is_stream ptr count - else do - let avail = w - r - if (count == avail) - then do - memcpy_ptr_baoff ptr raw r (fromIntegral count) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - return (so_far + count) - else do - if (count < avail) - then do - memcpy_ptr_baoff ptr raw r (fromIntegral count) - writeIORef ref buf{ bufRPtr = r + count } - return (so_far + count) - else do - - memcpy_ptr_baoff ptr raw r (fromIntegral avail) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - - let remaining = count - avail - so_far' = so_far + avail - ptr' = ptr `plusPtr` avail - - if remaining < sz - then bufRead fd ref is_stream ptr' so_far' remaining can_block - else do - - rest <- if can_block - then readChunk fd is_stream ptr' remaining - else readChunkNonBlocking fd is_stream ptr' remaining - return (so_far' + rest) - -readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int -readChunk fd is_stream ptr bytes = loop 0 bytes - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return off - loop off bytes = do - r <- fromIntegral `liftM` - readRawBufferPtr "readChunk" (fromIntegral fd) is_stream - (castPtr ptr) off (fromIntegral bytes) - if r == 0 - then return off - else loop (off + r) (bytes - r) - -readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int -readChunkNonBlocking fd is_stream ptr bytes = loop 0 bytes - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return off - loop off bytes = do -#ifndef mingw32_TARGET_OS - ssize <- c_read (fromIntegral fd) (ptr `plusPtr` off) (fromIntegral bytes) - let r = fromIntegral ssize :: Int - if (r == -1) - then do errno <- getErrno - if (errno == eAGAIN || errno == eWOULDBLOCK) - then return off - else throwErrno "readChunk" - else if (r == 0) - then return off - else loop (off + r) (bytes - r) -#else - (ssize, rc) <- asyncRead fd (fromIntegral $ fromEnum is_stream) - (fromIntegral bytes) - (ptr `plusPtr` off) - let r = fromIntegral ssize :: Int - if r == (-1) - then ioError (errnoToIOError "hGetBufNonBlocking" (Errno (fromIntegral rc)) Nothing Nothing) - else if (r == 0) - then return off - else loop (off + r) (bytes - r) -#endif - -slurpFile :: FilePath -> IO (Ptr (), Int) -slurpFile fname = do - handle <- openFile fname ReadMode - sz <- hFileSize handle - if sz > fromIntegral (maxBound::Int) then - ioError (userError "slurpFile: file too big") - else do - let sz_i = fromIntegral sz - if sz_i == 0 then return (nullPtr, 0) else do - chunk <- mallocBytes sz_i - r <- hGetBuf handle chunk sz_i - hClose handle - return (chunk, r) +{- +catchException used to handle the passing around of the state to the +action and the handler. This turned out to be a bad idea - it meant +that we had to wrap both arguments in thunks so they could be entered +as normal (remember IO returns an unboxed pair...). --- --------------------------------------------------------------------------- --- pipes +Now catch# has type -{-| -(@createPipe@) creates an anonymous /pipe/ and returns a pair of -handles, the first for reading and the second for writing. Both -pipe ends can be inherited by a child process. + catch# :: IO a -> (b -> IO a) -> IO a -> createPipe = createPipeEx (BinaryMode AppendMode) +(well almost; the compiler doesn't know about the IO newtype so we +have to work around that in the definition of catchException below). -} -createPipe :: IO (Handle,Handle) -createPipe = createPipeEx AppendMode -{-| -(@createPipeEx modeEx@) creates an anonymous /pipe/ and returns a pair of -handles, the first for reading and the second for writing. -The pipe mode @modeEx@ can be: - - * @'TextMode' mode@ -- the pipe is opened in text mode. - - * @'BinaryMode' mode@ -- the pipe is opened in binary mode. - -The @mode@ determines if child processes can inherit the pipe handles: - - * 'ReadMode' -- The /read/ handle of the pipe is private to this process. - - * 'WriteMode' -- The /write/ handle of the pipe is private to this process. - - * 'ReadWriteMode' -- Both handles are private to this process. - - * 'AppendMode' -- Both handles are available (inheritable) to child processes. - This mode can be used to /append/ (|) two seperate child processes. - -If a broken pipe is read, an end-of-file ('GHC.IOBase.EOF') -exception is raised. If a broken pipe is written to, an invalid argument exception -is raised ('GHC.IOBase.InvalidArgument'). --} -createPipeEx :: IOMode -> IO (Handle,Handle) -createPipeEx mode = do -#if 1 - return (error "createPipeEx") -#else - -#ifndef mingw32_TARGET_OS - -- ignore modeEx for Unix: just always inherit the descriptors - allocaArray 2 $ \p -> do - throwErrnoIfMinus1 "createPipe" (c_pipe p) - r <- peekElemOff p 0 - hr <- openFd (fromIntegral r) (Just Stream) ("") ReadMode - False{-text mode-} False{-don't truncate-} - w <- peekElemOff p 1 - hw <- openFd (fromIntegral w) (Just Stream) ("") WriteMode - False{-text mode-} False{-don't truncate-} - return (hr,hw) -#else - - alloca $ \pFdRead -> - alloca $ \pFdWrite -> - do{ r <- winCreatePipe (fromIntegral textmode) (fromIntegral inherit) 4096 pFdRead pFdWrite - ; when (r/=0) (ioError (userError ("unable to create pipe"))) - ; fdRead <- do{ fd <- peek pFdRead - ; case mode of - WriteMode -> inheritFd fd -- a child process must be able to read from it - other -> return fd - } - ; fdWrite <- do{ fd <- peek pFdWrite - ; case mode of - ReadMode -> inheritFd fd -- a child process must be able to write to it - other -> return fd - } - ; hRead <- openFd (fromIntegral fd) (Just Stream) - "" ReadMode textmode False - ; hWrite <- openFd (fromIntegral fd) (Just Stream) - "" WriteMode textmode False - ; return (hRead,hWrite) - } - where - (mode,textmode) = case modeEx of - TextMode mode -> (mode,1::Int) - BinaryMode mode -> (mode,0::Int) - - inherit :: Int - inherit = case mode of - ReadMode -> 0 -- not inheritable - WriteMode -> 0 -- not inheritable - ReadWriteMode -> 0 -- not inheritable - AppendMode -> 1 -- both inheritable - -inheritFd :: CInt -> IO CInt -inheritFd fd0 - = do{ fd1 <- c_dup fd0 -- dup() makes a file descriptor inheritable - ; c_close fd0 - ; return fd1 - } -#endif -#endif /* mingw32_TARGET_OS */ +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 -> raiseIO# e --- --------------------------------------------------------------------------- --- memcpy wrappers +catchAny :: IO a -> (forall e . Exception e => e -> IO a) -> IO a +catchAny (IO io) handler = IO $ catch# io handler' + where handler' (SomeException e) = unIO (handler e) -foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ba_baoff :: RawBuffer -> RawBuffer -> Int -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ptr_baoff :: Ptr a -> RawBuffer -> Int -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ba :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ptr :: RawBuffer -> Int -> Ptr a -> CSize -> IO (Ptr ()) +-- | A variant of 'throw' that can only be used within the 'IO' monad. +-- +-- Although 'throwIO' has a type that is an instance of the type of 'throw', the +-- two functions are subtly different: +-- +-- > throw e `seq` x ===> throw e +-- > throwIO e `seq` x ===> x +-- +-- The first example will cause the exception @e@ to be raised, +-- whereas the second one won\'t. In fact, 'throwIO' will only cause +-- an exception to be raised when it is used within the 'IO' monad. +-- The 'throwIO' variant should be used in preference to 'throw' to +-- raise an exception within the 'IO' monad because it guarantees +-- ordering with respect to other 'IO' operations, whereas 'throw' +-- does not. +throwIO :: Exception e => e -> IO a +throwIO e = IO (raiseIO# (toException e)) ------------------------------------------------------------------------------ --- Internal Utils - -illegalBufferSize :: Handle -> String -> Int -> IO a -illegalBufferSize handle fn (sz :: Int) = - ioException (IOError (Just handle) - InvalidArgument fn - ("illegal buffer size " ++ showsPrec 9 sz []) - Nothing) +-- ----------------------------------------------------------------------------- +-- Controlling asynchronous exception delivery + +{-# 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 unblocked again. There\'s +-- no need to worry about re-enabling asynchronous exceptions; that is +-- done automatically on exiting the scope of +-- 'block'. +-- +-- Threads created by 'Control.Concurrent.forkIO' inherit the blocked +-- state from the parent; that is, to start a thread in blocked mode, +-- use @block $ forkIO ...@. This is particularly useful if you need to +-- 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 + +{-# 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 +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 #) + +{-# DEPRECATED blocked "use Control.Exception.getMaskingState instead" #-} +-- | returns True if asynchronous exceptions are blocked in the +-- current thread. +blocked :: IO Bool +blocked = fmap (/= Unmasked) getMaskingState + +onException :: IO a -> IO b -> IO a +onException io what = io `catchException` \e -> do _ <- what + 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 + +bracket + :: IO a -- ^ computation to run first (\"acquire resource\") + -> (a -> IO b) -- ^ computation to run last (\"release resource\") + -> (a -> IO c) -- ^ computation to run in-between + -> IO c -- returns the value from the in-between computation +bracket before after thing = + mask $ \restore -> do + a <- before + r <- restore (thing a) `onException` after a + _ <- after a + return r + +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 = + 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 +-- evaluation with respect to other 'IO' operations; its semantics are +-- given by +-- +-- > evaluate x `seq` y ==> y +-- > evaluate x `catch` f ==> (return $! x) `catch` f +-- > evaluate x >>= f ==> (return $! x) >>= f +-- +-- /Note:/ the first equation implies that @(evaluate x)@ is /not/ the +-- same as @(return $! x)@. A correct definition is +-- +-- > evaluate x = (return $! x) >>= return +-- +evaluate :: a -> IO a +evaluate a = IO $ \s -> let !va = a in (# s, va #) -- NB. see #2273