import PrelConc
#ifndef __PARALLEL_HASKELL__
-import PrelForeign ( makeForeignObj )
+import PrelForeign ( makeForeignObj, mkForeignObj )
#endif
#endif /* ndef(__HUGS__) */
\begin{code}
withHandle :: Handle -> (Handle__ -> IO (Handle__,a)) -> IO a
{-# INLINE withHandle #-}
-withHandle (Handle h) act = do
+withHandle (Handle h) act =
+ blockAsyncExceptions $ do
h_ <- takeMVar h
(h',v) <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
putMVar h h'
withHandle_ :: Handle -> (Handle__ -> IO a) -> IO a
{-# INLINE withHandle_ #-}
-withHandle_ (Handle h) act = do
+withHandle_ (Handle h) act =
+ blockAsyncExceptions $ do
h_ <- takeMVar h
v <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
putMVar h h_
withHandle__ :: Handle -> (Handle__ -> IO Handle__) -> IO ()
{-# INLINE withHandle__ #-}
-withHandle__ (Handle h) act = do
+withHandle__ (Handle h) act =
+ blockAsyncExceptions $ do
h_ <- takeMVar h
h' <- catchException (act h_) (\ ex -> putMVar h h_ >> throw ex)
putMVar h h'
mkClosedHandle__ :: Handle__
mkClosedHandle__ =
- Handle__
- nullFile__
- ClosedHandle
- NoBuffering
- "closed file"
+ Handle__ { haFO__ = nullFile__,
+ haType__ = ClosedHandle,
+ haBufferMode__ = NoBuffering,
+ haFilePath__ = "closed file",
+ haBuffers__ = []
+ }
mkErrorHandle__ :: IOError -> Handle__
mkErrorHandle__ ioe =
- Handle__
- nullFile__
- (ErrorHandle ioe)
- NoBuffering
- "error handle"
+ Handle__ { haFO__ = nullFile__,
+ haType__ = (ErrorHandle ioe),
+ haBufferMode__ = NoBuffering,
+ haFilePath__ = "error handle",
+ haBuffers__ = []
+ }
\end{code}
%*********************************************************
%*********************************************************
\begin{code}
+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 :: Addr -> IO ()
+ freeStdFileObject :: FILE_OBJECT -> IO ()
foreign import "libHS_cbits" "freeFileObject" unsafe
- freeFileObject :: Addr -> IO ()
-
+ 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 (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")
+ hdl <- newHandle (Handle__ fo WriteHandle bm "stdout" [])
+
+#ifndef __PARALLEL_HASKELL__
+ addForeignFinalizer fo (stdHandleFinalizer hdl)
+#endif
+ return hdl
+
_ -> do ioError <- constructError "stdout"
newHandle (mkErrorHandle__ ioError)
)
(1::Int){-readable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- makeForeignObj 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"
(0::Int){-writeable-} -- ConcHask: SAFE, won't block
#ifndef __PARALLEL_HASKELL__
- fo <- makeForeignObj 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
(binary::Int) -- ConcHask: SAFE, won't block
if fo /= nullAddr then do
#ifndef __PARALLEL_HASKELL__
- fo <- makeForeignObj 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
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:
then constructErrorAndFail "slurpFile"
else return (chunk, rc)
-#ifndef __HUGS__ /* Hugs' Prelude doesn't need this */
-hFillBufBA :: Handle -> MutableByteArray RealWorld a -> 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 = hFillBuf' sz 0
- where
- hFillBuf' sz len = do
- r <- mayBlockRead "hFillBufBA" handle (\fo -> readChunkBA fo buf len sz)
- if r >= sz || r == 0 -- r == 0 indicates EOF
- then return (len+r)
- else hFillBuf' (sz-r) (len+r)
-#endif
-
-hFillBuf :: Handle -> Addr -> Int -> IO Int
-hFillBuf handle buf sz
- | sz <= 0 = ioError (IOError (Just handle)
- InvalidArgument
- "hFillBuf"
- ("illegal buffer size " ++ showsPrec 9 sz []))
- -- 9 => should be parens'ified.
- | otherwise = hFillBuf' sz 0
- where
- hFillBuf' sz len = do
- r <- mayBlockRead "hFillBuf" handle (\fo -> readChunk fo buf len sz)
- if r >= sz || r == 0 -- r == 0 indicates EOF
- then return (len+r)
- else hFillBuf' (sz-r) (len+r)
-\end{code}
-
-The @hPutBuf hdl buf len@ action writes an already packed sequence of
-bytes to the file/channel managed by @hdl@ - non-standard.
-
-\begin{code}
-hPutBuf :: Handle -> Addr -> Int -> IO ()
-hPutBuf handle buf sz
- | sz <= 0 = ioError (IOError (Just handle)
- InvalidArgument
- "hPutBuf"
- ("illegal buffer size " ++ showsPrec 9 sz []))
- -- 9 => should be parens'ified.
- | otherwise = hPutBuf' sz 0
- where
- hPutBuf' sz len = do
- r <- mayBlockWrite "hPutBuf" handle (\fo -> writeBuf fo buf len sz)
- if r >= sz
- then return ()
- else hPutBuf' (sz-r) (len+r) -- <= sz indicates blocking
-
-#ifndef __HUGS__ /* An_ one Hugs doesn't provide */
-hPutBufBA :: Handle -> MutableByteArray RealWorld a -> Int -> IO ()
-hPutBufBA handle buf sz
- | sz <= 0 = ioError (IOError (Just handle)
- InvalidArgument
- "hPutBufBA"
- ("illegal buffer size " ++ showsPrec 9 sz []))
- -- 9 => should be parens'ified.
- | otherwise = hPutBuf' sz 0
- where
- hPutBuf' sz len = do
- r <- mayBlockWrite "hPutBufBA" handle (\fo -> writeBufBA fo buf len sz)
- if r >= sz
- then return ()
- else hPutBuf' (sz-r) (len+r) -- <= sz indicates blocking
-#endif
\end{code}
Sometimes it's useful to get at the file descriptor that
wantWriteableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a
wantWriteableHandle fun handle act =
- withHandle_ handle $ \ handle_ -> do
- case haType__ handle_ of
+ 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
ErrorHandle theError -> ioError theError
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
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
ungetChar :: FILE_OBJECT -> Char -> IO Int{-ret code-}
foreign import "libHS_cbits" "readChunk" unsafe
readChunk :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-}
-foreign import "libHS_cbits" "readChunk" unsafe
- readChunkBA :: FILE_OBJECT -> MutableByteArray s a -> Int -> Int -> IO Int{-ret code-}
-foreign import "libHS_cbits" "writeBuf" unsafe
- writeBuf :: FILE_OBJECT -> Addr -> Int -> Int -> IO Int{-ret code-}
-#ifndef __HUGS__
-foreign import "libHS_cbits" "writeBufBA" unsafe
- writeBufBA :: FILE_OBJECT -> MutableByteArray s a -> Int -> Int -> IO Int{-ret code-}
-#endif
foreign import "libHS_cbits" "getFileFd" unsafe
getFileFd :: FILE_OBJECT -> IO Int{-fd-}
#ifdef __HUGS__
import PrelIOBase
import PrelHandle -- much of the real stuff is in here
+import PrelNum
import PrelRead ( readParen, Read(..), reads, lex,
readIO
)
import PrelShow
import PrelMaybe ( Either(..), Maybe(..) )
-import PrelAddr ( Addr(..), nullAddr )
+import PrelAddr ( Addr(..), AddrOff(..), nullAddr, plusAddr )
import PrelByteArr ( ByteArray )
import PrelPack ( unpackNBytesAccST )
-import PrelException ( ioError, catch )
+import PrelException ( ioError, catch, catchException, throw, blockAsyncExceptions )
import PrelConc
\end{code}
-
%*********************************************************
%* *
\subsection{Standard IO}
\begin{code}
hPutChar :: Handle -> Char -> IO ()
hPutChar handle c =
+ c `seq` do -- must evaluate c before grabbing the handle lock
wantWriteableHandle "hPutChar" handle $ \ handle_ -> do
let fo = haFO__ handle_
flushConnectedBuf fo
- rc <- mayBlock fo (filePutc fo c) -- ConcHask: UNSAFE, may block.
+ rc <- mayBlock fo (filePutc fo c) -- ConcHask: UNSAFE, may block.
if rc == 0
then return ()
else constructErrorAndFail "hPutChar"
+hPutChars :: Handle -> [Char] -> IO ()
+hPutChars handle [] = return ()
+hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs
\end{code}
@hPutStr hdl s@ writes the string @s@ to the file or
channel managed by @hdl@, buffering the output if needs be.
+
\begin{code}
hPutStr :: Handle -> String -> IO ()
-hPutStr handle str =
- wantWriteableHandle "hPutStr" handle $ \ handle_ -> do
- let fo = haFO__ handle_
- flushConnectedBuf fo
- case haBufferMode__ handle_ of
- LineBuffering -> do
- buf <- getWriteableBuf fo
- pos <- getBufWPtr fo
- bsz <- getBufSize fo
- writeLines fo buf bsz pos str
- BlockBuffering _ -> do
- buf <- getWriteableBuf fo
- pos <- getBufWPtr fo
- bsz <- getBufSize fo
- writeBlocks fo buf bsz pos str
- NoBuffering -> do
- writeChars fo str
+hPutStr handle str = do
+ buffer_mode <- wantWriteableHandle_ "hPutStr" handle
+ (\ handle_ -> do getBuffer handle_)
+ case buffer_mode of
+ (NoBuffering, _, _) -> do
+ hPutChars handle str -- v. slow, but we don't care
+ (LineBuffering, buf, bsz) -> do
+ writeLines handle buf bsz str
+ (BlockBuffering _, buf, bsz) -> do
+ writeBlocks handle buf bsz str
+ -- ToDo: async exceptions during writeLines & writeBlocks will cause
+ -- the buffer to get lost in the void. Using ByteArrays instead of
+ -- malloced buffers is one way around this, but we really ought to
+ -- be able to handle it with exception handlers/block/unblock etc.
+
+getBuffer :: Handle__ -> IO (Handle__, (BufferMode, Addr, Int))
+getBuffer handle_ = do
+ let bufs = haBuffers__ handle_
+ fo = haFO__ handle_
+ mode = haBufferMode__ handle_
+ sz <- getBufSize fo
+ case mode of
+ NoBuffering -> return (handle_, (mode, nullAddr, 0))
+ _ -> case bufs of
+ [] -> do buf <- allocMemory__ sz
+ return (handle_, (mode, buf, sz))
+ (b:bs) -> return (handle_{ haBuffers__ = bs }, (mode, b, sz))
+
+freeBuffer :: Handle__ -> Addr -> Int -> IO Handle__
+freeBuffer handle_ buf sz = do
+ fo_sz <- getBufSize (haFO__ handle_)
+ if (sz /= fo_sz)
+ then do { free buf; return handle_ }
+ else do { return handle_{ haBuffers__ = buf : haBuffers__ handle_ } }
+
+swapBuffers :: Handle__ -> Addr -> Int -> IO Handle__
+swapBuffers handle_ buf sz = do
+ let fo = haFO__ handle_
+ fo_buf <- getBuf fo
+ setBuf fo buf sz
+ return (handle_{ haBuffers__ = fo_buf : haBuffers__ handle_ })
+
+-- commitBuffer handle buf sz count flush
+--
+-- Write the contents of the buffer 'buf' ('sz' bytes long, containing
+-- 'count' bytes of data) to handle (handle must be block or line buffered).
+--
+-- Implementation:
+--
+-- for block/line buffering,
+-- 1. If there isn't room in the handle buffer, flush the handle
+-- buffer.
+--
+-- 2. If the handle buffer is empty,
+-- if flush,
+-- then write buf directly to the device.
+-- else swap the handle buffer with buf.
+--
+-- 3. If the handle buffer is non-empty, copy buf into the
+-- handle buffer. Then, if flush != 0, flush
+-- the buffer.
+
+commitAndReleaseBuffer
+ :: Handle -- handle to commit to
+ -> Addr -> Int -- address and size (in bytes) of buffer
+ -> Int -- number of bytes of data in buffer
+ -> Bool -- flush the handle afterward?
+ -> IO ()
+commitAndReleaseBuffer hdl@(Handle h) buf sz count flush = do
+ h_ <- takeMVar h
+
+ -- First deal with any possible exceptions by freeing the buffer.
+ -- Async exceptions are blocked, but there are still some interruptible
+ -- ops below.
+
+ -- note that commit doesn't *always* free the buffer, it might
+ -- swap it for the current handle buffer instead. This makes things
+ -- a whole lot more complicated, because we can't just do
+ -- "finally (... free buffer ...)" here.
+ catchException (commit hdl h_)
+ (\e -> do { h_ <- freeBuffer h_ buf sz; putMVar h h_ })
+
+ where
+ commit hdl@(Handle h) handle_ =
+ checkWriteableHandle "commitAndReleaseBuffer" hdl handle_ $ do
+ let fo = haFO__ handle_
+ flushConnectedBuf fo -- ???? -SDM
+ getWriteableBuf fo -- flush read buf if necessary
+ fo_buf <- getBuf fo
+ fo_wptr <- getBufWPtr fo
+ fo_bufSize <- getBufSize fo
+
+ let ok h_ = putMVar h h_ >> return ()
+
+ if (fo_bufSize - fo_wptr < count) -- not enough room in handle buffer?
+
+ then do rc <- mayBlock fo (flushFile fo)
+ if (rc < 0)
+ then constructErrorAndFail "commitBuffer"
+ else
+ if flush || sz /= fo_bufSize
+ then do rc <- write_buf fo buf count
+ if (rc < 0)
+ then constructErrorAndFail "commitBuffer"
+ else do handle_ <- freeBuffer handle_ buf sz
+ ok handle_
+
+ -- don't have to flush, and the new buffer is the
+ -- same size as the old one, so just swap them...
+ else do handle_ <- swapBuffers handle_ buf sz
+ setBufWPtr fo count
+ ok handle_
+
+ else do memcpy (plusAddr fo_buf (AddrOff# fo_wptr)) buf count
+ setBufWPtr fo (fo_wptr + count)
+ if flush
+ then do rc <- mayBlock fo (flushFile fo)
+ if (rc < 0)
+ then constructErrorAndFail "commitBuffer"
+ else do handle_ <- freeBuffer handle_ buf sz
+ ok handle_
+ else do handle_ <- freeBuffer handle_ buf sz
+ ok handle_
+
+commitBuffer
+ :: Handle -- handle to commit to
+ -> Addr -> Int -- address and size (in bytes) of buffer
+ -> Int -- number of bytes of data in buffer
+ -> Bool -- flush the handle afterward?
+ -> IO ()
+commitBuffer handle buf sz count flush = do
+ wantWriteableHandle "commitBuffer" handle $ \handle_ -> do
+ let fo = haFO__ handle_
+ flushConnectedBuf fo -- ???? -SDM
+ getWriteableBuf fo -- flush read buf if necessary
+ fo_buf <- getBuf fo
+ fo_wptr <- getBufWPtr fo
+ fo_bufSize <- getBufSize fo
+
+ (if (fo_bufSize - fo_wptr < count) -- not enough room in handle buffer?
+ then mayBlock fo (flushFile fo)
+ else return 0)
+
+ if (fo_bufSize < count) -- committed buffer too large?
+
+ then do rc <- write_buf fo buf count
+ if rc < 0 then constructErrorAndFail "commitBuffer"
+ else return ()
+
+ else do memcpy (plusAddr fo_buf (AddrOff# fo_wptr)) buf count
+ setBufWPtr fo (fo_wptr + count)
+ (if flush then mayBlock fo (flushFile fo) else return 0)
+ return ()
+
+write_buf fo buf 0 = return 0
+write_buf fo buf count = do
+ rc <- mayBlock fo (write_ fo buf count)
+ if (rc > 0)
+ then write_buf fo buf (count - rc) -- partial write
+ else return rc
+
+foreign import "memcpy" unsafe memcpy :: Addr -> Addr -> Int -> IO ()
\end{code}
Going across the border between Haskell and C is relatively costly,
#warning delayed update of buffer disnae work with killThread
#endif
-#ifndef __PARALLEL_HASKELL__
-writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
-#else
-writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
-#endif
-writeLines obj buf bufLen initPos s =
+writeLines :: Handle -> Addr -> Int -> String -> IO ()
+writeLines handle buf bufLen s =
let
shoveString :: Int -> [Char] -> IO ()
shoveString n ls =
case ls of
- [] ->
- {-
- At the end of a buffer write, update the buffer position
- in the underlying file object, so that if the handle
- is subsequently dropped by the program, the whole
- buffer will be properly flushed.
-
- There's one case where this delayed up-date of the buffer
- position can go wrong: if a thread is killed, it might be
- in the middle of filling up a buffer, with the result that
- the partial buffer update is lost upon finalisation. Not
- that killing of threads is supported at the moment.
-
- -}
- setBufWPtr obj n
+ [] -> commitAndReleaseBuffer handle buf buflen n False{-no need to flush-}
(x:xs) -> do
primWriteCharOffAddr buf n x
{- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
- if n == bufLen || x == '\n'
+ let next_n = n + 1
+ if next_n == bufLen || x == '\n'
then do
- rc <- mayBlock obj (writeFileObject obj (n + 1)) -- ConcHask: UNSAFE, may block.
- if rc == 0
- then shoveString 0 xs
- else constructErrorAndFail "writeLines"
+ commitBuffer hdl buf len next_n True{-needs flush-}
+ shoveString 0 xs
else
- shoveString (n + 1) xs
+ shoveString next_n xs
in
- shoveString initPos s
+ shoveString 0 s
+
#else /* ndef __HUGS__ */
-#ifndef __PARALLEL_HASKELL__
-writeLines :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
-#else
-writeLines :: Addr -> Addr -> Int -> Int -> String -> IO ()
-#endif
-writeLines obj buf (I# bufLen) (I# initPos#) s =
- let
- write_char :: Addr -> Int# -> Char# -> IO ()
- write_char (A# buf#) n# c# =
- IO $ \ s# ->
- case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
+writeLines :: Handle -> Addr -> Int -> String -> IO ()
+writeLines hdl buf len@(I# bufLen) s =
+ let
shoveString :: Int# -> [Char] -> IO ()
shoveString n ls =
case ls of
- [] ->
- {-
- At the end of a buffer write, update the buffer position
- in the underlying file object, so that if the handle
- is subsequently dropped by the program, the whole
- buffer will be properly flushed.
-
- There's one case where this delayed up-date of the buffer
- position can go wrong: if a thread is killed, it might be
- in the middle of filling up a buffer, with the result that
- the partial buffer update is lost upon finalisation. Not
- that killing of threads is supported at the moment.
-
- -}
- setBufWPtr obj (I# n)
+ [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-}
((C# x):xs) -> do
write_char buf n x
- {- Flushing on buffer exhaustion or newlines (even if it isn't the last one) -}
- if n ==# bufLen || x `eqChar#` '\n'#
+ -- Flushing on buffer exhaustion or newlines
+ -- (even if it isn't the last one)
+ let next_n = n +# 1#
+ if next_n ==# bufLen || x `eqChar#` '\n'#
then do
- rc <- mayBlock obj (writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
- if rc == 0
- then shoveString 0# xs
- else constructErrorAndFail "writeLines"
+ commitBuffer hdl buf len (I# next_n) True{-needs flush-}
+ shoveString 0# xs
else
- shoveString (n +# 1#) xs
+ shoveString next_n xs
in
- shoveString initPos# s
+ shoveString 0# s
#endif /* ndef __HUGS__ */
#ifdef __HUGS__
-#ifndef __PARALLEL_HASKELL__
-writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
-#else
-writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
-#endif
-writeBlocks obj buf bufLen initPos s =
+writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
+writeBlocks hdl buf bufLen s =
let
shoveString :: Int -> [Char] -> IO ()
shoveString n ls =
case ls of
- [] ->
- {-
- At the end of a buffer write, update the buffer position
- in the underlying file object, so that if the handle
- is subsequently dropped by the program, the whole
- buffer will be properly flushed.
-
- There's one case where this delayed up-date of the buffer
- position can go wrong: if a thread is killed, it might be
- in the middle of filling up a buffer, with the result that
- the partial buffer update is lost upon finalisation. However,
- by the time killThread is supported, Haskell finalisers are also
- likely to be in, which means the 'IOFileObject' hack can go
- alltogether.
-
- -}
- setBufWPtr obj n
+ [] -> commitAndReleaseBuffer hdl buf len n False{-no need to flush-}
(x:xs) -> do
primWriteCharOffAddr buf n x
- if n == bufLen
+ let next_n = n + 1
+ if next_n == bufLen
then do
- rc <- mayBlock obj (writeFileObject obj (n + 1)) -- ConcHask: UNSAFE, may block.
- if rc == 0
- then shoveString 0 xs
- else constructErrorAndFail "writeChunks"
+ commitBuffer hdl buf len next_n True{-needs flush-}
+ shoveString 0 xs
else
- shoveString (n + 1) xs
+ shoveString next_n xs
in
- shoveString initPos s
+ shoveString 0 s
+
#else /* ndef __HUGS__ */
-#ifndef __PARALLEL_HASKELL__
-writeBlocks :: ForeignObj -> Addr -> Int -> Int -> String -> IO ()
-#else
-writeBlocks :: Addr -> Addr -> Int -> Int -> String -> IO ()
-#endif
-writeBlocks obj buf (I# bufLen) (I# initPos#) s =
- let
- write_char :: Addr -> Int# -> Char# -> IO ()
- write_char (A# buf#) n# c# =
- IO $ \ s# ->
- case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
+writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
+writeBlocks hdl buf len@(I# bufLen) s =
+ let
shoveString :: Int# -> [Char] -> IO ()
shoveString n ls =
case ls of
- [] ->
- {-
- At the end of a buffer write, update the buffer position
- in the underlying file object, so that if the handle
- is subsequently dropped by the program, the whole
- buffer will be properly flushed.
-
- There's one case where this delayed up-date of the buffer
- position can go wrong: if a thread is killed, it might be
- in the middle of filling up a buffer, with the result that
- the partial buffer update is lost upon finalisation. However,
- by the time killThread is supported, Haskell finalisers are also
- likely to be in, which means the 'IOFileObject' hack can go
- alltogether.
-
- -}
- setBufWPtr obj (I# n)
+ [] -> commitAndReleaseBuffer hdl buf len (I# n) False{-no need to flush-}
((C# x):xs) -> do
write_char buf n x
- if n ==# bufLen
+ let next_n = n +# 1#
+ if next_n ==# bufLen
then do
- rc <- mayBlock obj (writeFileObject obj (I# (n +# 1#))) -- ConcHask: UNSAFE, may block.
- if rc == 0
- then shoveString 0# xs
- else constructErrorAndFail "writeChunks"
+ commitBuffer hdl buf len (I# next_n) True{-needs flush-}
+ shoveString 0# xs
else
- shoveString (n +# 1#) xs
+ shoveString next_n xs
in
- shoveString initPos# s
-#endif /* ndef __HUGS__ */
-
-#ifndef __PARALLEL_HASKELL__
-writeChars :: ForeignObj -> String -> IO ()
-#else
-writeChars :: Addr -> String -> IO ()
-#endif
-writeChars _fo "" = return ()
-writeChars fo (c:cs) = do
- rc <- mayBlock fo (filePutc fo c) -- ConcHask: UNSAFE, may block.
- if rc == 0
- then writeChars fo cs
- else constructErrorAndFail "writeChars"
+ shoveString 0# s
+write_char :: Addr -> Int# -> Char# -> IO ()
+write_char (A# buf#) n# c# =
+ IO $ \ s# ->
+ case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
+#endif /* ndef __HUGS__ */
\end{code}
Computation @hPrint hdl t@ writes the string representation of {\em t}
% -----------------------------------------------------------------------------
-% $Id: PrelIOBase.lhs,v 1.21 2000/04/10 16:02:58 simonpj Exp $
+% $Id: PrelIOBase.lhs,v 1.22 2000/04/12 17:33:16 simonmar Exp $
%
% (c) The AQUA Project, Glasgow University, 1994-1998
%
haFO__ :: FILE_OBJECT,
haType__ :: Handle__Type,
haBufferMode__ :: BufferMode,
- haFilePath__ :: FilePath
- }
+ haFilePath__ :: FilePath,
+ haBuffers__ :: [Addr]
+ }
{-
Internally, we classify handles as being one
-# $Id: Makefile,v 1.14 2000/03/17 17:05:27 rrt Exp $
+# $Id: Makefile,v 1.15 2000/04/12 17:33:16 simonmar Exp $
TOP = ../../..
include $(TOP)/mk/boilerplate.mk
SRC_MKDEPENDC_OPTS += -I$(GHC_INCLUDE_DIR)
# -----------------------------------------------------------------------------
+
+SO_OBJS = $(C_SRCS:.c=.$(way_)so)
+
+libHS_cbits.so : $(SO_OBJS)
+ $(CC) -shared -o libHS_cbits.so $(SO_OBJS)
+
+CC = $(WhatGccIsCalled)
+
+# -----------------------------------------------------------------------------
# Installation
INSTALL_LIBS+=$(LIBRARY)
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: fileObject.c,v 1.8 1999/11/26 16:25:56 simonmar Exp $
+ * $Id: fileObject.c,v 1.9 2000/04/12 17:33:16 simonmar Exp $
*
* hPutStr Runtime Support
*/
}
}
fo->bufWPtr += count;
+/* TODO: ipos doesn't change???? what's it for??? --SDM */
return (fo->bufWPtr - ipos);
}
int fd;
void* buf;
- int bufStart; /* offset of start of data waiting to
- be written. This may be non-zero in
- the case where we wrote out some of the
- buffer, and then blocked.
-
- NOTE: this field should be non-zero *only*
- when we just blocked on a call to writeBuffer,
- and we're going to restart the call when
- we unblock. It should be zero at all other
- times.
- */
-
int bufWPtr; /* points to next position to write,
bufRPtr >= bufWPtr <= bufSize.
int bufSize;
int flags;
struct _IOFileObject* connectedTo;
+
} IOFileObject;
#define FILEOBJ_LB 2
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: flushFile.c,v 1.6 1999/11/25 16:54:14 simonmar Exp $
+ * $Id: flushFile.c,v 1.7 2000/04/12 17:33:16 simonmar Exp $
*
* hFlush Runtime Support
*/
if (rc<0) return rc;
}
+ /* TODO: shouldn't we do the lseek stuff from flushReadBuffer
+ * here???? --SDM
+ */
+
/* Reset read & write pointer for input buffers */
if ( (fo->flags & FILEOBJ_READ) ) {
fo->bufRPtr=0;
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: openFile.c,v 1.15 1999/12/14 14:26:14 simonmar Exp $
+ * $Id: openFile.c,v 1.16 2000/04/12 17:33:16 simonmar Exp $
*
* openFile Runtime Support
*/
fo->buf = NULL;
fo->bufWPtr = 0;
fo->bufRPtr = 0;
- fo->bufStart = 0;
fo->flags = FILEOBJ_STD | ( rd ? FILEOBJ_READ : FILEOBJ_WRITE);
fo->connectedTo = NULL;
fo->fd = fd;
fo->buf = NULL;
- fo->bufStart = 0;
fo->bufWPtr = 0;
fo->bufRPtr = 0;
fo->flags = flags;
return NULL;
fo->fd = fd;
fo->buf = NULL;
- fo->bufStart = 0;
fo->bufWPtr = 0;
fo->bufRPtr = 0;
fo->flags = flags | ( oflags & O_RDONLY ? FILEOBJ_READ
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: readFile.c,v 1.14 2000/04/04 11:01:33 simonmar Exp $
+ * $Id: readFile.c,v 1.15 2000/04/12 17:33:16 simonmar Exp $
*
* hGetContents Runtime Support
*/
* buffer of connected handle.
* FILEOBJ_BLOCKED_READ didn't read anything; would block
* n, where n > 0 read n bytes into buffer.
+ * 0 EOF has been reached
*/
StgInt
return -2;
if ( FILEOBJ_IS_EOF(fo) ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
+ return 0;
}
/* if input stream is connect to an output stream, flush it first */
/* EOF */
if ( count == 0 ) {
FILEOBJ_SET_EOF(fo);
- if ( total_count == 0 ) {
- ghc_errtype = ERR_EOF;
- ghc_errstr = "";
- return -1;
- } else {
- return total_count;
- }
+ return total_count;
+ }
/* Blocking */
- } else if ( count == -1 && errno == EAGAIN) {
+ else if ( count == -1 && errno == EAGAIN) {
errno = 0;
if (total_count > 0)
return total_count; /* partial read */
else
return FILEOBJ_BLOCKED_READ;
+ }
/* Error */
- } else if ( count == -1 && errno != EINTR) {
+ else if ( count == -1 && errno != EINTR) {
cvtErrno();
stdErrno();
return -1;
fo->flags = (fo->flags & ~FILEOBJ_RW_WRITE) | FILEOBJ_RW_READ;
if ( fo->bufRPtr < 0 || fo->bufRPtr >= fo->bufWPtr ) { /* Buffer is empty */
- fo->bufRPtr=0; fo->bufWPtr=0;
- rc = fill_up_line_buffer(fo);
- if (rc < 0) return rc;
+ fo->bufRPtr=0;
+ fo->bufWPtr=0;
+ rc = fill_up_line_buffer(fo);
+ if (rc < 0) return rc;
}
while (1) {
/* -----------------------------------------------------------------------------
- * $Id: stgio.h,v 1.18 2000/04/11 20:44:18 panne Exp $
+ * $Id: stgio.h,v 1.19 2000/04/12 17:33:16 simonmar Exp $
*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1999
*
StgInt writeBufBA (StgForeignPtr, StgByteArray, StgInt, StgInt);
StgInt writeFileObject (StgForeignPtr, StgInt);
StgInt writeBuffer (StgForeignPtr, StgInt);
+StgInt write_ (StgForeignPtr ptr, StgAddr buf, StgInt len);
#endif /* ! STGIO_H */
/*
* (c) The GRASP/AQUA Project, Glasgow University, 1994-1998
*
- * $Id: writeFile.c,v 1.13 2000/03/10 15:23:40 simonmar Exp $
+ * $Id: writeFile.c,v 1.14 2000/04/12 17:33:16 simonmar Exp $
*
* hPutStr Runtime Support
*/
int count;
IOFileObject* fo = (IOFileObject*)ptr;
- char *pBuf = (char *) fo->buf + fo->bufStart;
+ char *pBuf = (char *) fo->buf + fo->bufRPtr;
- bytes -= fo->bufStart;
+ bytes -= fo->bufRPtr;
/* Disallow short writes */
if (bytes == 0 || fo->buf == NULL) {
- fo->bufStart = 0;
+ fo->bufRPtr = 0;
return 0;
}
else {
bytes -= count;
pBuf += count;
- fo->bufStart += count;
+ fo->bufRPtr += count;
}
}
/* Signal that we've emptied the buffer */
- fo->bufStart = 0;
- fo->bufWPtr = 0;
+ fo->bufRPtr = 0;
+ fo->bufWPtr = 0;
return 0;
}
{
return (writeBuf(ptr,(StgAddr)buf, off, len));
}
+
+/* -----------------------------------------------------------------------------
+ * write_ is just a simple wrapper around write/2 that restarts
+ * on EINTR and returns FILEOBJ_BLOCKED_WRITE on EAGAIN.
+ * -------------------------------------------------------------------------- */
+
+StgInt
+write_(StgForeignPtr ptr, StgAddr buf, StgInt len)
+{
+ IOFileObject* fo = (IOFileObject*)ptr;
+ int rc;
+
+ while ((rc =
+ (
+#ifdef USE_WINSOCK
+ fo->flags & FILEOBJ_WINSOCK ?
+ send(fo->fd, buf, (int)len, 0) :
+ write(fo->fd, buf, (int)len))) < 0 ) {
+#else
+ write(fo->fd, buf, (int)len))) < 0 ) {
+#endif
+ if ( errno == EAGAIN ) {
+ errno = 0;
+ return FILEOBJ_BLOCKED_WRITE;
+ } else if ( errno != EINTR ) {
+ cvtErrno();
+ stdErrno();
+ return -1;
+ }
+ }
+ return rc;
+}
projects / ghc-hetmet.git / commitdiff