X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Flib%2Fstd%2FPrelHandle.lhs;h=401870d252aeaf12875f9fed7cd981114aab9772;hb=62cfe85aeb765dc11503b26daadf42de54298850;hp=caa8c50886f89d89e5c3bbf5836f0e86f1d91f9e;hpb=4864e32ad1c683c7fc569d6aa5f2c605076abdbe;p=ghc-hetmet.git diff --git a/ghc/lib/std/PrelHandle.lhs b/ghc/lib/std/PrelHandle.lhs index caa8c50..401870d 100644 --- a/ghc/lib/std/PrelHandle.lhs +++ b/ghc/lib/std/PrelHandle.lhs @@ -1,5 +1,7 @@ - -% (c) The AQUA Project, Glasgow University, 1994-1996 +% ------------------------------------------------------------------------------ +% $Id: PrelHandle.lhs,v 1.67 2001/02/22 13:17:58 simonpj Exp $ +% +% (c) The AQUA Project, Glasgow University, 1994-2000 % \section[PrelHandle]{Module @PrelHandle@} @@ -9,51 +11,59 @@ which are supported for them. \begin{code} {-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-} -#include "cbits/error.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 PrelPtr +import PrelByteArr ( ByteArray(..) ) import PrelRead ( Read ) -import PrelList ( span ) +import PrelList ( break ) import PrelIOBase -import PrelException ( throw, ioError, catchException ) import PrelMaybe ( Maybe(..) ) -import PrelAddr ( Addr, nullAddr ) -import PrelBounded () -- get at Bounded Int instance. -import PrelNum ( toInteger ) -import PrelWeak ( addForeignFinaliser ) -#if __CONCURRENT_HASKELL__ +import PrelException +import PrelEnum +import PrelNum ( toBig, Integer(..), Num(..), int2Integer ) +import PrelShow +import PrelReal ( toInteger ) +import PrelPack ( packString ) + import PrelConc -#endif -import Ix #ifndef __PARALLEL_HASKELL__ -import PrelForeign ( makeForeignObj ) +import PrelForeign ( newForeignPtr, mkForeignPtr, addForeignPtrFinalizer ) #endif #endif /* ndef(__HUGS__) */ #ifdef __HUGS__ -#define cat2(x,y) x/**/y -#define CCALL(fun) cat2(prim_,fun) #define __CONCURRENT_HASKELL__ #define stToIO id -#define sizeof_int64 8 -#else -#define CCALL(fun) _ccall_ fun -#define const_BUFSIZ ``BUFSIZ'' -#define primPackString #endif #ifndef __PARALLEL_HASKELL__ -#define FILE_OBJECT ForeignObj +#define FILE_OBJECT (ForeignPtr ()) #else -#define FILE_OBJECT Addr +#define FILE_OBJECT (Ptr ()) #endif +\end{code} +\begin{code} +mkBuffer__ :: FILE_OBJECT -> Int -> IO () +mkBuffer__ fo sz_in_bytes = do + chunk <- + case sz_in_bytes of + 0 -> return nullPtr -- this has the effect of overwriting the pointer to the old buffer. + _ -> do + chunk <- malloc sz_in_bytes + if chunk == nullPtr + then ioException (IOError Nothing ResourceExhausted + "mkBuffer__" "not enough virtual memory" Nothing) + else return chunk + setBuf fo chunk sz_in_bytes \end{code} %********************************************************* @@ -66,45 +76,66 @@ The @Handle@ and @Handle__@ types are defined in @IOBase@. \begin{code} {-# INLINE newHandle #-} -{-# INLINE withHandle #-} -{-# INLINE writeHandle #-} newHandle :: Handle__ -> IO Handle -withHandle :: Handle -> (Handle__ -> IO a) -> IO a -writeHandle :: Handle -> Handle__ -> IO () - -#if defined(__CONCURRENT_HASKELL__) -- Use MVars for concurrent Haskell newHandle hc = newMVar hc >>= \ h -> return (Handle h) +\end{code} + +%********************************************************* +%* * +\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. + +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. - -- withHandle grabs the handle lock, performs - -- some operation over it, making sure that we - -- unlock & reset the handle state should an - -- exception occur while performing said op. -withHandle (Handle h) act = do +There are three versions of @withHandle@: corresponding to the three +possible combinations of: + + - 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 = + block $ 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 = + block $ do h_ <- takeMVar h v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex) + putMVar h h_ return v -writeHandle (Handle h) hc = putMVar h hc -#else - --- Use ordinary MutableVars for non-concurrent Haskell -newHandle hc = stToIO (newVar hc >>= \ h -> - return (Handle h)) - - -- of questionable value to install this exception - -- handler, but let's do it in the non-concurrent - -- case too, for now. -withHandle (Handle h) act = do - h_ <- stToIO (readVar h) - v <- catchException (act h_) (\ ex -> stToIO (writeVar h h_) >> throw ex) - return v - -writeHandle (Handle h) hc = stToIO (writeVar h hc) -#endif - +withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO () +{-# INLINE withHandle__ #-} +withHandle__ (Handle h) act = + block $ 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 @@ -114,46 +145,52 @@ file object reference. nullFile__ :: FILE_OBJECT nullFile__ = #ifndef __PARALLEL_HASKELL__ - unsafePerformIO (makeForeignObj nullAddr) + unsafePerformIO (newForeignPtr nullPtr (return ())) #else - nullAddr + nullPtr #endif mkClosedHandle__ :: Handle__ mkClosedHandle__ = - Handle__ - nullFile__ - ClosedHandle - NoBuffering - "closed file" - -mkErrorHandle__ :: IOError -> Handle__ -mkErrorHandle__ ioe = - Handle__ - nullFile__ - (ErrorHandle ioe) - NoBuffering - "error handle" + Handle__ { haFO__ = nullFile__, + haType__ = ClosedHandle, + haBufferMode__ = NoBuffering, + haFilePath__ = "closed file", + haBuffers__ = [] + } \end{code} %********************************************************* %* * -\subsection{Handle Finalisers} +\subsection{Handle Finalizers} %* * %********************************************************* \begin{code} -#ifndef __HUGS__ -freeStdFileObject :: ForeignObj -> IO () -freeStdFileObject fo = CCALL(freeStdFileObject) fo - -freeFileObject :: ForeignObj -> IO () -freeFileObject fo = CCALL(freeFileObject) fo -#else -foreign import stdcall "libHS_cbits.so" "freeStdFileObject" freeStdFileObject :: ForeignObj -> IO () -foreign import stdcall "libHS_cbits.so" "freeFileObject" freeFileObject :: ForeignObj -> IO () -#endif +stdHandleFinalizer :: Handle -> IO () +stdHandleFinalizer (Handle hdl) = do + handle <- takeMVar hdl + let fo = haFO__ handle + freeStdFileObject fo + freeBuffers (haBuffers__ handle) + +handleFinalizer :: Handle -> IO () +handleFinalizer (Handle hdl) = do + handle <- takeMVar hdl + let fo = haFO__ handle + freeFileObject fo + freeBuffers (haBuffers__ handle) + +freeBuffers [] = return () +freeBuffers (b:bs) = do { free b; freeBuffers bs } + +foreign import "libHS_cbits" "freeStdFileObject" unsafe + freeStdFileObject :: FILE_OBJECT -> IO () +foreign import "libHS_cbits" "freeFileObject" unsafe + freeFileObject :: FILE_OBJECT -> IO () +foreign import "free" unsafe + free :: Ptr a -> IO () \end{code} %********************************************************* @@ -172,25 +209,18 @@ standard error channel. These handles are initially open. stdin, stdout, stderr :: Handle stdout = unsafePerformIO (do - rc <- CCALL(getLock) (1::Int) (1::Int) -- ConcHask: SAFE, won't block + 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::Int) - (1::Int){-flush on close-} - (0::Int){-writeable-} -- ConcHask: SAFE, won't block -#else - fo <- CCALL(openStdFile) (1::Int) - ((1{-flush on close-} {-+ 128 don't block on I/O-})::Int) - (0::Int){-writeable-} -- ConcHask: SAFE, won't block -#endif - -- NOTE: turn off non-blocking I/O until - -- we've got proper support for threadWait{Read,Write} + fo <- openStdFile (1::Int) + (0::Int){-writeable-} -- ConcHask: SAFE, won't block #ifndef __PARALLEL_HASKELL__ - fo <- makeForeignObj fo - addForeignFinaliser fo (freeStdFileObject fo) + fo <- mkForeignPtr fo + -- I know this is deprecated, but I couldn't bring myself + -- to move fixIO into the prelude just so I could use + -- newForeignPtr. --SDM #endif #ifdef __HUGS__ @@ -202,71 +232,64 @@ stdout = unsafePerformIO (do (bm, bf_size) <- getBMode__ fo mkBuffer__ fo bf_size #endif - newHandle (Handle__ fo WriteHandle bm "stdout") - _ -> do ioError <- constructError "stdout" - newHandle (mkErrorHandle__ ioError) + hdl <- newHandle (Handle__ fo WriteHandle bm "stdout" []) + +#ifndef __PARALLEL_HASKELL__ + addForeignPtrFinalizer fo (stdHandleFinalizer hdl) +#endif + return hdl + + _ -> constructErrorAndFail "stdout" ) stdin = unsafePerformIO (do - rc <- CCALL(getLock) (0::Int) (0::Int) -- ConcHask: SAFE, won't block + 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::Int) - (0::Int){-don't flush on close -} - (1::Int){-readable-} -- ConcHask: SAFE, won't block -#else - fo <- CCALL(openStdFile) (0::Int) - ((0{-flush on close-} {-+ 128 don't block on I/O-})::Int) - (1::Int){-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 - addForeignFinaliser fo (freeStdFileObject fo) + fo <- mkForeignPtr fo #endif (bm, bf_size) <- getBMode__ fo mkBuffer__ fo bf_size - hdl <- newHandle (Handle__ fo ReadHandle bm "stdin") + hdl <- newHandle (Handle__ fo ReadHandle bm "stdin" []) -- when stdin and stdout are both connected to a terminal, ensure - -- that anything buffered on stdout is flushed prior to reading from stdin. - -- + -- that anything buffered on stdout is flushed prior to reading from + -- stdin. +#ifndef __PARALLEL_HASKELL__ + addForeignPtrFinalizer fo (stdHandleFinalizer hdl) +#endif hConnectTerms stdout hdl return hdl - _ -> do ioError <- constructError "stdin" - newHandle (mkErrorHandle__ ioError) + _ -> constructErrorAndFail "stdin" ) stderr = unsafePerformIO (do - rc <- CCALL(getLock) (2::Int) (1::Int){-writeable-} -- ConcHask: SAFE, won't block + 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::Int) - (1::Int){-flush on close-} - (0::Int){-writeable-} -- ConcHask: SAFE, won't block -#else - fo <- CCALL(openStdFile) (2::Int) - ((1{-flush on close-} {- + 128 don't block on I/O-})::Int) - (0::Int){-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 - addForeignFinaliser fo (freeStdFileObject fo) + fo <- mkForeignPtr fo #endif - hdl <- newHandle (Handle__ fo WriteHandle NoBuffering "stderr") + 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 to -- stderr. +#ifndef __PARALLEL_HASKELL__ + addForeignPtrFinalizer fo (stdHandleFinalizer hdl) +#endif hConnectTo stdout hdl return hdl - _ -> do ioError <- constructError "stderr" - newHandle (mkErrorHandle__ ioError) + _ -> constructErrorAndFail "stderr" ) \end{code} @@ -291,17 +314,20 @@ openFile fp im = openFileEx fp (TextMode im) openFileEx :: FilePath -> IOModeEx -> IO Handle openFileEx f m = do - fo <- CCALL(openFile) (primPackString f) (file_mode::Int) - (binary::Int) - (file_flags::Int) -- ConcHask: SAFE, won't block - if fo /= nullAddr then do + fo <- primOpenFile (packString f) + (file_mode::Int) + (binary::Int) -- ConcHask: SAFE, won't block + if fo /= nullPtr then do #ifndef __PARALLEL_HASKELL__ - fo <- makeForeignObj fo - addForeignFinaliser fo (freeFileObject fo) + fo <- mkForeignPtr fo #endif (bm, bf_size) <- getBMode__ fo mkBuffer__ fo bf_size - newHandle (Handle__ fo htype bm f) + hdl <- newHandle (Handle__ fo htype bm f []) +#ifndef __PARALLEL_HASKELL__ + addForeignPtrFinalizer fo (handleFinalizer hdl) +#endif + return hdl else do constructErrorAndFailWithInfo "openFile" f where @@ -310,20 +336,12 @@ openFileEx f m = do BinaryMode bmo -> (bmo, 1) TextMode tmo -> (tmo, 0) -#ifndef __CONCURRENT_HASKELL__ - file_flags = file_flags' -#else - -- See comment next to 'stderr' for why we leave - -- non-blocking off for now. - file_flags = file_flags' {-+ 128 Don't block on I/O-} -#endif - - (file_flags', 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 @@ -360,32 +378,29 @@ implementation is free to impose stricter conditions. hClose :: Handle -> IO () hClose handle = - withHandle handle $ \ handle_ -> do + withHandle__ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hClose" handle + ClosedHandle -> return handle_ _ -> do - rc <- CCALL(closeFile) (haFO__ handle_) (1::Int){-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 + has been performed, the ForeignPtr 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 + to avoid closing the file object when the ForeignPtr + is finalized. (we overwrite the file ptr in the underlying FileObject with a NULL as part of closeFile()) -} - if rc == (0::Int) - then - writeHandle handle (handle_{ haType__ = ClosedHandle, - haFO__ = nullFile__ }) - else do - writeHandle handle handle_ - constructErrorAndFail "hClose" + if (rc /= 0) + then constructErrorAndFail "hClose" + + -- free the spare buffers (except the handle buffer) + -- associated with this handle. + else do freeBuffers (haBuffers__ handle_) + return (handle_{ haType__ = ClosedHandle, + haBuffers__ = [] }) \end{code} Computation $hClose hdl$ makes handle {\em hdl} closed. Before the @@ -394,7 +409,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} %* * %********************************************************* @@ -406,22 +421,14 @@ which can be read from {\em hdl}. \begin{code} hFileSize :: Handle -> IO Integer hFileSize handle = - withHandle handle $ \ handle_ -> do + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hFileSize" handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hFileSize" handle + ClosedHandle -> ioe_closedHandle "hFileSize" handle + SemiClosedHandle -> ioe_closedHandle "hFileSize" handle #ifdef __HUGS__ _ -> do - mem <- primNewByteArray sizeof_int64 - rc <- CCALL(fileSize_int64) (haFO__ handle_) mem -- ConcHask: SAFE, won't block - writeHandle handle handle_ + 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) @@ -433,20 +440,23 @@ hFileSize handle = -- 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_ + case int2Integer# 1# of + (# s, d #) -> do + rc <- fileSize (haFO__ handle_) d -- ConcHask: SAFE, won't block if rc == (0::Int) then - return result + 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 @@ -454,11 +464,8 @@ the file. Otherwise, it returns @False@. \begin{code} hIsEOF :: Handle -> IO Bool -hIsEOF handle = - wantReadableHandle "hIsEOF" handle $ \ handle_ -> do - let fo = haFO__ handle_ - rc <- mayBlock fo (CCALL(fileEOF) fo) -- ConcHask: UNSAFE, may block - writeHandle handle handle_ +hIsEOF handle = do + rc <- mayBlockRead "hIsEOF" handle fileEOF case rc of 0 -> return False 1 -> return True @@ -506,20 +513,17 @@ hSetBuffering :: Handle -> BufferMode -> IO () hSetBuffering handle mode = case mode of BlockBuffering (Just n) - | n <= 0 -> ioError + | n <= 0 -> ioException (IOError (Just handle) InvalidArgument "hSetBuffering" - ("illegal buffer size " ++ showsPrec 9 n [])) -- 9 => should be parens'ified. + ("illegal buffer size " ++ showsPrec 9 n []) + -- 9 => should be parens'ified. + Nothing) _ -> - withHandle handle $ \ handle_ -> do + withHandle__ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hSetBuffering" handle + ClosedHandle -> ioe_closedHandle "hSetBuffering" handle _ -> do {- Note: - we flush the old buffer regardless of whether @@ -532,13 +536,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 @@ -558,8 +561,7 @@ hFlush :: Handle -> IO () 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 @@ -578,7 +580,20 @@ hFlush handle = 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) @@ -593,20 +608,20 @@ to a previously obtained position {\em p}. hGetPosn :: Handle -> IO HandlePosn hGetPosn handle = wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do - posn <- CCALL(getFilePosn) (haFO__ handle_) -- ConcHask: SAFE, won't block - writeHandle handle handle_ - if posn /= -1 then - return (HandlePosn handle posn) + posn <- getFilePosn (haFO__ handle_) -- ConcHask: SAFE, won't block + if posn /= -1 then do + return (mkHandlePosn handle (int2Integer posn)) else constructErrorAndFail "hGetPosn" hSetPosn :: HandlePosn -> IO () -hSetPosn (HandlePosn handle posn) = - wantSeekableHandle "hSetPosn" handle $ \ handle_ -> do -- 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" @@ -614,25 +629,24 @@ hSetPosn (HandlePosn handle posn) = 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} @@ -641,15 +655,15 @@ hSeek :: Handle -> SeekMode -> Integer -> IO () hSeek handle mode offset = wantSeekableHandle "hSeek" handle $ \ handle_ -> do let fo = haFO__ handle_ - rc <- mayBlock fo (CCALL(seekFile_int64) fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block + rc <- mayBlock fo (seekFile fo whence (primIntegerToInt64 offset)) -- ConcHask: UNSAFE, may block #else -hSeek handle mode (J# _ s# d#) = +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 (CCALL(seekFile) fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block + rc <- mayBlock fo (seekFile fo whence (I# s#) d#) -- ConcHask: UNSAFE, may block #endif - writeHandle handle handle_ - if rc == 0 then + if rc == 0 then do return () else constructErrorAndFail "hSeek" @@ -680,34 +694,18 @@ $( Just n )$ for block-buffering of {\em n} bytes. \begin{code} hIsOpen :: Handle -> IO Bool hIsOpen handle = - withHandle handle $ \ handle_ -> do + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - return False - SemiClosedHandle -> do - writeHandle handle handle_ - return False - _ -> do - writeHandle handle handle_ - return True + ClosedHandle -> return False + SemiClosedHandle -> return False + _ -> return True hIsClosed :: Handle -> IO Bool hIsClosed handle = - withHandle handle $ \ handle_ -> do + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - return True - _ -> do - writeHandle handle handle_ - return False + ClosedHandle -> return True + _ -> return False {- not defined, nor exported, but mentioned here for documentation purposes: @@ -721,20 +719,11 @@ hIsClosed handle = hIsReadable :: Handle -> IO Bool hIsReadable handle = - withHandle handle $ \ handle_ -> do + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - 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) + ClosedHandle -> ioe_closedHandle "hIsReadable" handle + SemiClosedHandle -> ioe_closedHandle "hIsReadable" handle + htype -> return (isReadable htype) where isReadable ReadHandle = True isReadable ReadWriteHandle = True @@ -742,20 +731,11 @@ hIsReadable handle = hIsWritable :: Handle -> IO Bool hIsWritable handle = - withHandle handle $ \ handle_ -> do + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - 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) + ClosedHandle -> ioe_closedHandle "hIsWritable" handle + SemiClosedHandle -> ioe_closedHandle "hIsWritable" handle + htype -> return (isWritable htype) where isWritable AppendHandle = True isWritable WriteHandle = True @@ -763,13 +743,9 @@ hIsWritable handle = 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) @@ -778,7 +754,7 @@ getBMode__ fo = do n -> return (BlockBuffering (Just n), n) where default_buffer_size :: Int - default_buffer_size = (const_BUFSIZ - 1) + default_buffer_size = const_BUFSIZ \end{code} Querying how a handle buffers its data: @@ -786,45 +762,27 @@ Querying how a handle buffers its data: \begin{code} hGetBuffering :: Handle -> IO BufferMode hGetBuffering handle = - withHandle handle $ \ handle_ -> do + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hGetBuffering" handle - _ -> do + 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 = - withHandle handle $ \ handle_ -> do + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - 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 + ClosedHandle -> ioe_closedHandle "hIsSeekable" handle + SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle + AppendHandle -> return False _ -> do - rc <- CCALL(seekFileP) (haFO__ handle_) -- ConcHask: SAFE, won't block - writeHandle handle handle_ + rc <- seekFileP (haFO__ handle_) -- ConcHask: SAFE, won't block case (rc::Int) of 0 -> return False 1 -> return True @@ -848,17 +806,11 @@ hSetEcho handle on = do if not isT then return () else - withHandle handle $ \ handle_ -> do + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hSetEcho" handle + ClosedHandle -> ioe_closedHandle "hSetEcho" handle _ -> do - rc <- CCALL(setTerminalEcho) (haFO__ handle_) ((if on then 1 else 0)::Int) -- ConcHask: SAFE, won't block - writeHandle handle handle_ + rc <- setTerminalEcho (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block if rc /= ((-1)::Int) then return () else constructErrorAndFail "hSetEcho" @@ -869,17 +821,11 @@ hGetEcho handle = do if not isT then return False else - withHandle handle $ \ handle_ -> do + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hGetEcho" handle + ClosedHandle -> ioe_closedHandle "hGetEcho" handle _ -> do - rc <- CCALL(getTerminalEcho) (haFO__ handle_) -- ConcHask: SAFE, won't block - writeHandle handle handle_ + rc <- getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block case (rc::Int) of 1 -> return True 0 -> return False @@ -887,17 +833,11 @@ hGetEcho handle = do hIsTerminalDevice :: Handle -> IO Bool hIsTerminalDevice handle = do - withHandle handle $ \ handle_ -> do - case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "hIsTerminalDevice" handle + withHandle_ handle $ \ handle_ -> do + case haType__ handle_ of + ClosedHandle -> ioe_closedHandle "hIsTerminalDevice" handle _ -> do - rc <- CCALL(isTerminalDevice) (haFO__ handle_) -- ConcHask: SAFE, won't block - writeHandle handle handle_ + rc <- isTerminalDevice (haFO__ handle_) -- ConcHask: SAFE, won't block case (rc::Int) of 1 -> return True 0 -> return False @@ -912,21 +852,10 @@ hConnectTo :: Handle -> Handle -> IO () hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-} hConnectHdl_ :: Handle -> Handle -> Int -> IO () -hConnectHdl_ hW hR is_tty = - wantRWHandle "hConnectTo" hW $ \ hW_ -> do +hConnectHdl_ hW hR is_tty = + wantRWHandle "hConnectTo" hW $ \ hW_ -> wantRWHandle "hConnectTo" hR $ \ hR_ -> do - 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 - -flushConnectedBuf :: FILE_OBJECT -> IO () -flushConnectedBuf fo = CCALL(flushConnectedBuf) fo + 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. @@ -938,8 +867,7 @@ pushback. (For unbuffered channels, the (default) push-back limit is hUngetChar :: Handle -> Char -> IO () hUngetChar handle c = wantReadableHandle "hLookAhead" handle $ \ handle_ -> do - rc <- CCALL(ungetChar) (haFO__ handle_) c -- ConcHask: SAFE, won't block - writeHandle handle handle_ + rc <- ungetChar (haFO__ handle_) c -- ConcHask: SAFE, won't block if rc == ((-1)::Int) then constructErrorAndFail "hUngetChar" else return () @@ -952,7 +880,7 @@ this as an extension: \begin{code} -- in one go, read file into an externally allocated buffer. -slurpFile :: FilePath -> IO (Addr, Int) +slurpFile :: FilePath -> IO (Ptr (), Int) slurpFile fname = do handle <- openFile fname ReadMode sz <- hFileSize handle @@ -960,84 +888,21 @@ slurpFile fname = do ioError (userError "slurpFile: file too big") else do let sz_i = fromInteger sz - chunk <- CCALL(allocMemory__) (sz_i::Int) - if chunk == nullAddr + chunk <- malloc sz_i + if chunk == nullPtr then do hClose handle constructErrorAndFail "slurpFile" - else - withHandle handle $ \ handle_ -> do - let fo = haFO__ handle_ - rc <- mayBlock fo (CCALL(readChunk) fo chunk sz_i) -- ConcHask: UNSAFE, may block. - writeHandle handle handle_ + else do + 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) -#ifndef __HUGS__ /* Hugs' Prelude doesn't need this */ -hFillBufBA :: Handle -> ByteArray Int -> Int -> IO Int -hFillBufBA handle buf sz - | sz <= 0 = ioError (IOError (Just handle) - InvalidArgument - "hFillBufBA" - ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified. - | otherwise = - wantReadableHandle "hFillBufBA" handle $ \ handle_ -> do - let fo = haFO__ handle_ -#ifdef __HUGS__ - rc <- mayBlock fo (CCALL(readChunkBA) fo buf sz) -- ConcHask: UNSAFE, may block. -#else - rc <- mayBlock fo (CCALL(readChunk) fo buf sz) -- ConcHask: UNSAFE, may block. -#endif - writeHandle handle handle_ - if rc >= (0::Int) - then return rc - else constructErrorAndFail "hFillBufBA" -#endif - -hFillBuf :: Handle -> Addr -> Int -> IO Int -hFillBuf handle buf sz - | sz <= 0 = ioError (IOError (Just handle) - InvalidArgument - "hFillBuf" - ("illegal buffer size " ++ showsPrec 9 sz [])) -- 9 => should be parens'ified. - | otherwise = - wantReadableHandle "hFillBuf" handle $ \ handle_ -> do - 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" - -\end{code} - -The @hPutBuf hdl buf len@ action writes an already packed sequence of -bytes to the file/channel managed by @hdl@ - non-standard. - -\begin{code} -hPutBuf :: Handle -> Addr -> Int -> IO () -hPutBuf handle buf len = - wantWriteableHandle "hPutBuf" handle $ \ handle_ -> do - let fo = haFO__ handle_ - rc <- mayBlock fo (CCALL(writeBuf) fo buf len) -- ConcHask: UNSAFE, may block. - writeHandle handle handle_ - if rc == (0::Int) - then return () - else constructErrorAndFail "hPutBuf" - -#ifndef __HUGS__ /* An_ one Hugs doesn't provide */ -hPutBufBA :: Handle -> ByteArray Int -> Int -> IO () -hPutBufBA handle buf len = - wantWriteableHandle "hPutBufBA" handle $ \ handle_ -> do - let fo = haFO__ handle_ - rc <- mayBlock fo (CCALL(writeBufBA) fo buf len) -- ConcHask: UNSAFE, may block. - writeHandle handle handle_ - if rc == (0::Int) - then return () - else constructErrorAndFail "hPutBuf" -#endif \end{code} Sometimes it's useful to get at the file descriptor that @@ -1045,18 +910,12 @@ the Handle contains.. \begin{code} getHandleFd :: Handle -> IO Int -getHandleFd handle = do - withHandle handle $ \ handle_ -> do +getHandleFd handle = + withHandle_ handle $ \ handle_ -> do case (haType__ handle_) of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle "getHandleFd" handle + ClosedHandle -> ioe_closedHandle "getHandleFd" handle _ -> do - fd <- CCALL(getFileFd) (haFO__ handle_) - writeHandle handle handle_ + fd <- getFileFd (haFO__ handle_) return fd \end{code} @@ -1076,112 +935,128 @@ ioeGetFileName :: IOError -> Maybe FilePath ioeGetErrorString :: IOError -> String ioeGetHandle :: IOError -> Maybe Handle -ioeGetHandle (IOError h _ _ _) = h -ioeGetErrorString (IOError _ iot _ str) = - case iot of - EOF -> "end of file" - _ -> str +ioeGetHandle (IOException (IOError h _ _ _ _)) = h +ioeGetHandle (UserError _) = Nothing +ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error" + +ioeGetErrorString (IOException (IOError _ iot _ str _)) = + case iot of + EOF -> "end of file" + _ -> str +ioeGetErrorString (UserError str) = str +ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error" + +ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn +ioeGetFileName (UserError _) = Nothing +ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error" +\end{code} -ioeGetFileName (IOError _ _ _ str) = - case span (/=':') str of - (_,[]) -> Nothing - (fs,_) -> Just fs +'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 import ccall "addrOf_ErrorHdrHook" unsafe + addrOf_ErrorHdrHook :: Ptr () + +foreign import ccall "writeErrString__" unsafe + writeErrString :: Ptr () -> ByteArray Int -> Int -> IO () + +-- SUP: Are the hooks allowed to re-enter Haskell land? If yes, remove the unsafe below. +foreign import ccall "stackOverflow" unsafe + callStackOverflowHook :: IO () + +foreign import ccall "stg_exit" unsafe + 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 -> (Handle__ -> IO a) -> IO a wantReadableHandle fun handle act = - withHandle handle $ \ handle_ -> do + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - AppendHandle -> do - writeHandle handle handle_ - ioError not_readable_error - WriteHandle -> do - writeHandle handle handle_ - ioError not_readable_error - _ -> act handle_ + ClosedHandle -> ioe_closedHandle fun handle + SemiClosedHandle -> ioe_closedHandle fun handle + AppendHandle -> ioException not_readable_error + WriteHandle -> ioException not_readable_error + _ -> act handle_ where not_readable_error = - IOError (Just handle) IllegalOperation fun - ("handle is not open for reading") + IOError (Just handle) IllegalOperation fun + "handle is not open for reading" Nothing wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantWriteableHandle fun handle act = - withHandle handle $ \ handle_ -> do - case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - ReadHandle -> do - writeHandle handle handle_ - ioError not_writeable_error - _ -> act handle_ + withHandle_ handle $ \ handle_ -> + checkWriteableHandle fun handle handle_ (act handle_) + +wantWriteableHandle_ :: String -> Handle -> (Handle__ -> IO (Handle__, a)) -> IO a +wantWriteableHandle_ fun handle act = + withHandle handle $ \ handle_ -> + checkWriteableHandle fun handle handle_ (act handle_) + +checkWriteableHandle fun handle handle_ act + = case haType__ handle_ of + ClosedHandle -> ioe_closedHandle fun handle + SemiClosedHandle -> ioe_closedHandle fun handle + ReadHandle -> ioException not_writeable_error + _ -> act where not_writeable_error = - IOError (Just handle) IllegalOperation fun - ("handle is not open for writing") + IOError (Just handle) IllegalOperation fun + "handle is not open for writing" Nothing wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a wantRWHandle fun handle act = - withHandle handle $ \ handle_ -> do + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - _ -> act handle_ - where - not_rw_error = - IOError (Just handle) IllegalOperation fun - ("handle is not open for reading or writing") + 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 + withHandle_ handle $ \ handle_ -> do case haType__ handle_ of - ErrorHandle theError -> do - writeHandle handle handle_ - ioError theError - ClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - SemiClosedHandle -> do - writeHandle handle handle_ - ioe_closedHandle fun handle - AppendHandle -> do - writeHandle handle handle_ - ioError not_seekable_error - _ -> act handle_ - where - not_seekable_error = - IOError (Just handle) - IllegalOperation fun - ("handle is not seekable") - + ClosedHandle -> ioe_closedHandle fun handle + SemiClosedHandle -> ioe_closedHandle fun handle + _ -> act handle_ \end{code} Internal function for creating an @IOError@ representing the @@ -1189,135 +1064,229 @@ access to a closed file. \begin{code} ioe_closedHandle :: String -> Handle -> IO a -ioe_closedHandle fun h = ioError (IOError (Just h) IllegalOperation fun "handle is closed") +ioe_closedHandle fun h = ioException (IOError (Just h) IllegalOperation fun + "handle is closed" Nothing) \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 notyet /*__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 -#endif - --- #ifdef __HUGS__ -#if 1 -threadDelay, threadWaitRead, threadWaitWrite :: Int -> IO () - --- Hugs does actually have the primops needed to implement these --- but, like GHC, the primops don't actually do anything... -threadDelay _ = return () -threadWaitRead _ = return () -threadWaitWrite _ = return () -#endif - +data MayBlock a + = BlockRead Int + | BlockWrite Int + | NoBlock a + +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 + +mayBlockRead' :: String -> Handle + -> (FILE_OBJECT -> IO Int) + -> (FILE_OBJECT -> Int -> IO a) + -> IO a +mayBlockRead' fname handle fn io = 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 do a <- io fo rc + return (NoBlock a) + else constructErrorAndFail fname + case r of + BlockRead fd -> do + threadWaitRead fd + mayBlockRead' fname handle fn io + BlockWrite fd -> do + threadWaitWrite fd + mayBlockRead' fname handle fn io + 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 FD = Int -type Exclusive = Int -- really Bool -type How = Int -type Binary = Int -type OpenStdFlags = Int -type OpenFlags = Int -type Readable = Int -- really Bool -type Flush = Int -- really Bool -type RC = Int -- standard return code - -type IOFileAddr = Addr -- as returned from functions -type CString = PrimByteArray -type Bytes = PrimMutableByteArray RealWorld -#ifndef __PARALLEL_HASKELL__ -type FILE_OBJ = ForeignObj -- as passed into functions +#ifdef __HUGS__ +type Bytes = PrimByteArray RealWorld #else -type FILE_OBJ = Addr +type Bytes = ByteArray# #endif -foreign import ccall "libHS_cbits.so" "setBuf" unsafe prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO () -foreign import ccall "libHS_cbits.so" "getBufSize" unsafe prim_getBufSize :: FILE_OBJ -> IO Int -foreign import ccall "libHS_cbits.so" "inputReady" unsafe prim_inputReady :: FILE_OBJ -> Int -> IO RC -foreign import ccall "libHS_cbits.so" "fileGetc" unsafe prim_fileGetc :: FILE_OBJ -> IO Int -foreign import ccall "libHS_cbits.so" "fileLookAhead" unsafe prim_fileLookAhead :: FILE_OBJ -> IO Int -foreign import ccall "libHS_cbits.so" "readBlock" unsafe prim_readBlock :: FILE_OBJ -> IO Int -foreign import ccall "libHS_cbits.so" "readLine" unsafe prim_readLine :: FILE_OBJ -> IO Int -foreign import ccall "libHS_cbits.so" "readChar" unsafe prim_readChar :: FILE_OBJ -> IO Int -foreign import ccall "libHS_cbits.so" "writeFileObject" unsafe prim_writeFileObject :: FILE_OBJ -> Int -> IO RC -foreign import ccall "libHS_cbits.so" "filePutc" unsafe prim_filePutc :: FILE_OBJ -> Char -> IO RC -foreign import ccall "libHS_cbits.so" "getBufStart" unsafe prim_getBufStart :: FILE_OBJ -> Int -> IO Addr -foreign import ccall "libHS_cbits.so" "getWriteableBuf" unsafe prim_getWriteableBuf :: FILE_OBJ -> IO Addr -foreign import ccall "libHS_cbits.so" "getBufWPtr" unsafe prim_getBufWPtr :: FILE_OBJ -> IO Int -foreign import ccall "libHS_cbits.so" "setBufWPtr" unsafe prim_setBufWPtr :: FILE_OBJ -> Int -> IO () -foreign import ccall "libHS_cbits.so" "closeFile" unsafe prim_closeFile :: FILE_OBJ -> Flush -> IO RC -foreign import ccall "libHS_cbits.so" "fileEOF" unsafe prim_fileEOF :: FILE_OBJ -> IO RC -foreign import ccall "libHS_cbits.so" "setBuffering" unsafe prim_setBuffering :: FILE_OBJ -> Int -> IO RC -foreign import ccall "libHS_cbits.so" "flushFile" unsafe prim_flushFile :: FILE_OBJ -> IO RC -foreign import ccall "libHS_cbits.so" "flushConnectedBuf" unsafe prim_flushConnectedBuf :: FILE_OBJ -> IO RC -foreign import ccall "libHS_cbits.so" "getBufferMode" unsafe prim_getBufferMode :: FILE_OBJ -> IO RC -foreign import ccall "libHS_cbits.so" "seekFile_int64" unsafe prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC -foreign import ccall "libHS_cbits.so" "seekFileP" unsafe prim_seekFileP :: FILE_OBJ -> IO RC -foreign import ccall "libHS_cbits.so" "setTerminalEcho" unsafe prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC -foreign import ccall "libHS_cbits.so" "getTerminalEcho" unsafe prim_getTerminalEcho :: FILE_OBJ -> IO RC -foreign import ccall "libHS_cbits.so" "isTerminalDevice" unsafe prim_isTerminalDevice :: FILE_OBJ -> IO RC -foreign import ccall "libHS_cbits.so" "setConnectedTo" unsafe prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO () -foreign import ccall "libHS_cbits.so" "ungetChar" unsafe prim_ungetChar :: FILE_OBJ -> Char -> IO RC -foreign import ccall "libHS_cbits.so" "readChunk" unsafe prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC -foreign import ccall "libHS_cbits.so" "writeBuf" unsafe prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC -foreign import ccall "libHS_cbits.so" "getFileFd" unsafe prim_getFileFd :: FILE_OBJ -> IO FD -foreign import ccall "libHS_cbits.so" "fileSize_int64" unsafe prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC -foreign import ccall "libHS_cbits.so" "getFilePosn" unsafe prim_getFilePosn :: FILE_OBJ -> IO Int -foreign import ccall "libHS_cbits.so" "setFilePosn" unsafe prim_setFilePosn :: FILE_OBJ -> Int -> IO Int -foreign import ccall "libHS_cbits.so" "getConnFileFd" unsafe prim_getConnFileFd :: FILE_OBJ -> IO FD -foreign import ccall "libHS_cbits.so" "allocMemory__" unsafe prim_allocMemory__ :: Int -> IO Addr -foreign import ccall "libHS_cbits.so" "getLock" unsafe prim_getLock :: FD -> Exclusive -> IO RC -foreign import ccall "libHS_cbits.so" "openStdFile" unsafe prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr -foreign import ccall "libHS_cbits.so" "openFile" unsafe prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr -foreign import ccall "libHS_cbits.so" "freeFileObject" unsafe prim_freeFileObject :: FILE_OBJ -> IO () -foreign import ccall "libHS_cbits.so" "freeStdFileObject" unsafe prim_freeStdFileObject :: FILE_OBJ -> IO () -foreign import ccall "libHS_cbits.so" "const_BUFSIZ" unsafe const_BUFSIZ :: Int - -foreign import ccall "libHS_cbits.so" "setConnNonBlockingIOFlag__" unsafe prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () -foreign import ccall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" unsafe prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO () -foreign import ccall "libHS_cbits.so" "setNonBlockingIOFlag__" unsafe prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO () -foreign import ccall "libHS_cbits.so" "clearNonBlockingIOFlag__" unsafe prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO () - -foreign import ccall "libHS_cbits.so" "getErrStr__" unsafe prim_getErrStr__ :: IO Addr -foreign import ccall "libHS_cbits.so" "getErrNo__" unsafe prim_getErrNo__ :: IO Int -foreign import ccall "libHS_cbits.so" "getErrType__" unsafe prim_getErrType__ :: IO Int - +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" "write_" unsafe + write_ :: FILE_OBJECT -> Ptr () -> Int -> IO Int{-ret code-} +foreign import "libHS_cbits" "getBufStart" unsafe + getBufStart :: FILE_OBJECT -> Int -> IO (Ptr ()) +foreign import "libHS_cbits" "getWriteableBuf" unsafe + getWriteableBuf :: FILE_OBJECT -> IO (Ptr ()) +foreign import "libHS_cbits" "getBuf" unsafe + getBuf :: FILE_OBJECT -> IO (Ptr ()) +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 -> Ptr a -> Int -> Int -> IO Int{-ret code-} +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 -\end{code} - +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 (Ptr ()){-file object-} +foreign import "libHS_cbits" "openFile" unsafe + primOpenFile :: ByteArray Int{-CString-} + -> Int{-How-} + -> Int{-Binary-} + -> IO (Ptr ()){-file object-} +foreign import "libHS_cbits" "const_BUFSIZ" unsafe + const_BUFSIZ :: Int + +foreign import "libHS_cbits" "setBinaryMode__" unsafe + setBinaryMode :: FILE_OBJECT -> Int -> IO Int +\end{code}