-
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% ------------------------------------------------------------------------------
+% $Id: PrelHandle.lhs,v 1.63 2000/11/07 10:42:56 simonmar Exp $
+%
+% (c) The AQUA Project, Glasgow University, 1994-2000
%
\section[PrelHandle]{Module @PrelHandle@}
\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 PrelAddr ( Addr, nullAddr )
-import PrelArr ( newVar, readVar, writeVar, ByteArray(..) )
+import PrelByteArr ( ByteArray(..) )
import PrelRead ( Read )
import PrelList ( span )
import PrelIOBase
-import PrelException
import PrelMaybe ( Maybe(..) )
+import PrelException
import PrelEnum
-import PrelNum
+import PrelNum ( toBig, Integer(..), Num(..) )
import PrelShow
import PrelAddr ( Addr, nullAddr )
-import PrelNum ( toInteger, toBig )
+import PrelReal ( toInteger )
import PrelPack ( packString )
+#ifndef __PARALLEL_HASKELL__
import PrelWeak ( addForeignFinalizer )
-import Ix
+#endif
-#ifdef __CONCURRENT_HASKELL__
import PrelConc
-#endif
#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( makeForeignObj )
+import PrelForeign ( makeForeignObj, mkForeignObj )
#endif
#endif /* ndef(__HUGS__) */
#endif
\end{code}
+\begin{code}
+mkBuffer__ :: FILE_OBJECT -> Int -> IO ()
+mkBuffer__ fo sz_in_bytes = do
+ chunk <-
+ case sz_in_bytes of
+ 0 -> return nullAddr -- this has the effect of overwriting the pointer to the old buffer.
+ _ -> do
+ chunk <- malloc sz_in_bytes
+ if chunk == nullAddr
+ then ioException (IOError Nothing ResourceExhausted "mkBuffer__" "not enough virtual memory")
+ else return chunk
+ setBuf fo chunk sz_in_bytes
+\end{code}
+
%*********************************************************
%* *
\subsection{Types @Handle@, @Handle__@}
\begin{code}
{-# INLINE newHandle #-}
-{-# INLINE withHandle #-}
newHandle :: Handle__ -> IO Handle
-#if defined(__CONCURRENT_HASKELL__)
-
-- Use MVars for concurrent Haskell
newHandle hc = newMVar hc >>= \ h ->
return (Handle h)
-#else
-
--- Use ordinary MutableVars for non-concurrent Haskell
-newHandle hc = stToIO (newVar hc >>= \ h ->
- return (Handle h))
-#endif
\end{code}
%*********************************************************
but we might want to revisit this in the future --SDM ].
\begin{code}
-#ifdef __CONCURRENT_HASKELL__
withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
-withHandle (Handle h) act = do
+{-# 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
-withHandle_ (Handle h) act = do
+{-# 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
withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO ()
-withHandle__ (Handle h) act = do
+{-# 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 ()
-
-#else
- -- 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
-
-#endif
\end{code}
nullFile__ is only used for closed handles, plugging it in as a null
nullFile__ :: FILE_OBJECT
nullFile__ =
#ifndef __PARALLEL_HASKELL__
- unsafePerformIO (makeForeignObj nullAddr)
+ unsafePerformIO (makeForeignObj nullAddr (return ()))
#else
nullAddr
#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}
%*********************************************************
%*********************************************************
\begin{code}
-foreign import "libHS_cbits" "freeStdFileObject"
+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"
+foreign import "libHS_cbits" "freeFileObject" unsafe
freeFileObject :: FILE_OBJECT -> IO ()
-
+foreign import "free" unsafe
+ free :: Addr -> IO ()
\end{code}
%*********************************************************
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- makeForeignObj fo
- addForeignFinalizer fo (freeStdFileObject fo)
+ fo <- mkForeignObj fo
+ -- I know this is deprecated, but I couldn't bring myself
+ -- to move fixIO into the prelude just so I could use makeForeignObj.
+ -- --SDM
#endif
#ifdef __HUGS__
(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__
+ addForeignFinalizer fo (stdHandleFinalizer hdl)
+#endif
+ return hdl
+
+ _ -> constructErrorAndFail "stdout"
)
stdin = unsafePerformIO (do
(1::Int){-readable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- makeForeignObj fo
- addForeignFinalizer fo (freeStdFileObject fo)
+ fo <- mkForeignObj 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__
+ addForeignFinalizer fo (stdHandleFinalizer hdl)
+#endif
hConnectTerms stdout hdl
return hdl
- _ -> do ioError <- constructError "stdin"
- newHandle (mkErrorHandle__ ioError)
+ _ -> constructErrorAndFail "stdin"
)
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- makeForeignObj fo
- addForeignFinalizer fo (freeStdFileObject fo)
+ fo <- mkForeignObj 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__
+ addForeignFinalizer fo (stdHandleFinalizer hdl)
+#endif
hConnectTo stdout hdl
return hdl
- _ -> do ioError <- constructError "stderr"
- newHandle (mkErrorHandle__ ioError)
+ _ -> constructErrorAndFail "stderr"
)
\end{code}
(binary::Int) -- ConcHask: SAFE, won't block
if fo /= nullAddr then do
#ifndef __PARALLEL_HASKELL__
- fo <- makeForeignObj fo
- addForeignFinalizer fo (freeFileObject fo)
+ fo <- mkForeignObj 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__
+ addForeignFinalizer fo (handleFinalizer hdl)
+#endif
+ return hdl
else do
constructErrorAndFailWithInfo "openFile" f
where
hClose handle =
withHandle__ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> return handle_
_ -> do
rc <- closeFile (haFO__ handle_)
is finalized. (we overwrite the file ptr in the underlying
FileObject with a NULL as part of closeFile())
-}
- if rc == (0::Int)
- then return (handle_{ haType__ = ClosedHandle,
- haFO__ = nullFile__ })
- else 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
%*********************************************************
%* *
-\subsection[EOF]{Detecting the End of Input}
+\subsection[FileSize]{Detecting the size of a file}
%* *
%*********************************************************
hFileSize handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hFileSize" handle
SemiClosedHandle -> ioe_closedHandle "hFileSize" handle
#ifdef __HUGS__
#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
\begin{code}
hIsEOF :: Handle -> IO Bool
-hIsEOF handle =
- wantReadableHandle "hIsEOF" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- rc <- mayBlock fo (fileEOF fo) -- ConcHask: UNSAFE, may block
+hIsEOF handle = do
+ rc <- mayBlockRead "hIsEOF" handle fileEOF
case rc of
0 -> return False
1 -> return True
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.
_ ->
withHandle__ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hSetBuffering" handle
_ -> do
{- Note:
-- [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
hIsOpen handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> return False
SemiClosedHandle -> return False
_ -> return True
hIsClosed handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> return True
_ -> return False
hIsReadable handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hIsReadable" handle
SemiClosedHandle -> ioe_closedHandle "hIsReadable" handle
htype -> return (isReadable htype)
hIsWritable handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hIsWritable" handle
SemiClosedHandle -> ioe_closedHandle "hIsWritable" handle
htype -> return (isWritable htype)
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 <- getBufferMode fo -- ConcHask: SAFE, won't block
case (rc::Int) of
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:
hGetBuffering handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hGetBuffering" handle
_ ->
{-
hIsSeekable handle =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hIsSeekable" handle
SemiClosedHandle -> ioe_closedHandle "hIsSeekable" handle
AppendHandle -> return False
else
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- 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
else
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hGetEcho" handle
_ -> do
rc <- getTerminalEcho (haFO__ handle_) -- ConcHask: SAFE, won't block
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
wantRWHandle "hConnectTo" hW $ \ hW_ ->
wantRWHandle "hConnectTo" hR $ \ hR_ -> do
setConnectedTo (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
-
-#ifndef __PARALLEL_HASKELL__
-#define FILE_OBJECT ForeignObj
-#else
-#define FILE_OBJECT Addr
-#endif
-
\end{code}
As an extension, we also allow characters to be pushed back.
ioError (userError "slurpFile: file too big")
else do
let sz_i = fromInteger sz
- chunk <- allocMemory__ sz_i
+ chunk <- malloc sz_i
if chunk == nullAddr
then do
hClose handle
else do
rc <- withHandle_ handle ( \ handle_ -> do
let fo = haFO__ handle_
- mayBlock fo (readChunk fo chunk sz_i) -- ConcHask: UNSAFE, may block.
+ 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_
- rc <- mayBlock fo (readChunkBA fo buf sz) -- ConcHask: UNSAFE, may block.
- 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 (readChunk fo buf sz) -- ConcHask: UNSAFE, may block.
- 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 (writeBuf fo buf len) -- ConcHask: UNSAFE, may block.
- 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 (writeBufBA fo buf len) -- ConcHask: UNSAFE, may block.
- if rc == (0::Int)
- then return ()
- else constructErrorAndFail "hPutBuf"
-#endif
\end{code}
Sometimes it's useful to get at the file descriptor that
getHandleFd handle =
withHandle_ handle $ \ handle_ -> do
case (haType__ handle_) of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "getHandleFd" handle
_ -> do
fd <- getFileFd (haFO__ handle_)
ioeGetErrorString :: IOError -> String
ioeGetHandle :: IOError -> Maybe Handle
-ioeGetHandle (IOError h _ _ _) = h
-ioeGetErrorString (IOError _ iot _ str) =
+ioeGetHandle (IOException (IOError h _ _ _)) = h
+ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error"
+
+ioeGetErrorString (IOException (IOError _ iot _ str)) =
case iot of
EOF -> "end of file"
_ -> str
+ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error"
-ioeGetFileName (IOError _ _ _ str) =
+ioeGetFileName (IOException (IOError _ _ _ str)) =
case span (/=':') str of
(_,[]) -> Nothing
(fs,_) -> Just fs
-
+ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error"
\end{code}
'Top-level' IO actions want to catch exceptions (e.g., forkIO and
reportError :: Bool -> String -> IO ()
reportError bombOut str = do
(hFlush stdout) `catchException` (\ _ -> return ())
- let bs@(ByteArray (_,len) _) = packString str
+ let bs@(ByteArray _ len _) = packString str
writeErrString addrOf_ErrorHdrHook bs len
if bombOut then
stg_exit 1
else
return ()
-foreign label "ErrorHdrHook"
+foreign import ccall "addrOf_ErrorHdrHook" unsafe
addrOf_ErrorHdrHook :: Addr
-foreign import ccall "writeErrString__"
+foreign import ccall "writeErrString__" unsafe
writeErrString :: Addr -> ByteArray Int -> Int -> IO ()
-foreign import ccall "stackOverflow"
+-- 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"
+foreign import ccall "stg_exit" unsafe
stg_exit :: Int -> IO ()
\end{code}
wantReadableHandle fun handle act =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
- AppendHandle -> ioError not_readable_error
- WriteHandle -> ioError not_readable_error
+ AppendHandle -> ioException not_readable_error
+ WriteHandle -> ioException not_readable_error
_ -> act handle_
where
not_readable_error =
wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantWriteableHandle fun handle act =
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
- ErrorHandle theError -> ioError theError
+ 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 -> ioError not_writeable_error
- _ -> act handle_
+ _ -> act
where
not_writeable_error =
- IOError (Just handle) IllegalOperation fun
- ("handle is not open for writing")
+ IOException (IOError (Just handle) IllegalOperation fun
+ ("handle is not open for writing"))
wantRWHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantRWHandle fun handle act =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
_ -> act handle_
wantSeekableHandle fun handle act =
withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle fun handle
SemiClosedHandle -> ioe_closedHandle fun handle
_ -> act handle_
- where
- not_seekable_error =
- IOError (Just handle)
- IllegalOperation fun
- ("handle is not seekable")
-
\end{code}
Internal function for creating an @IOError@ representing the
\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 = ioError (IOException (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
-
+mayBlock :: FILE_OBJECT -> IO Int -> IO Int
mayBlock fo act = do
rc <- act
case rc of
mayBlock fo act -- output possible
_ -> do
return rc
+
+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:
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 -> Addr -> Int -> 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" "getBuf" unsafe
+ getBuf :: FILE_OBJECT -> IO Addr
foreign import "libHS_cbits" "getBufWPtr" unsafe
getBufWPtr :: FILE_OBJECT -> IO Int
foreign import "libHS_cbits" "setBufWPtr" unsafe
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 -> IO Int{-ret code-}
-foreign import "libHS_cbits" "readChunk" unsafe
- readChunkBA :: FILE_OBJECT -> ByteArray Int -> Int -> IO Int{-ret code-}
-foreign import "libHS_cbits" "writeBuf" unsafe
- writeBuf :: FILE_OBJECT -> Addr -> Int -> IO Int{-ret code-}
-#ifndef __HUGS__
-foreign import "libHS_cbits" "writeBufBA" unsafe
- writeBufBA :: FILE_OBJECT -> ByteArray Int -> Int -> IO Int{-ret code-}
-#endif
+ readChunk :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-}
foreign import "libHS_cbits" "getFileFd" unsafe
getFileFd :: FILE_OBJECT -> IO Int{-fd-}
#ifdef __HUGS__
foreign import "libHS_cbits" "const_BUFSIZ" unsafe
const_BUFSIZ :: Int
-foreign import "libHS_cbits" "setBinaryMode__"
+foreign import "libHS_cbits" "setBinaryMode__" unsafe
setBinaryMode :: FILE_OBJECT -> Int -> IO Int
\end{code}
projects / ghc-hetmet.git / blobdiff