+% ------------------------------------------------------------------------------
+% $Id: PrelIO.lhs,v 1.18 2001/01/11 17:25:57 simonmar Exp $
%
-% (c) The GRAP/AQUA Project, Glasgow University, 1992-1996
+% (c) The University of Glasgow, 1992-2000
%
+
\section[PrelIO]{Module @PrelIO@}
This module defines all basic IO operations.
\begin{code}
-{-# OPTIONS -fcompiling-prelude -fno-implicit-prelude -#include "cbits/stgio.h" #-}
+{-# OPTIONS -fno-implicit-prelude -#include "cbits/stgio.h" #-}
module PrelIO where
import PrelHandle -- much of the real stuff is in here
import PrelNum
-import PrelRead ( readParen, Read(..), reads, lex,
- readIO
- )
+import PrelRead ( Read(..), readIO )
import PrelShow
-import PrelMaybe ( Either(..), Maybe(..) )
-import PrelAddr ( Addr(..), AddrOff(..), nullAddr, plusAddr )
-import PrelByteArr ( ByteArray )
-import PrelPack ( unpackNBytesAccST )
-import PrelException ( ioError, catch, catchException, throw, blockAsyncExceptions )
+import PrelMaybe ( Maybe(..) )
+import PrelPtr
+import PrelList ( concat, reverse, null )
+import PrelPack ( unpackNBytesST, unpackNBytesAccST )
+import PrelException ( ioError, catch, catchException, throw )
import PrelConc
-\end{code}
+#ifndef __PARALLEL_HASKELL__
+#define FILE_OBJECT (ForeignPtr ())
+#else
+#define FILE_OBJECT (Ptr ())
+#endif
+\end{code}
%*********************************************************
%* *
EOF and return the partial line. Next attempt at calling
hGetLine on the handle will yield an EOF IO exception though.
-}
+
hGetLine :: Handle -> IO String
hGetLine h = do
+ buffer_mode <- wantReadableHandle "hGetLine" h
+ (\ handle_ -> do return (haBufferMode__ handle_))
+ case buffer_mode of
+ NoBuffering -> hGetLineUnBuffered h
+ LineBuffering -> hGetLineBuf' []
+ BlockBuffering _ -> hGetLineBuf' []
+
+ where hGetLineBuf' xss = do
+ (eol, xss) <- catch
+ ( do
+ mayBlockRead' "hGetLine" h
+ (\fo -> readLine fo)
+ (\fo bytes -> do
+ buf <- getBufStart fo bytes
+ eol <- readCharOffPtr buf (bytes-1)
+ xs <- if (eol == '\n')
+ then stToIO (unpackNBytesST buf (bytes-1))
+ else stToIO (unpackNBytesST buf bytes)
+ return (eol, xs:xss)
+ )
+ )
+ (\e -> if isEOFError e && not (null xss)
+ then return ('\n', xss)
+ else ioError e)
+
+ if (eol == '\n')
+ then return (concat (reverse xss))
+ else hGetLineBuf' xss
+
+
+hGetLineUnBuffered :: Handle -> IO String
+hGetLineUnBuffered h = do
c <- hGetChar h
if c == '\n' then
return ""
s <- getRest
return (c:s)
+
+readCharOffPtr (Ptr a) (I# i)
+ = IO $ \s -> case readCharOffAddr# a i s of { (# s,x #) -> (# s, C# x #) }
\end{code}
@hLookahead hdl@ returns the next character from handle @hdl@
-- the handle.
withHandle handle $ \ handle_ -> do
case haType__ handle_ of
- ErrorHandle theError -> ioError theError
ClosedHandle -> ioe_closedHandle "hGetContents" handle
SemiClosedHandle -> ioe_closedHandle "hGetContents" handle
- AppendHandle -> ioError not_readable_error
- WriteHandle -> ioError not_readable_error
+ AppendHandle -> ioException not_readable_error
+ WriteHandle -> ioException not_readable_error
_ -> do
{-
To avoid introducing an extra layer of buffering here,
return (handle_', str)
where
not_readable_error =
- IOError (Just handle) IllegalOperation "hGetContents"
- ("handle is not open for reading")
+ IOError (Just handle) IllegalOperation "hGetContents"
+ "handle is not open for reading" Nothing
\end{code}
Note that someone may close the semi-closed handle (or change its buffering),
the handle has indeed been closed.
\begin{code}
-#ifndef __PARALLEL_HASKELL__
-lazyReadBlock :: Handle -> ForeignObj -> IO String
-lazyReadLine :: Handle -> ForeignObj -> IO String
-lazyReadChar :: Handle -> ForeignObj -> IO String
-#else
-lazyReadBlock :: Handle -> Addr -> IO String
-lazyReadLine :: Handle -> Addr -> IO String
-lazyReadChar :: Handle -> Addr -> IO String
-#endif
+lazyReadBlock :: Handle -> FILE_OBJECT -> IO String
+lazyReadLine :: Handle -> FILE_OBJECT -> IO String
+lazyReadChar :: Handle -> FILE_OBJECT -> IO String
lazyReadBlock handle fo = do
buf <- getBufStart fo 0
-1 -> -- an error occurred, close the handle
withHandle handle $ \ handle_ -> do
closeFile (haFO__ handle_) 0{-don't bother flushing-} -- ConcHask: SAFE, won't block.
- return (handle_ { haType__ = ClosedHandle,
- haFO__ = nullFile__ },
- "")
+ return (handle_ { haType__ = ClosedHandle }, "")
_ -> do
more <- unsafeInterleaveIO (lazyReadBlock handle fo)
stToIO (unpackNBytesAccST buf bytes more)
-1 -> -- an error occurred, close the handle
withHandle handle $ \ handle_ -> do
closeFile (haFO__ handle_) 0{- don't bother flushing-} -- ConcHask: SAFE, won't block
- return (handle_ { haType__ = ClosedHandle,
- haFO__ = nullFile__ },
- "")
+ return (handle_ { haType__ = ClosedHandle }, "")
_ -> do
more <- unsafeInterleaveIO (lazyReadLine handle fo)
buf <- getBufStart fo bytes -- ConcHask: won't block
-1 -> -- error, silently close handle.
withHandle handle $ \ handle_ -> do
closeFile (haFO__ handle_) 0{-don't bother flusing-} -- ConcHask: SAFE, won't block
- return (handle_{ haType__ = ClosedHandle,
- haFO__ = nullFile__ },
- "")
+ return (handle_{ haType__ = ClosedHandle }, "")
_ -> do
more <- unsafeInterleaveIO (lazyReadChar handle fo)
return (chr char : more)
-- 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__ -> IO (Handle__, (BufferMode, Ptr (), 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))
+ NoBuffering -> return (handle_, (mode, nullPtr, 0))
_ -> case bufs of
- [] -> do buf <- allocMemory__ sz
+ [] -> do buf <- malloc sz
return (handle_, (mode, buf, sz))
(b:bs) -> return (handle_{ haBuffers__ = bs }, (mode, b, sz))
-freeBuffer :: Handle__ -> Addr -> Int -> IO Handle__
+freeBuffer :: Handle__ -> Ptr () -> 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__ -> Ptr () -> 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
+-------------------------------------------------------------------------------
+-- commitAndReleaseBuffer 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).
commitAndReleaseBuffer
:: Handle -- handle to commit to
- -> Addr -> Int -- address and size (in bytes) of buffer
+ -> Ptr () -> 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.
+ -- First deal with any possible exceptions, by freeing the buffer.
-- Async exceptions are blocked, but there are still some interruptible
-- ops below.
let ok h_ = putMVar h h_ >> return ()
- if (fo_bufSize - fo_wptr < count) -- not enough room in handle buffer?
+ -- enough room in handle buffer for the new data?
+ if (flush || fo_bufSize - fo_wptr <= count)
+
+ -- The <= is to be sure that we never exactly fill up the
+ -- buffer, which would require a flush. So if copying the
+ -- new data into the buffer would make the buffer full, we
+ -- just flush the existing buffer and the new data immediately,
+ -- rather than copying before flushing.
then do rc <- mayBlock fo (flushFile fo)
if (rc < 0)
- then constructErrorAndFail "commitBuffer"
+ then constructErrorAndFail "commitAndReleaseBuffer"
else
- if flush || sz /= fo_bufSize
+ if (flush || sz /= fo_bufSize || count == sz)
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...
+ then constructErrorAndFail "commitAndReleaseBuffer"
+ else do handle_ <- freeBuffer handle_ buf sz
+ ok handle_
+
+ -- if: (a) we don't have to flush, and
+ -- (b) size(new buffer) == size(old buffer), and
+ -- (c) new buffer is not full,
+ -- we can just just swap them over...
else do handle_ <- swapBuffers handle_ buf sz
setBufWPtr fo count
ok handle_
- else do memcpy (plusAddr fo_buf (AddrOff# fo_wptr)) buf count
+ -- not flushing, and there's enough room in the buffer:
+ -- just copy the data in and update bufWPtr.
+ else do memcpy (plusPtr fo_buf 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_
+ handle_ <- freeBuffer handle_ buf sz
+ ok handle_
+
+--------------------------------------------------------------------------------
+-- commitBuffer handle buf sz count flush
+--
+-- Flushes 'count' bytes from the buffer 'buf' (size 'sz') to 'handle'.
+-- There are several cases to consider altogether:
+--
+-- If flush,
+-- - flush handle buffer,
+-- - write out new buffer directly
+--
+-- else
+-- - if there's enough room in the handle buffer,
+-- then copy new buf into it
+-- else flush handle buffer, then copy new buffer into it
+--
+-- Make sure that we maintain the invariant that the handle buffer is never
+-- left in a full state. Several functions rely on this (eg. filePutc), so
+-- if we're about to exactly fill the buffer then we make sure we do a flush
+-- here (also see above in commitAndReleaseBuffer).
commitBuffer
:: Handle -- handle to commit to
- -> Addr -> Int -- address and size (in bytes) of buffer
+ -> Ptr () -> 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_
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)
+ new_wptr <- -- not enough room in handle buffer?
+ (if flush || (fo_bufSize - fo_wptr <= count)
+ then do rc <- mayBlock fo (flushFile fo)
+ if (rc < 0) then constructErrorAndFail "commitBuffer"
+ else return 0
+ else return fo_wptr )
- if (fo_bufSize < count) -- committed buffer too large?
+ if (flush || fo_bufSize <= count) -- committed buffer too large?
then do rc <- write_buf fo buf count
- if rc < 0 then constructErrorAndFail "commitBuffer"
- else return ()
+ 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)
+ else do memcpy (plusPtr fo_buf new_wptr) buf count
+ setBufWPtr fo (new_wptr + count)
return ()
write_buf fo buf 0 = return 0
then write_buf fo buf (count - rc) -- partial write
else return rc
-foreign import "memcpy" unsafe memcpy :: Addr -> Addr -> Int -> IO ()
+-- a version of commitBuffer that will free the buffer if an exception is
+-- received. DON'T use this if you intend to use the buffer again!
+checkedCommitBuffer handle buf sz count flush
+ = catchException (commitBuffer handle buf sz count flush)
+ (\e -> do withHandle__ handle (\h_ -> freeBuffer h_ buf sz)
+ throw e)
+
+foreign import "memcpy" unsafe memcpy :: Ptr () -> Ptr () -> 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
-writeLines :: Handle -> Addr -> Int -> String -> IO ()
+writeLines :: Handle -> Ptr () -> Int -> String -> IO ()
writeLines handle buf bufLen s =
let
shoveString :: Int -> [Char] -> IO ()
let next_n = n + 1
if next_n == bufLen || x == '\n'
then do
- commitBuffer hdl buf len next_n True{-needs flush-}
+ checkedCommitBuffer hdl buf len next_n True{-needs flush-}
shoveString 0 xs
else
shoveString next_n xs
#else /* ndef __HUGS__ */
-writeLines :: Handle -> Addr -> Int -> String -> IO ()
+writeLines :: Handle -> Ptr () -> Int -> String -> IO ()
writeLines hdl buf len@(I# bufLen) s =
let
shoveString :: Int# -> [Char] -> IO ()
let next_n = n +# 1#
if next_n ==# bufLen || x `eqChar#` '\n'#
then do
- commitBuffer hdl buf len (I# next_n) True{-needs flush-}
+ checkedCommitBuffer hdl buf len (I# next_n) True{-needs flush-}
shoveString 0# xs
else
shoveString next_n xs
#endif /* ndef __HUGS__ */
#ifdef __HUGS__
-writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
+writeBlocks :: Handle -> Ptr () -> Int -> String -> IO ()
writeBlocks hdl buf bufLen s =
let
shoveString :: Int -> [Char] -> IO ()
let next_n = n + 1
if next_n == bufLen
then do
- commitBuffer hdl buf len next_n True{-needs flush-}
+ checkedCommitBuffer hdl buf len next_n True{-needs flush-}
shoveString 0 xs
else
shoveString next_n xs
#else /* ndef __HUGS__ */
-writeBlocks :: Handle -> Addr -> Int -> String -> IO ()
+writeBlocks :: Handle -> Ptr () -> Int -> String -> IO ()
writeBlocks hdl buf len@(I# bufLen) s =
let
shoveString :: Int# -> [Char] -> IO ()
let next_n = n +# 1#
if next_n ==# bufLen
then do
- commitBuffer hdl buf len (I# next_n) True{-needs flush-}
+ checkedCommitBuffer hdl buf len (I# next_n) True{-needs flush-}
shoveString 0# xs
else
shoveString next_n xs
in
shoveString 0# s
-write_char :: Addr -> Int# -> Char# -> IO ()
-write_char (A# buf#) n# c# =
+write_char :: Ptr () -> Int# -> Char# -> IO ()
+write_char (Ptr buf#) n# c# =
IO $ \ s# ->
case (writeCharOffAddr# buf# n# c# s#) of s2# -> (# s2#, () #)
#endif /* ndef __HUGS__ */
projects / ghc-hetmet.git / blobdiff