#undef DEBUG_DUMP
-- -----------------------------------------------------------------------------
--- $Id: PrelIO.hsc,v 1.4 2001/05/24 10:41:13 simonmar Exp $
+-- $Id: PrelIO.hsc,v 1.16 2001/09/18 08:32:11 simonmar Exp $
--
-- (c) The University of Glasgow, 1992-2001
--
-- but as it happens they also do everything required by library
-- module IO.
-module PrelIO where
+module PrelIO (
+ putChar, putStr, putStrLn, print, getChar, getLine, getContents,
+ interact, readFile, writeFile, appendFile, readLn, readIO, hReady,
+ hWaitForInput, hGetChar, hGetLine, hGetContents, hPutChar, hPutStr,
+ hPutStrLn, hPrint,
+ commitBuffer', -- hack, see below
+ hGetcBuffered, -- needed by ghc/compiler/utils/StringBuffer.lhs
+ ) where
#include "HsStd.h"
#include "PrelHandle_hsc.h"
import PrelBase
import PrelPosix
-import PrelMarshalAlloc
import PrelMarshalUtils
import PrelStorable
import PrelCError
hGetLineBufferedLoop handle_ ref new_buf (xs:xss)
+maybeFillReadBuffer fd is_line buf
+ = catch
+ (do buf <- fillReadBuffer fd is_line buf
+ return (Just buf)
+ )
+ (\e -> do if isEOFError e
+ then return Nothing
+ else throw e)
+
+
unpack :: RawBuffer -> Int -> Int -> IO [Char]
unpack buf r 0 = return ""
unpack buf (I## r) (I## len) = IO $ \s -> unpack [] (len -## 1##) s
-- carry on writing to it afterwards.
hGetContents :: Handle -> IO String
-hGetContents handle@(DuplexHandle r w)
- = withHandle' "hGetContents" handle r (hGetContents' handle)
-hGetContents handle@(FileHandle m)
- = withHandle' "hGetContents" handle m (hGetContents' handle)
-
-hGetContents' handle handle_ =
+hGetContents handle =
+ withHandle "hGetContents" handle $ \handle_ ->
case haType handle_ of
ClosedHandle -> ioe_closedHandle
SemiClosedHandle -> ioe_closedHandle
lazyRead :: Handle -> IO String
lazyRead handle =
unsafeInterleaveIO $
- withHandle_ "lazyRead" handle $ \ handle_ -> do
+ withHandle "lazyRead" handle $ \ handle_ -> do
case haType handle_ of
- ClosedHandle -> return ""
+ ClosedHandle -> return (handle_, "")
SemiClosedHandle -> lazyRead' handle handle_
_ -> ioException
(IOError (Just handle) IllegalOperation "lazyRead"
-- (see hLookAhead)
buf <- readIORef ref
if not (bufferEmpty buf)
- then lazyReadBuffered h fd ref buf
+ then lazyReadHaveBuffer h handle_ fd ref buf
else do
case haBufferMode handle_ of
-- make use of the minimal buffer we already have
let raw = bufBuf buf
fd = haFD handle_
- r <- throwErrnoIfMinus1RetryMayBlock "hGetChar"
+ r <- throwErrnoIfMinus1RetryMayBlock "lazyRead"
(read_off (fromIntegral fd) raw 0 1)
(threadWaitRead fd)
if r == 0
- then return ""
+ then do handle_ <- hClose_help handle_
+ return (handle_, "")
else do (c,_) <- readCharFromBuffer raw 0
rest <- lazyRead h
- return (c : rest)
+ return (handle_, c : rest)
- LineBuffering -> lazyReadBuffered h fd ref buf
- BlockBuffering _ -> lazyReadBuffered h fd ref buf
+ LineBuffering -> lazyReadBuffered h handle_ fd ref buf
+ BlockBuffering _ -> lazyReadBuffered h handle_ fd ref buf
-- we never want to block during the read, so we call fillReadBuffer with
-- is_line==True, which tells it to "just read what there is".
-lazyReadBuffered h fd ref buf = do
- maybe_new_buf <-
- if bufferEmpty buf
- then maybeFillReadBuffer fd True buf
- else return (Just buf)
- case maybe_new_buf of
- Nothing -> return ""
- Just buf -> do
- more <- lazyRead h
- writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
-
-
-maybeFillReadBuffer fd is_line buf
- = catch
- (do buf <- fillReadBuffer fd is_line buf
- return (Just buf)
- )
- (\e -> if isEOFError e
- then return Nothing
- else throw e)
+lazyReadBuffered h handle_ fd ref buf = do
+ catch
+ (do buf <- fillReadBuffer fd True{-is_line-} buf
+ lazyReadHaveBuffer h handle_ fd ref buf
+ )
+ -- all I/O errors are discarded. Additionally, we close the handle.
+ (\e -> do handle_ <- hClose_help handle_
+ return (handle_, "")
+ )
+
+lazyReadHaveBuffer h handle_ fd ref buf = do
+ more <- lazyRead h
+ writeIORef ref buf{ bufRPtr=0, bufWPtr=0 }
+ s <- unpackAcc (bufBuf buf) (bufRPtr buf) (bufWPtr buf) more
+ return (handle_, s)
unpackAcc :: RawBuffer -> Int -> Int -> [Char] -> IO [Char]
-- check n == len first, to ensure that shoveString is strict in n.
shoveString n cs | n == len = do
new_buf <- commitBuffer hdl raw len n True{-needs flush-} False
- writeBlocks hdl new_buf cs
+ writeLines hdl new_buf cs
shoveString n [] = do
commitBuffer hdl raw len n False{-no flush-} True{-release-}
return ()
shoveString n (c:cs) = do
n' <- writeCharIntoBuffer raw n c
- shoveString n' cs
+ if (c == '\n')
+ then do
+ new_buf <- commitBuffer hdl raw len n' True{-needs flush-} False
+ writeLines hdl new_buf cs
+ else
+ shoveString n' cs
in
shoveString 0 s
:: Handle -- handle to commit to
-> RawBuffer -> Int -- address and size (in bytes) of buffer
-> Int -- number of bytes of data in buffer
- -> Bool -- flush the handle afterward?
+ -> Bool -- True <=> flush the handle afterward
-> Bool -- release the buffer?
-> IO Buffer
-commitBuffer hdl raw sz count flush release = do
- wantWritableHandle "commitAndReleaseBuffer" hdl $
- \ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } -> do
+commitBuffer hdl raw sz@(I## _) count@(I## _) flush release = do
+ wantWritableHandle "commitAndReleaseBuffer" hdl $
+ commitBuffer' hdl raw sz count flush release
+
+-- Explicitly lambda-lift this function to subvert GHC's full laziness
+-- optimisations, which otherwise tends to float out subexpressions
+-- past the \handle, which is really a pessimisation in this case because
+-- that lambda is a one-shot lambda.
+--
+-- Don't forget to export the function, to stop it being inlined too
+-- (this appears to be better than NOINLINE, because the strictness
+-- analyser still gets to worker-wrapper it).
+--
+-- This hack is a fairly big win for hPutStr performance. --SDM 18/9/2001
+--
+commitBuffer' hdl raw sz@(I## _) count@(I## _) flush release
+ handle_@Handle__{ haFD=fd, haBuffer=ref, haBuffers=spare_buf_ref } = do
#ifdef DEBUG_DUMP
puts ("commitBuffer: sz=" ++ show sz ++ ", count=" ++ show count
else allocateBuffer size WriteBuffer
-- release the buffer if necessary
- if release && bufSize buf_ret == size
- then do
+ case buf_ret of
+ Buffer{ bufSize=buf_ret_sz, bufBuf=buf_ret_raw } -> do
+ if release && buf_ret_sz == size
+ then do
spare_bufs <- readIORef spare_buf_ref
writeIORef spare_buf_ref
- (BufferListCons (bufBuf buf_ret) spare_bufs)
+ (BufferListCons buf_ret_raw spare_bufs)
return buf_ret
- else
+ else
return buf_ret
-foreign import "memcpy_wrap" unsafe
+foreign import "memcpy_PrelIO_wrap" unsafe
memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ())
#def inline \
-void *memcpy_wrap(char *dst, int dst_off, char *src, size_t sz) \
+void *memcpy_PrelIO_wrap(char *dst, HsInt dst_off, const char *src, size_t sz) \
{ return memcpy(dst+dst_off, src, sz); }
-- ---------------------------------------------------------------------------
projects / ghc-hetmet.git / blobdiff