X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelHandle.lhs;h=22ca0d64c9512fb97075aaa353a4f8261c87b896;hb=a103a9dc0de992716e62c30d7ac81c0bc0dbcdc5;hp=c1ca8b2c219090861f03e3b5eb104be2c6becb77;hpb=bbe9c55569ffa1ea660a02d7349afb4ba659072d;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index c1ca8b2..22ca0d6 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -8,30 +8,50 @@ This module defines Haskell {\em handles} and the basic operations which are supported for them. \begin{code} -{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} -#include "error.h" - +{-# OPTIONS -fcompiling-prelude -fno-implicit-prelude -#include "cbits/stgio.h" #-} +#include "cbits/stgerror.h" +#ifndef __HUGS__ /* Hugs just includes this in PreludeBuiltin so no header needed */ module PrelHandle where +import PrelArr import PrelBase -import PrelArr ( newVar, readVar, writeVar, ByteArray ) +import PrelAddr ( Addr, nullAddr ) +import PrelByteArr ( ByteArray(..), MutableByteArray(..) ) import PrelRead ( Read ) import PrelList ( span ) import PrelIOBase +import PrelException import PrelMaybe ( Maybe(..) ) +import PrelEnum +import PrelNum ( toBig, Integer(..), Num(..) ) +import PrelShow import PrelAddr ( Addr, nullAddr ) -import PrelBounded () -- get at Bounded Int instance. -import PrelNum ( toInteger ) -import Ix +import PrelReal ( toInteger ) +import PrelPack ( packString ) +#ifndef __PARALLEL_HASKELL__ +import PrelWeak ( addForeignFinalizer ) +#endif + +import PrelConc #ifndef __PARALLEL_HASKELL__ -import PrelForeign ( ForeignObj, makeForeignObj, writeForeignObj ) +import PrelForeign ( makeForeignObj ) #endif -import PrelConc -- concurrent only -\end{code} +#endif /* ndef(__HUGS__) */ + +#ifdef __HUGS__ +#define __CONCURRENT_HASKELL__ +#define stToIO id +#endif +#ifndef __PARALLEL_HASKELL__ +#define FILE_OBJECT ForeignObj +#else +#define FILE_OBJECT Addr +#endif +\end{code} %********************************************************* %* * @@ -43,32 +63,107 @@ The @Handle@ and @Handle__@ types are defined in @IOBase@. \begin{code} {-# INLINE newHandle #-} -{-# INLINE readHandle #-} -{-# INLINE writeHandle #-} -newHandle :: Handle__ -> IO Handle -readHandle :: Handle -> IO Handle__ -writeHandle :: Handle -> Handle__ -> IO () - -#if defined(__CONCURRENT_HASKELL__) +newHandle :: Handle__ -> IO Handle -- Use MVars for concurrent Haskell newHandle hc = newMVar hc >>= \ h -> return (Handle h) +\end{code} -readHandle (Handle h) = takeMVar h -writeHandle (Handle h) hc = putMVar h hc +%********************************************************* +%* * +\subsection{@withHandle@ operations} +%* * +%********************************************************* + +In the concurrent world, handles are locked during use. This is done +by wrapping an MVar around the handle which acts as a mutex over +operations on the handle. -#else +To avoid races, we use the following bracketing operations. The idea +is to obtain the lock, do some operation and replace the lock again, +whether the operation succeeded or failed. We also want to handle the +case where the thread receives an exception while processing the IO +operation: in these cases we also want to relinquish the lock. --- Use ordinary MutableVars for non-concurrent Haskell -newHandle hc = stToIO (newVar hc >>= \ h -> - return (Handle h)) +There are three versions of @withHandle@: corresponding to the three +possible combinations of: -readHandle (Handle h) = stToIO (readVar h) -writeHandle (Handle h) hc = stToIO (writeVar h hc) + - the operation may side-effect the handle + - the operation may return a result +If the operation generates an error or an exception is raised, the +orignal handle is always replaced [ this is the case at the moment, +but we might want to revisit this in the future --SDM ]. + +\begin{code} +withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a +{-# INLINE withHandle #-} +withHandle (Handle h) act = do + h_ <- takeMVar h + (h',v) <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) + putMVar h h' + return v + +withHandle_ :: Handle -> (Handle__ -> IO a) -> IO a +{-# INLINE withHandle_ #-} +withHandle_ (Handle h) act = do + h_ <- takeMVar h + v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) + putMVar h h_ + return v + +withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO () +{-# INLINE withHandle__ #-} +withHandle__ (Handle h) act = do + h_ <- takeMVar h + h' <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) + putMVar h h' + return () +\end{code} + +nullFile__ is only used for closed handles, plugging it in as a null +file object reference. + +\begin{code} +nullFile__ :: FILE_OBJECT +nullFile__ = +#ifndef __PARALLEL_HASKELL__ + unsafePerformIO (makeForeignObj nullAddr) +#else + nullAddr #endif + +mkClosedHandle__ :: Handle__ +mkClosedHandle__ = + Handle__ + nullFile__ + ClosedHandle + NoBuffering + "closed file" + +mkErrorHandle__ :: IOError -> Handle__ +mkErrorHandle__ ioe = + Handle__ + nullFile__ + (ErrorHandle ioe) + NoBuffering + "error handle" +\end{code} + +%********************************************************* +%* * +\subsection{Handle Finalizers} +%* * +%********************************************************* + +\begin{code} +foreign import "libHS_cbits" "freeStdFileObject" unsafe + freeStdFileObject :: FILE_OBJECT -> IO () +foreign import "libHS_cbits" "freeFileObject" unsafe + freeFileObject :: FILE_OBJECT -> IO () + \end{code} %********************************************************* @@ -82,45 +177,48 @@ two manage input or output from the Haskell program's standard input or output channel respectively. The third manages output to the standard error channel. These handles are initially open. + \begin{code} stdin, stdout, stderr :: Handle stdout = unsafePerformIO (do - rc <- _ccall_ getLock 1 1 -- ConcHask: SAFE, won't block - case rc of + rc <- getLock (1::Int) (1::Int) -- ConcHask: SAFE, won't block + case (rc::Int) of 0 -> newHandle (mkClosedHandle__) 1 -> do -#ifndef __CONCURRENT_HASKELL__ - fo <- _ccall_ openStdFile 1 1{-flush on close-} 0{-writeable-} -- ConcHask: SAFE, won't block -#else - fo <- _ccall_ openStdFile 1 (1{-flush on close-} + 128{-don't block on I/O-}) - 0{-writeable-} -- ConcHask: SAFE, won't block -#endif + fo <- openStdFile (1::Int) + (0::Int){-writeable-} -- ConcHask: SAFE, won't block #ifndef __PARALLEL_HASKELL__ - fo <- makeForeignObj fo (``&freeStdFileObject''::Addr) + fo <- makeForeignObj fo + addForeignFinalizer fo (freeStdFileObject fo) #endif + +#ifdef __HUGS__ +/* I dont care what the Haskell report says, in an interactive system, + * stdout should be unbuffered by default. + */ + let bm = NoBuffering +#else (bm, bf_size) <- getBMode__ fo mkBuffer__ fo bf_size +#endif newHandle (Handle__ fo WriteHandle bm "stdout") _ -> do ioError <- constructError "stdout" newHandle (mkErrorHandle__ ioError) ) stdin = unsafePerformIO (do - rc <- _ccall_ getLock 0 0 -- ConcHask: SAFE, won't block - case rc of + rc <- getLock (0::Int) (0::Int) -- ConcHask: SAFE, won't block + case (rc::Int) of 0 -> newHandle (mkClosedHandle__) 1 -> do -#ifndef __CONCURRENT_HASKELL__ - fo <- _ccall_ openStdFile 0 0{-don't flush on close -} 1{-readable-} -- ConcHask: SAFE, won't block -#else - fo <- _ccall_ openStdFile 0 (0{-flush on close-} + 128{-don't block on I/O-}) - 1{-readable-} -- ConcHask: SAFE, won't block -#endif + fo <- openStdFile (0::Int) + (1::Int){-readable-} -- ConcHask: SAFE, won't block #ifndef __PARALLEL_HASKELL__ - fo <- makeForeignObj fo (``&freeStdFileObject''::Addr) + fo <- makeForeignObj fo + addForeignFinalizer fo (freeStdFileObject fo) #endif (bm, bf_size) <- getBMode__ fo mkBuffer__ fo bf_size @@ -136,26 +234,24 @@ stdin = unsafePerformIO (do stderr = unsafePerformIO (do - rc <- _ccall_ getLock 2 1 -- ConcHask: SAFE, won't block - case rc of + rc <- getLock (2::Int) (1::Int){-writeable-} -- ConcHask: SAFE, won't block + case (rc::Int) of 0 -> newHandle (mkClosedHandle__) 1 -> do -#ifndef __CONCURRENT_HASKELL__ - fo <- _ccall_ openStdFile 2 1{-flush on close-} 0{-writeable-} -- ConcHask: SAFE, won't block -#else - fo <- _ccall_ openStdFile 2 (1{-flush on close-} + 128{-don't block on I/O-}) - 0{-writeable-} -- ConcHask: SAFE, won't block -#endif + fo <- openStdFile (2::Int) + (0::Int){-writeable-} -- ConcHask: SAFE, won't block #ifndef __PARALLEL_HASKELL__ - fo <- makeForeignObj fo (``&freeStdFileObject''::Addr) + fo <- makeForeignObj fo + addForeignFinalizer fo (freeStdFileObject fo) #endif hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr") - -- when stderr and stdout are both connected to a terminal, ensure - -- that anything buffered on stdout is flushed prior to writing on stderr. - -- + -- when stderr and stdout are both connected to a terminal, ensure + -- that anything buffered on stdout is flushed prior to writing to + -- stderr. hConnectTo stdout hdl return hdl + _ -> do ioError <- constructError "stderr" newHandle (mkErrorHandle__ ioError) ) @@ -182,10 +278,13 @@ openFile fp im = openFileEx fp (TextMode im) openFileEx :: FilePath -> IOModeEx -> IO Handle openFileEx f m = do - fo <- _ccall_ openFile f file_mode binary flush_on_close -- ConcHask: SAFE, won't block + fo <- primOpenFile (packString f) + (file_mode::Int) + (binary::Int) -- ConcHask: SAFE, won't block if fo /= nullAddr then do #ifndef __PARALLEL_HASKELL__ - fo <- makeForeignObj fo ((``&freeFileObject'')::Addr) + fo <- makeForeignObj fo + addForeignFinalizer fo (freeFileObject fo) #endif (bm, bf_size) <- getBMode__ fo mkBuffer__ fo bf_size @@ -195,21 +294,15 @@ openFileEx f m = do where (imo, binary) = case m of - BinaryMode imo -> (imo, 1) - TextMode imo -> (imo, 0) + BinaryMode bmo -> (bmo, 1) + TextMode tmo -> (tmo, 0) -#ifndef __CONCURRENT_HASKELL__ - file_mode = file_mode' -#else - file_mode = file_mode' + 128{-Don't block on I/O-} -#endif - - (flush_on_close, file_mode') = + file_mode = case imo of - AppendMode -> (1, 0) - WriteMode -> (1, 1) - ReadMode -> (0, 2) - ReadWriteMode -> (1, 3) + AppendMode -> 0 + WriteMode -> 1 + ReadMode -> 2 + ReadWriteMode -> 3 htype = case imo of ReadMode -> ReadHandle @@ -245,32 +338,26 @@ implementation is free to impose stricter conditions. \begin{code} hClose :: Handle -> IO () -hClose handle = do - handle_ <- readHandle handle +hClose handle = + withHandle__ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hClose" handle + ErrorHandle theError -> ioError theError + ClosedHandle -> return handle_ _ -> do - rc <- _ccall_ closeFile (haFO__ handle_) 1{-flush if you can-} -- ConcHask: SAFE, won't block + rc <- closeFile (haFO__ handle_) + (1::Int){-flush if you can-} -- ConcHask: SAFE, won't block {- We explicitly close a file object so that we can be told if there were any errors. Note that after @hClose@ has been performed, the ForeignObj embedded in the Handle is still lying around in the heap, so care is taken to avoid closing the file object when the ForeignObj - is finalised. (we overwrite the file ptr in the underlying + is finalized. (we overwrite the file ptr in the underlying FileObject with a NULL as part of closeFile()) -} - if rc == 0 - then - writeHandle handle (handle_{ haType__ = ClosedHandle, - haFO__ = nullFile__ }) - else do - writeHandle handle handle_ - constructErrorAndFail "hClose" + if rc == (0::Int) + then return (handle_{ haType__ = ClosedHandle, + haFO__ = nullFile__ }) + else constructErrorAndFail "hClose" \end{code} @@ -280,7 +367,7 @@ sent to the operating system are flushed as for $flush$. %********************************************************* %* * -\subsection[EOF]{Detecting the End of Input} +\subsection[FileSize]{Detecting the size of a file} %* * %********************************************************* @@ -291,36 +378,44 @@ which can be read from {\em hdl}. \begin{code} hFileSize :: Handle -> IO Integer -hFileSize handle = do - handle_ <- readHandle handle +hFileSize handle = + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hFileSize" handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hFileSize" handle - other -> + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "hFileSize" handle + SemiClosedHandle -> ioe_closedHandle "hFileSize" handle +#ifdef __HUGS__ + _ -> do + mem <- primNewByteArray 8{-sizeof_int64-} + rc <- fileSize_int64 (haFO__ handle_) mem -- ConcHask: SAFE, won't block + if rc == 0 then do + result <- primReadInt64Array mem 0 + return (primInt64ToInteger result) + else + constructErrorAndFail "hFileSize" +#else + _ -> -- HACK! We build a unique MP_INT of the right shape to hold -- a single unsigned word, and we let the C routine -- change the data bits -- - -- For some reason, this fails to typecheck if converted to a do - -- expression --SDM - _casm_ ``%r = 1;'' >>= \(I# hack#) -> - case int2Integer# hack# of - result@(J# _ _ d#) -> do - rc <- _ccall_ fileSize (haFO__ handle_) d# -- ConcHask: SAFE, won't block - writeHandle handle handle_ - if rc == 0 then - return result + case int2Integer# 1# of + (# s, d #) -> do + rc <- fileSize (haFO__ handle_) d -- ConcHask: SAFE, won't block + if rc == (0::Int) then + return (J# s d) else constructErrorAndFail "hFileSize" +#endif \end{code} +%********************************************************* +%* * +\subsection[EOF]{Detecting the End of Input} +%* * +%********************************************************* + + For a readable handle {\em hdl}, @hIsEOF hdl@ returns @True@ if no further input can be taken from @hdl@ or for a physical file, if the current I/O position is equal to the length of @@ -329,10 +424,7 @@ the file. Otherwise, it returns @False@. \begin{code} hIsEOF :: Handle -> IO Bool hIsEOF handle = do - handle_ <- wantReadableHandle "hIsEOF" handle - let fo = haFO__ handle_ - rc <- mayBlock fo (_ccall_ fileEOF fo) -- ConcHask: UNSAFE, may block - writeHandle handle handle_ + rc <- mayBlockRead "hIsEOF" handle fileEOF case rc of 0 -> return False 1 -> return True @@ -380,19 +472,16 @@ hSetBuffering :: Handle -> BufferMode -> IO () hSetBuffering handle mode = case mode of BlockBuffering (Just n) - | n <= 0 -> fail (IOError (Just handle) + | n <= 0 -> ioError + (IOError (Just handle) InvalidArgument "hSetBuffering" ("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified. - _ -> do - handle_ <- readHandle handle + _ -> + withHandle__ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hSetBuffering" handle + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "hSetBuffering" handle _ -> do {- Note: - we flush the old buffer regardless of whether @@ -405,13 +494,12 @@ hSetBuffering handle mode = of semi-closed handles to change [sof 6/98] -} let fo = haFO__ handle_ - rc <- mayBlock fo (_ccall_ setBuffering fo bsize) -- ConcHask: UNSAFE, may block + rc <- mayBlock fo (setBuffering fo bsize) -- ConcHask: UNSAFE, may block if rc == 0 then do - writeHandle handle (handle_{ haBufferMode__ = mode }) + return (handle_{ haBufferMode__ = mode }) else do -- Note: failure to change the buffer size will cause old buffer to be flushed. - writeHandle handle handle_ constructErrorAndFail "hSetBuffering" where bsize :: Int @@ -428,11 +516,10 @@ system. \begin{code} hFlush :: Handle -> IO () -hFlush handle = do - handle_ <- wantWriteableHandle "hFlush" handle +hFlush handle = + wantWriteableHandle "hFlush" handle $ \ handle_ -> do let fo = haFO__ handle_ - rc <- mayBlock fo (_ccall_ flushFile fo) -- ConcHask: UNSAFE, may block - writeHandle handle handle_ + rc <- mayBlock fo (flushFile fo) -- ConcHask: UNSAFE, may block if rc == 0 then return () else @@ -451,7 +538,20 @@ hFlush handle = do data HandlePosn = HandlePosn Handle -- Q: should this be a weak or strong ref. to the handle? - Int + -- [what's the winning argument for it not being strong? --sof] + HandlePosition + +instance Eq HandlePosn where + (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 + + -- HandlePosition is the Haskell equivalent of POSIX' off_t. + -- We represent it as an Integer on the Haskell side, but + -- cheat slightly in that hGetPosn calls upon a C helper + -- that reports the position back via (merely) an Int. +type HandlePosition = Integer + +mkHandlePosn :: Handle -> HandlePosition -> HandlePosn +mkHandlePosn h p = HandlePosn h p data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd deriving (Eq, Ord, Ix, Enum, Read, Show) @@ -464,22 +564,22 @@ to a previously obtained position {\em p}. \begin{code} hGetPosn :: Handle -> IO HandlePosn -hGetPosn handle = do - handle_ <- wantSeekableHandle "hGetPosn" handle - posn <- _ccall_ getFilePosn (haFO__ handle_) -- ConcHask: SAFE, won't block - writeHandle handle handle_ - if posn /= -1 then - return (HandlePosn handle posn) +hGetPosn handle = + wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do + posn <- getFilePosn (haFO__ handle_) -- ConcHask: SAFE, won't block + if posn /= -1 then do + return (mkHandlePosn handle (fromInt posn)) else constructErrorAndFail "hGetPosn" hSetPosn :: HandlePosn -> IO () -hSetPosn (HandlePosn handle posn) = do - handle_ <- wantSeekableHandle "hSetPosn" handle -- not as silly as it looks: the handle may have been closed in the meantime. +hSetPosn (HandlePosn handle i@(S# _)) = hSetPosn (HandlePosn handle (toBig i)) +hSetPosn (HandlePosn handle (J# s# d#)) = + wantSeekableHandle "hSetPosn" handle $ \ handle_ -> do + -- not as silly as it looks: the handle may have been closed in the meantime. let fo = haFO__ handle_ - rc <- mayBlock fo (_ccall_ setFilePosn fo posn) -- ConcHask: UNSAFE, may block - writeHandle handle handle_ - if rc == 0 then + rc <- mayBlock fo (setFilePosn fo (I# s#) d#) -- ConcHask: UNSAFE, may block + if rc == 0 then do return () else constructErrorAndFail "hSetPosn" @@ -487,35 +587,41 @@ hSetPosn (HandlePosn handle posn) = do The action @hSeek hdl mode i@ sets the position of handle @hdl@ depending on @mode@. If @mode@ is -\begin{itemize} -\item[{\bf AbsoluteSeek}] The position of @hdl@ is set to @i@. -\item[{\bf RelativeSeek}] The position of @hdl@ is set to offset @i@ from -the current position. -\item[{\bf SeekFromEnd}] The position of @hdl@ is set to offset @i@ from -the end of the file. -\end{itemize} -Some handles may not be seekable (see @hIsSeekable@), or only support a -subset of the possible positioning operations (e.g. it may only be -possible to seek to the end of a tape, or to a positive offset from -the beginning or current position). + * AbsoluteSeek - The position of @hdl@ is set to @i@. + * RelativeSeek - The position of @hdl@ is set to offset @i@ from + the current position. + * SeekFromEnd - The position of @hdl@ is set to offset @i@ from + the end of the file. + +Some handles may not be seekable (see @hIsSeekable@), or only +support a subset of the possible positioning operations (e.g. it may +only be possible to seek to the end of a tape, or to a positive +offset from the beginning or current position). It is not possible to set a negative I/O position, or for a physical file, an I/O position beyond the current end-of-file. Note: - - when seeking using @SeekFromEnd@, positive offsets (>=0) means seeking - at or past EOF. + - when seeking using @SeekFromEnd@, positive offsets (>=0) means + seeking at or past EOF. - relative seeking on buffered handles can lead to non-obvious results. \begin{code} hSeek :: Handle -> SeekMode -> Integer -> IO () -hSeek handle mode offset@(J# _ s# d#) = do - handle_ <- wantSeekableHandle "hSeek" handle +#ifdef __HUGS__ +hSeek handle mode offset = + wantSeekableHandle "hSeek" handle $ \ handle_ -> do let fo = haFO__ handle_ - rc <- mayBlock fo (_ccall_ seekFile fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block - writeHandle handle handle_ - if rc == 0 then + rc <- mayBlock fo (seekFile fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block +#else +hSeek handle mode i@(S# _) = hSeek handle mode (toBig i) +hSeek handle mode (J# s# d#) = + wantSeekableHandle "hSeek" handle $ \ handle_ -> do + let fo = haFO__ handle_ + rc <- mayBlock fo (seekFile fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block +#endif + if rc == 0 then do return () else constructErrorAndFail "hSeek" @@ -545,35 +651,21 @@ $( Just n )$ for block-buffering of {\em n} bytes. \begin{code} hIsOpen :: Handle -> IO Bool -hIsOpen handle = do - handle_ <- readHandle handle +hIsOpen handle = + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - return False - SemiClosedHandle -> do - writeHandle handle handle_ - return False - _ -> do - writeHandle handle handle_ - return True + ErrorHandle theError -> ioError theError + ClosedHandle -> return False + SemiClosedHandle -> return False + _ -> return True hIsClosed :: Handle -> IO Bool -hIsClosed handle = do - handle_ <- readHandle handle +hIsClosed handle = + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - return True - _ -> do - writeHandle handle handle_ - return False + ErrorHandle theError -> ioError theError + ClosedHandle -> return True + _ -> return False {- not defined, nor exported, but mentioned here for documentation purposes: @@ -586,42 +678,26 @@ hIsClosed handle = do -} hIsReadable :: Handle -> IO Bool -hIsReadable handle = do - handle_ <- readHandle handle +hIsReadable handle = + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hIsReadable" handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hIsReadable" handle - htype -> do - writeHandle handle handle_ - return (isReadable htype) + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "hIsReadable" handle + SemiClosedHandle -> ioe_closedHandle "hIsReadable" handle + htype -> return (isReadable htype) where isReadable ReadHandle = True isReadable ReadWriteHandle = True isReadable _ = False hIsWritable :: Handle -> IO Bool -hIsWritable handle = do - handle_ <- readHandle handle +hIsWritable handle = + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hIsWritable" handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hIsWritable" handle - htype -> do - writeHandle handle handle_ - return (isWritable htype) + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "hIsWritable" handle + SemiClosedHandle -> ioe_closedHandle "hIsWritable" handle + htype -> return (isWritable htype) where isWritable AppendHandle = True isWritable WriteHandle = True @@ -629,13 +705,9 @@ hIsWritable handle = do isWritable _ = False -#ifndef __PARALLEL_HASKELL__ -getBMode__ :: ForeignObj -> IO (BufferMode, Int) -#else -getBMode__ :: Addr -> IO (BufferMode, Int) -#endif +getBMode__ :: FILE_OBJECT -> IO (BufferMode, Int) getBMode__ fo = do - rc <- _ccall_ getBufferMode fo -- ConcHask: SAFE, won't block + rc <- getBufferMode fo -- ConcHask: SAFE, won't block case (rc::Int) of 0 -> return (NoBuffering, 0) -1 -> return (LineBuffering, default_buffer_size) @@ -644,54 +716,38 @@ getBMode__ fo = do n -> return (BlockBuffering (Just n), n) where default_buffer_size :: Int - default_buffer_size = (``BUFSIZ'' - 1) + default_buffer_size = (const_BUFSIZ - 1) \end{code} Querying how a handle buffers its data: \begin{code} hGetBuffering :: Handle -> IO BufferMode -hGetBuffering handle = do - handle_ <- readHandle handle +hGetBuffering handle = + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hGetBuffering" handle - _ -> do + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "hGetBuffering" handle + _ -> {- We're being non-standard here, and allow the buffering of a semi-closed handle to be queried. -- sof 6/98 -} - let v = haBufferMode__ handle_ - writeHandle handle handle_ - return v -- could be stricter.. - + return (haBufferMode__ handle_) -- could be stricter.. \end{code} \begin{code} hIsSeekable :: Handle -> IO Bool -hIsSeekable handle = do - handle_ <- readHandle handle +hIsSeekable handle = + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hIsSeekable" handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hIsSeekable" handle - AppendHandle -> do - writeHandle handle handle_ - return False - other -> do - rc <- _ccall_ seekFileP (haFO__ handle_) -- ConcHask: SAFE, won't block - writeHandle handle handle_ - case rc of + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "hIsSeekable" handle + SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle + AppendHandle -> return False + _ -> do + rc <- seekFileP (haFO__ handle_) -- ConcHask: SAFE, won't block + case (rc::Int) of 0 -> return False 1 -> return True _ -> constructErrorAndFail "hIsSeekable" @@ -709,62 +765,47 @@ of a handles connected to terminals to be reconfigured: \begin{code} hSetEcho :: Handle -> Bool -> IO () -hSetEcho hdl on = do - isT <- hIsTerminalDevice hdl +hSetEcho handle on = do + isT <- hIsTerminalDevice handle if not isT then return () - else do - handle_ <- readHandle hdl + else + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle hdl handle_ - fail ioError - ClosedHandle -> do - writeHandle hdl handle_ - ioe_closedHandle "hSetEcho" hdl - other -> do - rc <- _ccall_ setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block - writeHandle hdl handle_ - if rc /= -1 + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "hSetEcho" handle + _ -> do + rc <- setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block + if rc /= ((-1)::Int) then return () else constructErrorAndFail "hSetEcho" hGetEcho :: Handle -> IO Bool -hGetEcho hdl = do - isT <- hIsTerminalDevice hdl +hGetEcho handle = do + isT <- hIsTerminalDevice handle if not isT then return False - else do - handle_ <- readHandle hdl + else + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle hdl handle_ - fail ioError - ClosedHandle -> do - writeHandle hdl handle_ - ioe_closedHandle "hGetEcho" hdl - other -> do - rc <- _ccall_ getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block - writeHandle hdl handle_ - case rc of + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "hGetEcho" handle + _ -> do + rc <- getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block + case (rc::Int) of 1 -> return True 0 -> return False _ -> constructErrorAndFail "hSetEcho" hIsTerminalDevice :: Handle -> IO Bool -hIsTerminalDevice hdl = do - handle_ <- readHandle hdl - case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle hdl handle_ - fail ioError - ClosedHandle -> do - writeHandle hdl handle_ - ioe_closedHandle "hIsTerminalDevice" hdl - other -> do - rc <- _ccall_ isTerminalDevice (haFO__ handle_) -- ConcHask: SAFE, won't block - writeHandle hdl handle_ - case rc of +hIsTerminalDevice handle = do + withHandle_ handle $ \ handle_ -> do + case haType__ handle_ of + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "hIsTerminalDevice" handle + _ -> do + rc <- isTerminalDevice (haFO__ handle_) -- ConcHask: SAFE, won't block + case (rc::Int) of 1 -> return True 0 -> return False _ -> constructErrorAndFail "hIsTerminalDevice" @@ -778,21 +819,10 @@ hConnectTo :: Handle -> Handle -> IO () hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-} hConnectHdl_ :: Handle -> Handle -> Int -> IO () -hConnectHdl_ hW hR is_tty = do - hW_ <- wantRWHandle "hConnectTo" hW - hR_ <- wantRWHandle "hConnectTo" hR - _ccall_ setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block - writeHandle hR hR_ - writeHandle hW hW_ - -#ifndef __PARALLEL_HASKELL__ -#define FILE_OBJECT ForeignObj -#else -#define FILE_OBJECT Addr -#endif - -flushConnectedHandle :: FILE_OBJECT -> IO () -flushConnectedHandle fo = _ccall_ flushConnectedHandle fo +hConnectHdl_ hW hR is_tty = + wantRWHandle "hConnectTo" hW $ \ hW_ -> + wantRWHandle "hConnectTo" hR $ \ hR_ -> do + setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block \end{code} As an extension, we also allow characters to be pushed back. @@ -802,11 +832,10 @@ pushback. (For unbuffered channels, the (default) push-back limit is \begin{code} hUngetChar :: Handle -> Char -> IO () -hUngetChar handle c = do - handle_ <- wantReadableHandle "hLookAhead" handle - rc <- _ccall_ ungetChar (haFO__ handle_) c -- ConcHask: SAFE, won't block - writeHandle handle handle_ - if rc == (-1) +hUngetChar handle c = + wantReadableHandle "hLookAhead" handle $ \ handle_ -> do + rc <- ungetChar (haFO__ handle_) c -- ConcHask: SAFE, won't block + if rc == ((-1)::Int) then constructErrorAndFail "hUngetChar" else return () @@ -820,57 +849,57 @@ this as an extension: -- in one go, read file into an externally allocated buffer. slurpFile :: FilePath -> IO (Addr, Int) slurpFile fname = do - hdl <- openFile fname ReadMode - sz <- hFileSize hdl + handle <- openFile fname ReadMode + sz <- hFileSize handle if sz > toInteger (maxBound::Int) then - fail (userError "slurpFile: file too big") + ioError (userError "slurpFile: file too big") else do let sz_i = fromInteger sz - chunk <- _ccall_ allocMemory__ (sz_i::Int) + chunk <- allocMemory__ sz_i if chunk == nullAddr then do - hClose hdl + hClose handle constructErrorAndFail "slurpFile" else do - handle_ <- readHandle hdl - let fo = haFO__ handle_ - rc <- mayBlock fo (_ccall_ readChunk fo chunk sz_i) -- ConcHask: UNSAFE, may block. - writeHandle hdl handle_ - hClose hdl - if rc < 0 + rc <- withHandle_ handle ( \ handle_ -> do + let fo = haFO__ handle_ + mayBlock fo (readChunk fo chunk 0 sz_i) -- ConcHask: UNSAFE, may block. + ) + hClose handle + if rc < (0::Int) then constructErrorAndFail "slurpFile" else return (chunk, rc) -hFillBufBA :: Handle -> ByteArray Int -> Int -> IO Int +#ifndef __HUGS__ /* Hugs' Prelude doesn't need this */ +hFillBufBA :: Handle -> MutableByteArray RealWorld a -> Int -> IO Int hFillBufBA handle buf sz - | sz <= 0 = fail (IOError (Just handle) + | sz <= 0 = ioError (IOError (Just handle) InvalidArgument "hFillBufBA" ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified. - | otherwise = do - handle_ <- wantReadableHandle "hFillBufBA" handle - let fo = haFO__ handle_ - rc <- mayBlock fo (_ccall_ readChunk fo buf sz) -- ConcHask: UNSAFE, may block. - writeHandle handle handle_ - if rc >= 0 - then return rc - else constructErrorAndFail "hFillBufBA" + | otherwise = hFillBuf' sz 0 + where + hFillBuf' sz len = do + r <- mayBlockRead "hFillBufBA" handle (\fo -> readChunkBA fo buf len sz) + if r >= sz || r == 0 -- r == 0 indicates EOF + then return (len+r) + else hFillBuf' (sz-r) (len+r) +#endif hFillBuf :: Handle -> Addr -> Int -> IO Int hFillBuf handle buf sz - | sz <= 0 = fail (IOError (Just handle) + | sz <= 0 = ioError (IOError (Just handle) InvalidArgument "hFillBuf" - ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified. - | otherwise = do - handle_ <- wantReadableHandle "hFillBuf" handle - let fo = haFO__ handle_ - rc <- mayBlock fo (_ccall_ readChunk fo buf sz) -- ConcHask: UNSAFE, may block. - writeHandle handle handle_ - if rc >= 0 - then return rc - else constructErrorAndFail "hFillBuf" - + ("illegal buffer size " ++ showsPrec 9 sz [])) + -- 9 => should be parens'ified. + | otherwise = hFillBuf' sz 0 + where + hFillBuf' sz len = do + r <- mayBlockRead "hFillBuf" handle (\fo -> readChunk fo buf len sz) + if r >= sz || r == 0 -- r == 0 indicates EOF + then return (len+r) + else hFillBuf' (sz-r) (len+r) \end{code} The @hPutBuf hdl buf len@ action writes an already packed sequence of @@ -878,24 +907,36 @@ bytes to the file/channel managed by @hdl@ - non-standard. \begin{code} hPutBuf :: Handle -> Addr -> Int -> IO () -hPutBuf handle buf len = do - handle_ <- wantWriteableHandle "hPutBuf" handle - let fo = haFO__ handle_ - rc <- mayBlock fo (_ccall_ writeBuf fo buf len) -- ConcHask: UNSAFE, may block. - writeHandle handle handle_ - if rc == 0 - then return () - else constructErrorAndFail "hPutBuf" - -hPutBufBA :: Handle -> ByteArray Int -> Int -> IO () -hPutBufBA handle buf len = do - handle_ <- wantWriteableHandle "hPutBufBA" handle - let fo = haFO__ handle_ - rc <- mayBlock fo (_ccall_ writeBufBA fo buf len) -- ConcHask: UNSAFE, may block. - writeHandle handle handle_ - if rc == 0 - then return () - else constructErrorAndFail "hPutBuf" +hPutBuf handle buf sz + | sz <= 0 = ioError (IOError (Just handle) + InvalidArgument + "hPutBuf" + ("illegal buffer size " ++ showsPrec 9 sz [])) + -- 9 => should be parens'ified. + | otherwise = hPutBuf' sz 0 + where + hPutBuf' sz len = do + r <- mayBlockWrite "hPutBuf" handle (\fo -> writeBuf fo buf len sz) + if r >= sz + then return () + else hPutBuf' (sz-r) (len+r) -- <= sz indicates blocking + +#ifndef __HUGS__ /* An_ one Hugs doesn't provide */ +hPutBufBA :: Handle -> MutableByteArray RealWorld a -> Int -> IO () +hPutBufBA handle buf sz + | sz <= 0 = ioError (IOError (Just handle) + InvalidArgument + "hPutBufBA" + ("illegal buffer size " ++ showsPrec 9 sz [])) + -- 9 => should be parens'ified. + | otherwise = hPutBuf' sz 0 + where + hPutBuf' sz len = do + r <- mayBlockWrite "hPutBufBA" handle (\fo -> writeBufBA fo buf len sz) + if r >= sz + then return () + else hPutBuf' (sz-r) (len+r) -- <= sz indicates blocking +#endif \end{code} Sometimes it's useful to get at the file descriptor that @@ -903,18 +944,13 @@ the Handle contains.. \begin{code} getHandleFd :: Handle -> IO Int -getHandleFd handle = do - handle_ <- readHandle handle +getHandleFd handle = + withHandle_ handle $ \ handle_ -> do case (haType__ handle_) of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "getHandleFd" handle + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle "getHandleFd" handle _ -> do - fd <- _ccall_ getFileFd (haFO__ handle_) - writeHandle handle handle_ + fd <- getFileFd (haFO__ handle_) return fd \end{code} @@ -942,99 +978,112 @@ ioeGetErrorString (IOError _ iot _ str) = ioeGetFileName (IOError _ _ _ str) = case span (/=':') str of - (fs,[]) -> Nothing + (_,[]) -> Nothing (fs,_) -> Just fs \end{code} +'Top-level' IO actions want to catch exceptions (e.g., forkIO and +PrelMain.mainIO) and report them - topHandler is the exception +handler they should use for this: + +\begin{code} +-- make sure we handle errors while reporting the error! +-- (e.g. evaluating the string passed to 'error' might generate +-- another error, etc.) +topHandler :: Bool -> Exception -> IO () +topHandler bombOut err = catchException (real_handler bombOut err) (topHandler bombOut) + +real_handler :: Bool -> Exception -> IO () +real_handler bombOut ex = + case ex of + AsyncException StackOverflow -> reportStackOverflow bombOut + ErrorCall s -> reportError bombOut s + other -> reportError bombOut (showsPrec 0 other "\n") + +reportStackOverflow :: Bool -> IO () +reportStackOverflow bombOut = do + (hFlush stdout) `catchException` (\ _ -> return ()) + callStackOverflowHook + if bombOut then + stg_exit 2 + else + return () + +reportError :: Bool -> String -> IO () +reportError bombOut str = do + (hFlush stdout) `catchException` (\ _ -> return ()) + let bs@(ByteArray _ len _) = packString str + writeErrString addrOf_ErrorHdrHook bs len + if bombOut then + stg_exit 1 + else + return () + +foreign label "ErrorHdrHook" + addrOf_ErrorHdrHook :: Addr + +foreign import ccall "writeErrString__" unsafe + writeErrString :: Addr -> ByteArray Int -> Int -> IO () + +foreign import ccall "stackOverflow" + callStackOverflowHook :: IO () + +foreign import ccall "stg_exit" + stg_exit :: Int -> IO () +\end{code} + + A number of operations want to get at a readable or writeable handle, and fail if it isn't: \begin{code} -wantReadableHandle :: String -> Handle -> IO Handle__ -wantReadableHandle fun handle = do - handle_ <- readHandle handle +wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantReadableHandle fun handle act = + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - AppendHandle -> do - writeHandle handle handle_ - fail not_readable_error - WriteHandle -> do - writeHandle handle handle_ - fail not_readable_error - other -> return handle_ + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle fun handle + SemiClosedHandle -> ioe_closedHandle fun handle + AppendHandle -> ioError not_readable_error + WriteHandle -> ioError not_readable_error + _ -> act handle_ where not_readable_error = IOError (Just handle) IllegalOperation fun ("handle is not open for reading") -wantWriteableHandle :: String -> Handle -> IO Handle__ -wantWriteableHandle fun handle = do - handle_ <- readHandle handle +wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantWriteableHandle fun handle act = + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - ReadHandle -> do - writeHandle handle handle_ - fail not_writeable_error - other -> return handle_ + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle fun handle + SemiClosedHandle -> ioe_closedHandle fun handle + ReadHandle -> ioError not_writeable_error + _ -> act handle_ where not_writeable_error = IOError (Just handle) IllegalOperation fun ("handle is not open for writing") --- either R or W. -wantRWHandle :: String -> Handle -> IO Handle__ -wantRWHandle fun handle = do - handle_ <- readHandle handle +wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantRWHandle fun handle act = + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - other -> return handle_ - where - not_readable_error = - IOError (Just handle) IllegalOperation fun - ("handle is not open for reading or writing") - -wantSeekableHandle :: String -> Handle -> IO Handle__ -wantSeekableHandle fun handle = do - handle_ <- readHandle handle + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle fun handle + SemiClosedHandle -> ioe_closedHandle fun handle + _ -> act handle_ + +wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a +wantSeekableHandle fun handle act = + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle ioError -> do - writeHandle handle handle_ - fail ioError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - AppendHandle -> do - writeHandle handle handle_ - fail not_seekable_error - _ -> return handle_ + ErrorHandle theError -> ioError theError + ClosedHandle -> ioe_closedHandle fun handle + SemiClosedHandle -> ioe_closedHandle fun handle + _ -> act handle_ where not_seekable_error = IOError (Just handle) @@ -1048,46 +1097,200 @@ access to a closed file. \begin{code} ioe_closedHandle :: String -> Handle -> IO a -ioe_closedHandle fun h = fail (IOError (Just h) IllegalOperation fun "handle is closed") +ioe_closedHandle fun h = ioError (IOError (Just h) IllegalOperation fun "handle is closed") \end{code} Internal helper functions for Concurrent Haskell implementation of IO: \begin{code} -#ifndef __PARALLEL_HASKELL__ -mayBlock :: ForeignObj -> IO Int -> IO Int -#else -mayBlock :: Addr -> IO Int -> IO Int -#endif - -#ifndef __CONCURRENT_HASKELL__ -mayBlock _ act = act -#else +mayBlock :: FILE_OBJECT -> IO Int -> IO Int mayBlock fo act = do rc <- act case rc of -5 -> do -- (possibly blocking) read - fd <- _ccall_ getFileFd fo + fd <- getFileFd fo threadWaitRead fd - _ccall_ clearNonBlockingIOFlag__ fo -- force read to happen this time. mayBlock fo act -- input available, re-try -6 -> do -- (possibly blocking) write - fd <- _ccall_ getFileFd fo + fd <- getFileFd fo threadWaitWrite fd - _ccall_ clearNonBlockingIOFlag__ fo -- force write to happen this time. mayBlock fo act -- output possible -7 -> do -- (possibly blocking) write on connected handle - fd <- _ccall_ getConnFileFd fo + fd <- getConnFileFd fo threadWaitWrite fd - _ccall_ clearConnNonBlockingIOFlag__ fo -- force write to happen this time. mayBlock fo act -- output possible _ -> do - _ccall_ setNonBlockingIOFlag__ fo -- reset file object. - _ccall_ setConnNonBlockingIOFlag__ fo -- reset (connected) file object. return rc +data MayBlock + = BlockRead Int + | BlockWrite Int + | NoBlock Int + +mayBlockRead :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int +mayBlockRead fname handle fn = do + r <- wantReadableHandle fname handle $ \ handle_ -> do + let fo = haFO__ handle_ + rc <- fn fo + case rc of + -5 -> do -- (possibly blocking) read + fd <- getFileFd fo + return (BlockRead fd) + -6 -> do -- (possibly blocking) write + fd <- getFileFd fo + return (BlockWrite fd) + -7 -> do -- (possibly blocking) write on connected handle + fd <- getConnFileFd fo + return (BlockWrite fd) + _ -> + if rc >= 0 + then return (NoBlock rc) + else constructErrorAndFail fname + case r of + BlockRead fd -> do + threadWaitRead fd + mayBlockRead fname handle fn + BlockWrite fd -> do + threadWaitWrite fd + mayBlockRead fname handle fn + NoBlock c -> return c + +mayBlockWrite :: String -> Handle -> (FILE_OBJECT -> IO Int) -> IO Int +mayBlockWrite fname handle fn = do + r <- wantWriteableHandle fname handle $ \ handle_ -> do + let fo = haFO__ handle_ + rc <- fn fo + case rc of + -5 -> do -- (possibly blocking) read + fd <- getFileFd fo + return (BlockRead fd) + -6 -> do -- (possibly blocking) write + fd <- getFileFd fo + return (BlockWrite fd) + -7 -> do -- (possibly blocking) write on connected handle + fd <- getConnFileFd fo + return (BlockWrite fd) + _ -> + if rc >= 0 + then return (NoBlock rc) + else constructErrorAndFail fname + case r of + BlockRead fd -> do + threadWaitRead fd + mayBlockWrite fname handle fn + BlockWrite fd -> do + threadWaitWrite fd + mayBlockWrite fname handle fn + NoBlock c -> return c +\end{code} + +Foreign import declarations of helper functions: + +\begin{code} + +#ifdef __HUGS__ +type Bytes = PrimByteArray RealWorld +#else +type Bytes = ByteArray# +#endif + +foreign import "libHS_cbits" "inputReady" unsafe + inputReady :: FILE_OBJECT -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "fileGetc" unsafe + fileGetc :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "fileLookAhead" unsafe + fileLookAhead :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "readBlock" unsafe + readBlock :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "readLine" unsafe + readLine :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "readChar" unsafe + readChar :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "writeFileObject" unsafe + writeFileObject :: FILE_OBJECT -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "filePutc" unsafe + filePutc :: FILE_OBJECT -> Char -> IO Int{-ret code-} +foreign import "libHS_cbits" "getBufStart" unsafe + getBufStart :: FILE_OBJECT -> Int -> IO Addr +foreign import "libHS_cbits" "getWriteableBuf" unsafe + getWriteableBuf :: FILE_OBJECT -> IO Addr +foreign import "libHS_cbits" "getBufWPtr" unsafe + getBufWPtr :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "setBufWPtr" unsafe + setBufWPtr :: FILE_OBJECT -> Int -> IO () +foreign import "libHS_cbits" "closeFile" unsafe + closeFile :: FILE_OBJECT -> Int{-Flush-} -> IO Int{-ret code-} +foreign import "libHS_cbits" "fileEOF" unsafe + fileEOF :: FILE_OBJECT -> IO Int{-ret code-} +foreign import "libHS_cbits" "setBuffering" unsafe + setBuffering :: FILE_OBJECT -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "flushFile" unsafe + flushFile :: FILE_OBJECT -> IO Int{-ret code-} +foreign import "libHS_cbits" "flushConnectedBuf" unsafe + flushConnectedBuf :: FILE_OBJECT -> IO () +foreign import "libHS_cbits" "getBufferMode" unsafe + getBufferMode :: FILE_OBJECT -> IO Int{-ret code-} +#ifdef __HUGS__ +foreign import "libHS_cbits" "seekFile_int64" unsafe + seekFile :: FILE_OBJECT -> Int -> Int64 -> IO Int +#else +foreign import "libHS_cbits" "seekFile" unsafe + seekFile :: FILE_OBJECT -> Int -> Int -> Bytes -> IO Int +#endif + +foreign import "libHS_cbits" "seekFileP" unsafe + seekFileP :: FILE_OBJECT -> IO Int{-ret code-} +foreign import "libHS_cbits" "setTerminalEcho" unsafe + setTerminalEcho :: FILE_OBJECT -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "getTerminalEcho" unsafe + getTerminalEcho :: FILE_OBJECT -> IO Int{-ret code-} +foreign import "libHS_cbits" "isTerminalDevice" unsafe + isTerminalDevice :: FILE_OBJECT -> IO Int{-ret code-} +foreign import "libHS_cbits" "setConnectedTo" unsafe + setConnectedTo :: FILE_OBJECT -> FILE_OBJECT -> Int -> IO () +foreign import "libHS_cbits" "ungetChar" unsafe + ungetChar :: FILE_OBJECT -> Char -> IO Int{-ret code-} +foreign import "libHS_cbits" "readChunk" unsafe + readChunk :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "readChunk" unsafe + readChunkBA :: FILE_OBJECT -> MutableByteArray s a -> Int -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "writeBuf" unsafe + writeBuf :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-} +#ifndef __HUGS__ +foreign import "libHS_cbits" "writeBufBA" unsafe + writeBufBA :: FILE_OBJECT -> MutableByteArray s a -> Int -> Int -> IO Int{-ret code-} +#endif +foreign import "libHS_cbits" "getFileFd" unsafe + getFileFd :: FILE_OBJECT -> IO Int{-fd-} +#ifdef __HUGS__ +foreign import "libHS_cbits" "fileSize_int64" unsafe + fileSize_int64 :: FILE_OBJECT -> Bytes -> IO Int{-ret code-} +#else +foreign import "libHS_cbits" "fileSize" unsafe + fileSize :: FILE_OBJECT -> Bytes -> IO Int{-ret code-} #endif + +foreign import "libHS_cbits" "getFilePosn" unsafe + getFilePosn :: FILE_OBJECT -> IO Int +foreign import "libHS_cbits" "setFilePosn" unsafe + setFilePosn :: FILE_OBJECT -> Int -> ByteArray# -> IO Int +foreign import "libHS_cbits" "getConnFileFd" unsafe + getConnFileFd :: FILE_OBJECT -> IO Int{-fd-} +foreign import "libHS_cbits" "getLock" unsafe + getLock :: Int{-Fd-} -> Int{-exclusive-} -> IO Int{-return code-} +foreign import "libHS_cbits" "openStdFile" unsafe + openStdFile :: Int{-fd-} -> Int{-Readable?-} -> IO Addr{-file obj-} +foreign import "libHS_cbits" "openFile" unsafe + primOpenFile :: ByteArray Int{-CString-} + -> Int{-How-} + -> Int{-Binary-} + -> IO Addr {-file obj-} +foreign import "libHS_cbits" "const_BUFSIZ" unsafe + const_BUFSIZ :: Int + +foreign import "libHS_cbits" "setBinaryMode__" + setBinaryMode :: FILE_OBJECT -> Int -> IO Int \end{code}