+% ------------------------------------------------------------------------------
+% $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.
import PrelIOBase
import PrelHandle -- much of the real stuff is in here
-import PrelRead ( readParen, Read(..), reads, lex,
- readIO
- )
+import PrelNum
+import PrelRead ( Read(..), readIO )
import PrelShow
-import PrelMaybe ( Either(..), Maybe(..) )
-import PrelAddr ( Addr(..), nullAddr )
-import PrelByteArr ( ByteArray )
-import PrelPack ( unpackNBytesAccST )
-import PrelException ( ioError, catch )
+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)
\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, 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, nullPtr, 0))
+ _ -> case bufs of
+ [] -> do buf <- malloc sz
+ return (handle_, (mode, buf, sz))
+ (b:bs) -> return (handle_{ haBuffers__ = bs }, (mode, b, sz))
+
+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__ -> 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_ })
+
+-------------------------------------------------------------------------------
+-- 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).
+--
+-- 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
+ -> 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.
+ -- 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 ()
+
+ -- 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 "commitAndReleaseBuffer"
+ else
+ if (flush || sz /= fo_bufSize || count == sz)
+ then do rc <- write_buf fo buf count
+ if (rc < 0)
+ 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_
+
+ -- 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)
+ 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
+ -> 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_
+ flushConnectedBuf fo -- ???? -SDM
+ getWriteableBuf fo -- flush read buf if necessary
+ fo_buf <- getBuf fo
+ fo_wptr <- getBufWPtr fo
+ fo_bufSize <- getBufSize fo
+
+ 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 (flush || 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 (plusPtr fo_buf new_wptr) buf count
+ setBufWPtr fo (new_wptr + count)
+ 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
+
+-- 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
-#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 -> Ptr () -> 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"
+ checkedCommitBuffer 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 -> Ptr () -> 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"
+ checkedCommitBuffer 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 -> Ptr () -> 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"
+ checkedCommitBuffer 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 -> Ptr () -> 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"
+ checkedCommitBuffer 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 :: Ptr () -> Int# -> Char# -> IO ()
+write_char (Ptr 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}
projects / ghc-hetmet.git / blobdiff