+% ------------------------------------------------------------------------------
+% $Id: PrelHandle.lhs,v 1.63 2000/11/07 10:42:56 simonmar Exp $
%
-% (c) The AQUA Project, Glasgow University, 1994-1996
+% (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 PrelArr ( newVar, readVar, writeVar, ByteArray )
+import PrelAddr ( Addr, nullAddr )
+import PrelByteArr ( ByteArray(..) )
import PrelRead ( Read )
import PrelList ( span )
import PrelIOBase
-import PrelException ( Exception(..), throw, catch, fail, catchException )
import PrelMaybe ( Maybe(..) )
+import PrelException
+import PrelEnum
+import PrelNum ( toBig, Integer(..), Num(..) )
+import PrelShow
import PrelAddr ( Addr, nullAddr )
-import PrelBounded () -- get at Bounded Int instance.
-import PrelNum ( toInteger )
-import PrelWeak ( addForeignFinaliser )
-#if __CONCURRENT_HASKELL__
-import PrelConc
+import PrelReal ( toInteger )
+import PrelPack ( packString )
+#ifndef __PARALLEL_HASKELL__
+import PrelWeak ( addForeignFinalizer )
#endif
-import Ix
+
+import PrelConc
#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( makeForeignObj, writeForeignObj )
+import PrelForeign ( makeForeignObj, mkForeignObj )
#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
#else
#define FILE_OBJECT Addr
#endif
-#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}
%*********************************************************
\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}
- -- 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
+%*********************************************************
+%* *
+\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.
+
+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
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}
%*********************************************************
%* *
-\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.dll" "freeStdFileObject" freeStdFileObject :: ForeignObj -> IO ()
-foreign import stdcall "./libHS_cbits.dll" "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 :: Addr -> IO ()
\end{code}
%*********************************************************
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
- addForeignFinaliser 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
- 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
- addForeignFinaliser 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"
)
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
- addForeignFinaliser fo (freeStdFileObject fo)
+ fo <- mkForeignObj 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 to
+ -- stderr.
+#ifndef __PARALLEL_HASKELL__
+ addForeignFinalizer fo (stdHandleFinalizer hdl)
#endif
- newHandle (Handle__ fo WriteHandle NoBuffering "stderr")
- _ -> do ioError <- constructError "stderr"
- newHandle (mkErrorHandle__ ioError)
+ hConnectTo stdout hdl
+ return hdl
+
+ _ -> constructErrorAndFail "stderr"
)
\end{code}
openFileEx :: FilePath -> IOModeEx -> IO Handle
openFileEx f m = do
- fo <- CCALL(openFile) (primPackString f) file_mode binary file_flags -- 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
- addForeignFinaliser 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
(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_flags = file_flags'
-#else
- 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
hClose :: Handle -> IO ()
hClose handle =
- withHandle handle $ \ handle_ -> do
+ 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
+ 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)
+ 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}
%* *
%*********************************************************
\begin{code}
hFileSize :: Handle -> IO Integer
hFileSize handle =
- withHandle handle $ \ handle_ -> do
+ 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
+ ClosedHandle -> ioe_closedHandle "hFileSize" handle
+ SemiClosedHandle -> ioe_closedHandle "hFileSize" handle
#ifdef __HUGS__
- other -> do
- mem <- primNewByteArray sizeof_int64
- rc <- CCALL(fileSize_int64) (haFO__ handle_) mem -- ConcHask: SAFE, won't block
- writeHandle handle handle_
+ _ -> 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
- other ->
+ _ ->
-- 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
\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
hSetBuffering handle mode =
case mode of
BlockBuffering (Just n)
- | n <= 0 -> fail (IOError (Just handle)
+ | 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
+ 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
+ ClosedHandle -> ioe_closedHandle "hSetBuffering" handle
_ -> do
{- Note:
- we flush the old buffer regardless of whether
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
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
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)
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 (fromInt 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"
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 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 offset@(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"
\begin{code}
hIsOpen :: Handle -> IO Bool
hIsOpen handle =
- withHandle handle $ \ handle_ -> do
+ 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
+ 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 ioError -> do
- writeHandle handle handle_
- fail ioError
- 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:
hIsReadable :: Handle -> IO Bool
hIsReadable handle =
- withHandle handle $ \ handle_ -> do
+ 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)
+ ClosedHandle -> ioe_closedHandle "hIsReadable" handle
+ SemiClosedHandle -> ioe_closedHandle "hIsReadable" handle
+ htype -> return (isReadable htype)
where
isReadable ReadHandle = True
isReadable ReadWriteHandle = True
hIsWritable :: Handle -> IO Bool
hIsWritable handle =
- withHandle handle $ \ handle_ -> do
+ 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)
+ ClosedHandle -> ioe_closedHandle "hIsWritable" handle
+ SemiClosedHandle -> ioe_closedHandle "hIsWritable" handle
+ htype -> return (isWritable htype)
where
isWritable AppendHandle = True
isWritable WriteHandle = True
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)
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:
\begin{code}
hGetBuffering :: Handle -> IO BufferMode
hGetBuffering handle =
- withHandle handle $ \ handle_ -> do
+ 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
+ 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 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
+ 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"
if not isT
then return ()
else
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle ioError -> do
- writeHandle handle handle_
- fail ioError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hSetEcho" handle
- other -> do
- rc <- CCALL(setTerminalEcho) (haFO__ handle_) (if on then 1 else 0) -- ConcHask: SAFE, won't block
- writeHandle handle handle_
- if rc /= -1
+ 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"
if not isT
then return False
else
- withHandle handle $ \ handle_ -> do
+ withHandle_ handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle ioError -> do
- writeHandle handle handle_
- fail ioError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hGetEcho" handle
- other -> do
- rc <- CCALL(getTerminalEcho) (haFO__ handle_) -- ConcHask: SAFE, won't block
- writeHandle handle handle_
- case rc of
+ 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 handle = do
- withHandle handle $ \ handle_ -> do
- case haType__ handle_ of
- ErrorHandle ioError -> do
- writeHandle handle handle_
- fail ioError
- ClosedHandle -> do
- writeHandle handle handle_
- ioe_closedHandle "hIsTerminalDevice" handle
- other -> do
- rc <- CCALL(isTerminalDevice) (haFO__ handle_) -- ConcHask: SAFE, won't block
- writeHandle handle handle_
- case rc of
+ withHandle_ handle $ \ handle_ -> do
+ case haType__ handle_ of
+ 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"
hConnectTo hW hR = hConnectHdl_ hW hR 0{-connect regardless-}
hConnectHdl_ :: Handle -> Handle -> Int -> IO ()
-hConnectHdl_ hW hR is_tty =
- wantWriteableHandle "hConnectTo" hW $ \ hW_ -> do
- wantReadableHandle "hConnectTo" hR $ \ hR_ -> do
- CCALL(setConnectedTo) (haFO__ hR_) (haFO__ hW_) is_tty -- ConcHask: SAFE, won't block
- writeHandle hR hR_
- writeHandle hW hW_
-
+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.
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_
- if rc == (-1)
+ rc <- ungetChar (haFO__ handle_) c -- ConcHask: SAFE, won't block
+ if rc == ((-1)::Int)
then constructErrorAndFail "hUngetChar"
else return ()
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 <- malloc sz_i
if chunk == nullAddr
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
+ 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 = fail (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
- then return rc
- else constructErrorAndFail "hFillBufBA"
-#endif
-
-hFillBuf :: Handle -> Addr -> Int -> IO Int
-hFillBuf handle buf sz
- | sz <= 0 = fail (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
- then return ()
- else constructErrorAndFail "hPutBuf"
-
-#ifndef __HUGS__ /* Another 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
- then return ()
- else constructErrorAndFail "hPutBuf"
-#endif
\end{code}
Sometimes it's useful to get at the file descriptor that
\begin{code}
getHandleFd :: Handle -> IO Int
-getHandleFd handle = do
- withHandle handle $ \ handle_ -> do
+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
+ ClosedHandle -> ioe_closedHandle "getHandleFd" handle
_ -> do
- fd <- CCALL(getFileFd) (haFO__ handle_)
- writeHandle handle handle_
+ fd <- getFileFd (haFO__ handle_)
return fd
\end{code}
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
- (fs,[]) -> Nothing
+ (_,[]) -> 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
+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 :: Addr
+
+foreign import ccall "writeErrString__" unsafe
+ writeErrString :: Addr -> 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 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 -> 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
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 -> 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 -> ioError not_writeable_error
+ _ -> 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
+ 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 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
- _ -> 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
\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 (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
-
-#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__
-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 stdcall "libHS_cbits.so" "setBuf" prim_setBuf :: FILE_OBJ -> Addr -> Int -> IO ()
-foreign import stdcall "libHS_cbits.so" "getBufSize" prim_getBufSize :: FILE_OBJ -> IO Int
-foreign import stdcall "libHS_cbits.so" "inputReady" prim_inputReady :: FILE_OBJ -> Int -> IO RC
-foreign import stdcall "libHS_cbits.so" "fileGetc" prim_fileGetc :: FILE_OBJ -> IO Int
-foreign import stdcall "libHS_cbits.so" "fileLookAhead" prim_fileLookAhead :: FILE_OBJ -> IO Int
-foreign import stdcall "libHS_cbits.so" "readBlock" prim_readBlock :: FILE_OBJ -> IO Int
-foreign import stdcall "libHS_cbits.so" "readLine" prim_readLine :: FILE_OBJ -> IO Int
-foreign import stdcall "libHS_cbits.so" "readChar" prim_readChar :: FILE_OBJ -> IO Int
-foreign import stdcall "libHS_cbits.so" "writeFileObject" prim_writeFileObject :: FILE_OBJ -> Int -> IO RC
-foreign import stdcall "libHS_cbits.so" "filePutc" prim_filePutc :: FILE_OBJ -> Char -> IO RC
-foreign import stdcall "libHS_cbits.so" "getBufStart" prim_getBufStart :: FILE_OBJ -> Int -> IO Addr
-foreign import stdcall "libHS_cbits.so" "getWriteableBuf" prim_getWriteableBuf :: FILE_OBJ -> IO Addr
-foreign import stdcall "libHS_cbits.so" "getBufWPtr" prim_getBufWPtr :: FILE_OBJ -> IO Int
-foreign import stdcall "libHS_cbits.so" "setBufWPtr" prim_setBufWPtr :: FILE_OBJ -> Int -> IO ()
-foreign import stdcall "libHS_cbits.so" "closeFile" prim_closeFile :: FILE_OBJ -> Flush -> IO RC
-foreign import stdcall "libHS_cbits.so" "fileEOF" prim_fileEOF :: FILE_OBJ -> IO RC
-foreign import stdcall "libHS_cbits.so" "setBuffering" prim_setBuffering :: FILE_OBJ -> Int -> IO RC
-foreign import stdcall "libHS_cbits.so" "flushFile" prim_flushFile :: FILE_OBJ -> IO RC
-foreign import stdcall "libHS_cbits.so" "getBufferMode" prim_getBufferMode :: FILE_OBJ -> IO RC
-foreign import stdcall "libHS_cbits.so" "seekFile_int64" prim_seekFile_int64 :: FILE_OBJ -> Int -> Int64 -> IO RC
-foreign import stdcall "libHS_cbits.so" "seekFileP" prim_seekFileP :: FILE_OBJ -> IO RC
-foreign import stdcall "libHS_cbits.so" "setTerminalEcho" prim_setTerminalEcho :: FILE_OBJ -> Int -> IO RC
-foreign import stdcall "libHS_cbits.so" "getTerminalEcho" prim_getTerminalEcho :: FILE_OBJ -> IO RC
-foreign import stdcall "libHS_cbits.so" "isTerminalDevice" prim_isTerminalDevice :: FILE_OBJ -> IO RC
-foreign import stdcall "libHS_cbits.so" "setConnectedTo" prim_setConnectedTo :: FILE_OBJ -> FILE_OBJ -> Int -> IO ()
-foreign import stdcall "libHS_cbits.so" "ungetChar" prim_ungetChar :: FILE_OBJ -> Char -> IO RC
-foreign import stdcall "libHS_cbits.so" "readChunk" prim_readChunk :: FILE_OBJ -> Addr -> Int -> IO RC
-foreign import stdcall "libHS_cbits.so" "writeBuf" prim_writeBuf :: FILE_OBJ -> Addr -> Int -> IO RC
-foreign import stdcall "libHS_cbits.so" "getFileFd" prim_getFileFd :: FILE_OBJ -> IO FD
-foreign import stdcall "libHS_cbits.so" "fileSize_int64" prim_fileSize_int64 :: FILE_OBJ -> Bytes -> IO RC
-foreign import stdcall "libHS_cbits.so" "getFilePosn" prim_getFilePosn :: FILE_OBJ -> IO Int
-foreign import stdcall "libHS_cbits.so" "setFilePosn" prim_setFilePosn :: FILE_OBJ -> Int -> IO Int
-foreign import stdcall "libHS_cbits.so" "getConnFileFd" prim_getConnFileFd :: FILE_OBJ -> IO FD
-foreign import stdcall "libHS_cbits.so" "allocMemory__" prim_allocMemory__ :: Int -> IO Addr
-foreign import stdcall "libHS_cbits.so" "getLock" prim_getLock :: FD -> Exclusive -> IO RC
-foreign import stdcall "libHS_cbits.so" "openStdFile" prim_openStdFile :: FD -> OpenStdFlags -> Readable -> IO IOFileAddr
-foreign import stdcall "libHS_cbits.so" "openFile" prim_openFile :: CString -> How -> Binary -> OpenFlags -> IO IOFileAddr
-foreign import stdcall "libHS_cbits.so" "freeFileObject" prim_freeFileObject :: FILE_OBJ -> IO ()
-foreign import stdcall "libHS_cbits.so" "freeStdFileObject" prim_freeStdFileObject :: FILE_OBJ -> IO ()
-foreign import stdcall "libHS_cbits.so" "const_BUFSIZ" const_BUFSIZ :: Int
-
-foreign import stdcall "libHS_cbits.so" "setConnNonBlockingIOFlag__" prim_setConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
-foreign import stdcall "libHS_cbits.so" "clearConnNonBlockingIOFlag__" prim_clearConnNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
-foreign import stdcall "libHS_cbits.so" "setNonBlockingIOFlag__" prim_setNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
-foreign import stdcall "libHS_cbits.so" "clearNonBlockingIOFlag__" prim_clearNonBlockingIOFlag__ :: FILE_OBJ -> IO ()
-
-foreign import stdcall "libHS_cbits.so" "getErrStr__" prim_getErrStr__ :: IO Addr
-foreign import stdcall "libHS_cbits.so" "getErrNo__" prim_getErrNo__ :: IO Int
-foreign import stdcall "libHS_cbits.so" "getErrType__" 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 -> 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
+ 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" "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__" unsafe
+ setBinaryMode :: FILE_OBJECT -> Int -> IO Int
\end{code}
projects / ghc-hetmet.git / blobdiff