X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=GHC%2FIO.hs;h=fef57dafda62854795263f72365292fe9c6b257e;hb=d2063b5b0be014545b21819172c87756efcb0b0c;hp=231244bc9b390ecbb5a4a4365332d1b7fabfe513;hpb=f473a3b8817dce18cfb0c43c15795cdf559c6b7e;p=ghc-base.git diff --git a/GHC/IO.hs b/GHC/IO.hs index 231244b..fef57da 100644 --- a/GHC/IO.hs +++ b/GHC/IO.hs @@ -1,974 +1,387 @@ -{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-} +{-# OPTIONS_GHC -fno-implicit-prelude -funbox-strict-fields #-} {-# OPTIONS_HADDOCK hide #-} - -#undef DEBUG_DUMP - ----------------------------------------------------------------------------- -- | -- 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. -- ----------------------------------------------------------------------------- -- #hide -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, - memcpy_ba_baoff, - memcpy_ptr_baoff, - memcpy_baoff_ba, - memcpy_baoff_ptr, - ) where - -import Foreign -import Foreign.C - -import System.IO.Error -import Data.Maybe -import Control.Monad -#ifndef mingw32_HOST_OS -import System.Posix.Internals -#endif +module GHC.IO ( + IO(..), unIO, failIO, liftIO, bindIO, thenIO, returnIO, + unsafePerformIO, unsafeInterleaveIO, + unsafeDupablePerformIO, unsafeDupableInterleaveIO, + noDuplicate, + + -- To and from from ST + stToIO, ioToST, unsafeIOToST, unsafeSTToIO, + + FilePath, + + catchException, catchAny, throwIO, + block, unblock, blocked, + onException, 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.Show -import GHC.List +import GHC.ST +import GHC.Exception +import Data.Maybe -#ifdef mingw32_HOST_OS -import GHC.Conc -#endif +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. --- --- If @t@ is less than zero, then @hWaitForInput@ waits indefinitely. --- --- This operation may fail with: --- --- * 'isEOFError' if the end of file has been reached. --- --- NOTE for GHC users: unless you use the @-threaded@ flag, --- @hWaitForInput t@ where @t >= 0@ will block all other Haskell --- threads for the duration of the call. It behaves like a --- @safe@ foreign call in this respect. - -hWaitForInput :: Handle -> Int -> IO Bool -hWaitForInput h msecs = do - wantReadableHandle "hWaitForInput" h $ \ handle_ -> do - let ref = haBuffer handle_ - buf <- readIORef ref - - if not (bufferEmpty buf) - then return True - else do - - if msecs < 0 - then do buf' <- fillReadBuffer (haFD handle_) True - (haIsStream handle_) buf - writeIORef ref buf' - return True - else do r <- throwErrnoIfMinus1Retry "hWaitForInput" $ - fdReady (haFD handle_) 0 {- read -} - (fromIntegral msecs) - (fromIntegral $ fromEnum $ haIsStream handle_) - if r /= 0 then do -- Call hLookAhead' to throw an EOF - -- exception if appropriate - hLookAhead' handle_ - return True - else return False - -foreign import ccall safe "fdReady" - fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt +NOTE: The IO representation is deeply wired in to various parts of the +system. The following list may or may not be exhaustive: --- --------------------------------------------------------------------------- --- hGetChar +Compiler - types of various primitives in PrimOp.lhs --- | 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" fd (haIsStream handle_) raw 0 1 - if r == 0 - then ioe_EOF - else do (c,_) <- readCharFromBuffer raw 0 - return c - -hGetcBuffered :: FD -> IORef Buffer -> Buffer -> IO Char -hGetcBuffered _ ref buf@Buffer{ bufBuf=b, bufRPtr=r0, bufWPtr=w } - = do (c, r) <- readCharFromBuffer b r0 - let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 } - | otherwise = buf{ bufRPtr=r } - writeIORef ref new_buf - return c +RTS - forceIO (StgMiscClosures.hc) + - catchzh_fast, (un)?blockAsyncExceptionszh_fast, raisezh_fast + (Exceptions.hc) + - raiseAsync (Schedule.c) --- --------------------------------------------------------------------------- --- hGetLine +Prelude - GHC.IO.lhs, and several other places including + GHC.Exception.lhs. --- ToDo: the unbuffered case is wrong: it doesn't lock the handle for --- the duration. +Libraries - parts of hslibs/lang. --- | 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__ -> IO String -hGetLineBuffered handle_ = do - let ref = haBuffer handle_ - buf <- readIORef ref - hGetLineBufferedLoop handle_ ref buf [] - -hGetLineBufferedLoop :: Handle__ -> IORef Buffer -> Buffer -> [String] - -> IO String -hGetLineBufferedLoop handle_ ref - buf@Buffer{ bufRPtr=r0, bufWPtr=w, bufBuf=raw0 } 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 raw0 r0 - -#ifdef DEBUG_DUMP - puts ("hGetLineBufferedLoop: r=" ++ show r0 ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n") -#endif - - xs <- unpack raw0 r0 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 -> Bool -> Bool -> Buffer -> IO (Maybe Buffer) -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 _ _ 0 = return "" -unpack buf (I# r) (I# len) = IO $ \s -> unpackRB [] (len -# 1#) s - where - unpackRB acc i s - | i <# r = (# s, acc #) - | otherwise = - case readCharArray# buf i s of - (# s', ch #) -> unpackRB (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) +--SDM +-} --- ----------------------------------------------------------------------------- --- hGetContents +{-| +A value of type @'IO' a@ is a computation which, when performed, +does some I\/O before returning a value of type @a@. --- hGetContents on a DuplexHandle only affects the read side: you can --- carry on writing to it afterwards. +There is really only one way to \"perform\" an I\/O action: bind it to +@Main.main@ in your program. When your program is run, the I\/O will +be performed. It isn't possible to perform I\/O from an arbitrary +function, unless that function is itself in the 'IO' monad and called +at some point, directly or indirectly, from @Main.main@. --- | 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@. --- --- 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 Nothing) - -lazyRead' :: Handle -> Handle__ -> IO (Handle__, [Char]) -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" 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 :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer - -> IO (Handle__, [Char]) -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. - (\_ -> do (handle_', _) <- hClose_help handle_ - return (handle_', "") - ) - -lazyReadHaveBuffer :: Handle -> Handle__ -> FD -> IORef Buffer -> Buffer -> IO (Handle__, [Char]) -lazyReadHaveBuffer h handle_ _ 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 _ _ 0 acc = return acc -unpackAcc buf (I# r) (I# len) acc0 = IO $ \s -> unpackRB acc0 (len -# 1#) s - where - unpackRB acc i s - | i <# r = (# s, acc #) - | otherwise = - case readCharArray# buf i s of - (# s', ch #) -> unpackRB (C# ch : acc) (i -# 1#) s' +'IO' is a monad, so 'IO' actions can be combined using either the do-notation +or the '>>' and '>>=' operations from the 'Monad' class. +-} +newtype IO a = IO (State# RealWorld -> (# State# RealWorld, a #)) + +unIO :: IO a -> (State# RealWorld -> (# State# RealWorld, a #)) +unIO (IO a) = a + +instance Functor IO where + fmap f x = x >>= (return . f) + +instance Monad IO where + {-# INLINE return #-} + {-# INLINE (>>) #-} + {-# INLINE (>>=) #-} + m >> k = m >>= \ _ -> k + return x = returnIO x + + m >>= k = bindIO m k + fail s = failIO s + +liftIO :: IO a -> State# RealWorld -> STret RealWorld a +liftIO (IO m) = \s -> case m s of (# s', r #) -> STret s' r + +bindIO :: IO a -> (a -> IO b) -> IO b +bindIO (IO m) k = IO ( \ s -> + case m s of + (# new_s, a #) -> unIO (k a) new_s + ) + +thenIO :: IO a -> IO b -> IO b +thenIO (IO m) k = IO ( \ s -> + case m s of + (# new_s, _ #) -> unIO k new_s + ) + +returnIO :: a -> IO a +returnIO x = IO (\ s -> (# s, x #)) + +failIO :: String -> IO a +failIO s = IO (raiseIO# (toException (userError s))) -- --------------------------------------------------------------------------- --- hPutChar +-- Coercions between IO and ST --- | 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 +-- | 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 + +ioToST :: IO a -> ST RealWorld a +ioToST (IO m) = (ST m) + +-- This relies on IO and ST having the same representation modulo the +-- constraint on the type of the state -- --- * 'isPermissionError' if another system resource limit would be exceeded. - -hPutChar :: Handle -> Char -> IO () -hPutChar handle c = do - c `seq` return () - wantWritableHandle "hPutChar" handle $ \ handle_ -> do - let fd = haFD handle_ - case haBufferMode handle_ of - LineBuffering -> hPutcBuffered handle_ True c - BlockBuffering _ -> hPutcBuffered handle_ False c - NoBuffering -> - with (castCharToCChar c) $ \buf -> do - writeRawBufferPtr "hPutChar" fd (haIsStream handle_) buf 0 1 - return () - -hPutcBuffered :: Handle__ -> Bool -> Char -> IO () -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 _ [] = return () -hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs +unsafeIOToST :: IO a -> ST s a +unsafeIOToST (IO io) = ST $ \ s -> (unsafeCoerce# io) s + +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. You have to be careful when +writing and compiling modules that use 'unsafePerformIO': + + * 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, 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) + +{-| +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 #)) + +{-| +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', () #) --- 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. +-- ----------------------------------------------------------------------------- +-- | 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. --- | 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 +type FilePath = String -- ----------------------------------------------------------------------------- --- 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' 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' :: RawBuffer -> Int -> Int -> Bool -> Bool -> Handle__ - -> IO Buffer -commitBuffer' 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, 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 (fromIntegral 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 +-- Primitive catch and throwIO --- --------------------------------------------------------------------------- --- Reading/writing sequences of bytes. +{- +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...). --- --------------------------------------------------------------------------- --- hPutBuf +Now catch# has type --- | '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__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> - bufWrite fd ref is_stream ptr count can_block - -bufWrite :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Bool -> IO Int -bufWrite fd ref is_stream ptr count can_block = - seq count $ seq fd $ do -- strictness hack - old_buf@Buffer{ bufBuf=old_raw, 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 (fromIntegral 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 bytes0 = loop 0 bytes0 - where - loop :: Int -> Int -> IO () - loop _ bytes | bytes <= 0 = return () - loop off bytes = do - r <- fromIntegral `liftM` - writeRawBufferPtr "writeChunk" 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 -#ifndef mingw32_HOST_OS - _ -#else - is_stream -#endif - ptr bytes0 = loop 0 bytes0 - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return off - loop off bytes = do -#ifndef mingw32_HOST_OS - ssize <- c_write 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 (fromIntegral 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 + catch# :: IO a -> (b -> IO a) -> IO a --- --------------------------------------------------------------------------- --- hGetBuf +(well almost; the compiler doesn't know about the IO newtype so we +have to work around that in the definition of catchException below). +-} --- | '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 - | count == 0 = return 0 - | count < 0 = illegalBufferSize h "hGetBuf" count - | otherwise = - wantReadableHandle "hGetBuf" h $ - \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - bufRead fd ref is_stream ptr 0 count - --- small reads go through the buffer, large reads are satisfied by --- taking data first from the buffer and then direct from the file --- descriptor. -bufRead :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int -> IO Int -bufRead fd ref is_stream ptr so_far count = - 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 count > sz -- small read? - then do rest <- readChunk fd is_stream ptr count - return (so_far + rest) - else do mb_buf <- maybeFillReadBuffer fd True is_stream buf - case mb_buf of - Nothing -> return so_far -- got nothing, we're done - Just buf' -> do - writeIORef ref buf' - bufRead fd ref is_stream ptr so_far count - else do - let avail = w - r - if (count == avail) - then do - memcpy_ptr_baoff ptr raw (fromIntegral 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 (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufRPtr = r + count } - return (so_far + count) - else do - - memcpy_ptr_baoff ptr raw (fromIntegral 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 - else do - - rest <- readChunk fd is_stream ptr' remaining - return (so_far' + rest) - -readChunk :: FD -> Bool -> Ptr a -> Int -> IO Int -readChunk fd is_stream ptr bytes0 = loop 0 bytes0 - where - loop :: Int -> Int -> IO Int - loop off bytes | bytes <= 0 = return off - loop off bytes = do - r <- fromIntegral `liftM` - readRawBufferPtr "readChunk" fd is_stream - (castPtr ptr) off (fromIntegral bytes) - if r == 0 - then return off - else loop (off + r) (bytes - r) - - --- | 'hGetBufNonBlocking' @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, or there is no more data available --- to read immediately. +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 + +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) + +-- | A variant of 'throw' that can only be used within the 'IO' monad. -- --- 'hGetBufNonBlocking' is identical to 'hGetBuf', except that it will --- never block waiting for data to become available, instead it returns --- only whatever data is available. To wait for data to arrive before --- calling 'hGetBufNonBlocking', use 'hWaitForInput'. +-- Although 'throwIO' has a type that is an instance of the type of 'throw', the +-- two functions are subtly different: -- --- If the handle is a pipe or socket, and the writing end --- is closed, 'hGetBufNonBlocking' will behave as if EOF was reached. +-- > throw e `seq` x ===> throw e +-- > throwIO e `seq` x ===> x -- -hGetBufNonBlocking :: Handle -> Ptr a -> Int -> IO Int -hGetBufNonBlocking h ptr count - | count == 0 = return 0 - | count < 0 = illegalBufferSize h "hGetBufNonBlocking" count - | otherwise = - wantReadableHandle "hGetBufNonBlocking" h $ - \ Handle__{ haFD=fd, haBuffer=ref, haIsStream=is_stream } -> do - bufReadNonBlocking fd ref is_stream ptr 0 count - -bufReadNonBlocking :: FD -> IORef Buffer -> Bool -> Ptr a -> Int -> Int - -> IO Int -bufReadNonBlocking fd ref is_stream ptr so_far count = - 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 count > sz -- large read? - then do rest <- readChunkNonBlocking fd is_stream ptr count - return (so_far + rest) - else do buf' <- fillReadBufferWithoutBlocking fd is_stream buf - case buf' of { Buffer{ bufWPtr=w' } -> - if (w' == 0) - then return so_far - else do writeIORef ref buf' - bufReadNonBlocking fd ref is_stream ptr - so_far (min count w') - -- NOTE: new count is min count w' - -- so we will just copy the contents of the - -- buffer in the recursive call, and not - -- loop again. - } - else do - let avail = w - r - if (count == avail) - then do - memcpy_ptr_baoff ptr raw (fromIntegral 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 (fromIntegral r) (fromIntegral count) - writeIORef ref buf{ bufRPtr = r + count } - return (so_far + count) - else do - - memcpy_ptr_baoff ptr raw (fromIntegral r) (fromIntegral avail) - writeIORef ref buf{ bufWPtr=0, bufRPtr=0 } - let remaining = count - avail - so_far' = so_far + avail - ptr' = ptr `plusPtr` avail - - -- we haven't attempted to read anything yet if we get to here. - if remaining < sz - then bufReadNonBlocking fd ref is_stream ptr' so_far' remaining - else do - - rest <- readChunkNonBlocking fd is_stream ptr' remaining - return (so_far' + rest) - - -readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int -readChunkNonBlocking fd is_stream ptr bytes = do - fromIntegral `liftM` - readRawBufferPtrNoBlock "readChunkNonBlocking" fd is_stream - (castPtr ptr) 0 (fromIntegral bytes) - - -- we don't have non-blocking read support on Windows, so just invoke - -- the ordinary low-level read which will block until data is available, - -- but won't wait for the whole buffer to fill. - -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) - --- --------------------------------------------------------------------------- --- memcpy wrappers - -foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ba_baoff :: RawBuffer -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_src_off" - memcpy_ptr_baoff :: Ptr a -> RawBuffer -> CInt -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ba :: RawBuffer -> CInt -> RawBuffer -> CSize -> IO (Ptr ()) -foreign import ccall unsafe "__hscore_memcpy_dst_off" - memcpy_baoff_ptr :: RawBuffer -> CInt -> Ptr a -> CSize -> IO (Ptr ()) +-- 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 = - ioException (IOError (Just handle) - InvalidArgument fn - ("illegal buffer size " ++ showsPrec 9 sz []) - Nothing Nothing) +-- ----------------------------------------------------------------------------- +-- Controlling asynchronous exception delivery + +-- | 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 +-- 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 + +-- | 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 + +-- | 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# #) + +onException :: IO a -> IO b -> IO a +onException io what = io `catchException` \e -> do what + throw (e :: SomeException) + +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 + 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 -> 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