From dca0d0f7c04520caa00e2a4ec1602bbfd9de32f9 Mon Sep 17 00:00:00 2001 From: sof Date: Wed, 7 Nov 2001 18:25:55 +0000 Subject: [PATCH] [project @ 2001-11-07 18:25:55 by sof] no more --- ghc/lib/std/PrelHandle.hsc | 1224 -------------------------------------------- ghc/lib/std/PrelIO.hsc | 668 ------------------------ 2 files changed, 1892 deletions(-) delete mode 100644 ghc/lib/std/PrelHandle.hsc delete mode 100644 ghc/lib/std/PrelIO.hsc diff --git a/ghc/lib/std/PrelHandle.hsc b/ghc/lib/std/PrelHandle.hsc deleted file mode 100644 index 73efbe5..0000000 --- a/ghc/lib/std/PrelHandle.hsc +++ /dev/null @@ -1,1224 +0,0 @@ -{-# OPTIONS -fno-implicit-prelude #-} - -#undef DEBUG_DUMP -#undef DEBUG - --- ----------------------------------------------------------------------------- --- $Id: PrelHandle.hsc,v 1.17 2001/10/16 15:06:38 simonmar Exp $ --- --- (c) The University of Glasgow, 1994-2001 --- --- This module defines the basic operations on I/O "handles". - -module PrelHandle ( - withHandle, withHandle', withHandle_, - wantWritableHandle, wantReadableHandle, wantSeekableHandle, - - newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer, - flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer, - read_off, - - ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable, - - stdin, stdout, stderr, - IOMode(..), IOModeEx(..), openFile, openFileEx, openFd, - hFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode, - hFlush, - - hClose, hClose_help, - - HandlePosn(..), hGetPosn, hSetPosn, - SeekMode(..), hSeek, - - hIsOpen, hIsClosed, hIsReadable, hIsWritable, hGetBuffering, hIsSeekable, - hSetEcho, hGetEcho, hIsTerminalDevice, - ioeGetFileName, ioeGetErrorString, ioeGetHandle, - -#ifdef DEBUG_DUMP - puts, -#endif - - ) where - -#include "HsStd.h" - -import Monad - -import PrelBits -import PrelPosix -import PrelMarshalUtils -import PrelCString -import PrelCTypes -import PrelCError -import PrelReal - -import PrelArr -import PrelBase -import PrelPtr -import PrelRead ( Read ) -import PrelList -import PrelIOBase -import PrelMaybe ( Maybe(..) ) -import PrelException -import PrelEnum -import PrelNum ( Integer(..), Num(..) ) -import PrelShow -import PrelReal ( toInteger ) - -import PrelConc - --- ----------------------------------------------------------------------------- --- TODO: - --- hWaitForInput blocks (should use a timeout) - --- unbuffered hGetLine is a bit dodgy - --- hSetBuffering: can't change buffering on a stream, --- when the read buffer is non-empty? (no way to flush the buffer) - --- --------------------------------------------------------------------------- --- Are files opened by default in text or binary mode, if the user doesn't --- specify? -dEFAULT_OPEN_IN_BINARY_MODE :: Bool -dEFAULT_OPEN_IN_BINARY_MODE = False - --- Is seeking on text-mode handles allowed, or not? -tEXT_MODE_SEEK_ALLOWED :: Bool -#if defined(mingw32_TARGET_OS) -tEXT_MODE_SEEK_ALLOWED = False -#else -tEXT_MODE_SEEK_ALLOWED = True -#endif - - --- --------------------------------------------------------------------------- --- Creating a new handle - -newFileHandle :: (MVar Handle__ -> IO ()) -> Handle__ -> IO Handle -newFileHandle finalizer hc = do - m <- newMVar hc - addMVarFinalizer m (finalizer m) - return (FileHandle m) - --- --------------------------------------------------------------------------- --- Working with Handles - -{- -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 -original handle is always replaced [ this is the case at the moment, -but we might want to revisit this in the future --SDM ]. --} - -{-# INLINE withHandle #-} -withHandle :: String -> Handle -> (Handle__ -> IO (Handle__,a)) -> IO a -withHandle fun h@(FileHandle m) act = withHandle' fun h m act -withHandle fun h@(DuplexHandle m _) act = withHandle' fun h m act - -withHandle' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - (h',v) <- catchException (act h_) - (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_)) - checkBufferInvariants h' - putMVar m h' - return v - -{-# INLINE withHandle_ #-} -withHandle_ :: String -> Handle -> (Handle__ -> IO a) -> IO a -withHandle_ fun h@(FileHandle m) act = withHandle_' fun h m act -withHandle_ fun h@(DuplexHandle m _) act = withHandle_' fun h m act - -withHandle_' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - v <- catchException (act h_) - (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_)) - checkBufferInvariants h_ - putMVar m h_ - return v - -withAllHandles__ :: String -> Handle -> (Handle__ -> IO Handle__) -> IO () -withAllHandles__ fun h@(FileHandle m) act = withHandle__' fun h m act -withAllHandles__ fun h@(DuplexHandle r w) act = do - withHandle__' fun h r act - withHandle__' fun h w act - -withHandle__' fun h m act = - block $ do - h_ <- takeMVar m - checkBufferInvariants h_ - h' <- catchException (act h_) - (\ ex -> putMVar m h_ >> throw (augmentIOError ex fun h h_)) - checkBufferInvariants h' - putMVar m h' - return () - -augmentIOError (IOException (IOError _ iot _ str fp)) fun h h_ - = IOException (IOError (Just h) iot fun str filepath) - where filepath | Just _ <- fp = fp - | otherwise = Just (haFilePath h_) -augmentIOError other_exception _ _ _ - = other_exception - --- --------------------------------------------------------------------------- --- Wrapper for write operations. - -wantWritableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantWritableHandle fun h@(FileHandle m) act - = wantWritableHandle' fun h m act -wantWritableHandle fun h@(DuplexHandle _ m) act - = wantWritableHandle' fun h m act - -- ToDo: in the Duplex case, we don't need to checkWritableHandle - -wantWritableHandle' - :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO a) -> IO a -wantWritableHandle' fun h m act - = withHandle_' fun h m (checkWritableHandle act) - -checkWritableHandle act handle_ - = case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - ReadHandle -> ioe_notWritable - ReadWriteHandle -> do - let ref = haBuffer handle_ - buf <- readIORef ref - new_buf <- - if not (bufferIsWritable buf) - then do b <- flushReadBuffer (haFD handle_) buf - return b{ bufState=WriteBuffer } - else return buf - writeIORef ref new_buf - act handle_ - _other -> act handle_ - --- --------------------------------------------------------------------------- --- Wrapper for read operations. - -wantReadableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantReadableHandle fun h@(FileHandle m) act - = wantReadableHandle' fun h m act -wantReadableHandle fun h@(DuplexHandle m _) act - = wantReadableHandle' fun h m act - -- ToDo: in the Duplex case, we don't need to checkReadableHandle - -wantReadableHandle' - :: String -> Handle -> MVar Handle__ - -> (Handle__ -> IO a) -> IO a -wantReadableHandle' fun h m act - = withHandle_' fun h m (checkReadableHandle act) - -checkReadableHandle act handle_ = - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notReadable - WriteHandle -> ioe_notReadable - ReadWriteHandle -> do - let ref = haBuffer handle_ - buf <- readIORef ref - when (bufferIsWritable buf) $ do - new_buf <- flushWriteBuffer (haFD handle_) buf - writeIORef ref new_buf{ bufState=ReadBuffer } - act handle_ - _other -> act handle_ - --- --------------------------------------------------------------------------- --- Wrapper for seek operations. - -wantSeekableHandle :: String -> Handle -> (Handle__ -> IO a) -> IO a -wantSeekableHandle fun h@(DuplexHandle _ _) _act = - ioException (IOError (Just h) IllegalOperation fun - "handle is not seekable" Nothing) -wantSeekableHandle fun h@(FileHandle m) act = - withHandle_' fun h m (checkSeekableHandle act) - -checkSeekableHandle act handle_ = - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notSeekable - _ | haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED -> act handle_ - | otherwise -> ioe_notSeekable_notBin - --- ----------------------------------------------------------------------------- --- Handy IOErrors - -ioe_closedHandle, ioe_EOF, - ioe_notReadable, ioe_notWritable, - ioe_notSeekable, ioe_notSeekable_notBin :: IO a - -ioe_closedHandle = ioException - (IOError Nothing IllegalOperation "" - "handle is closed" Nothing) -ioe_EOF = ioException - (IOError Nothing EOF "" "" Nothing) -ioe_notReadable = ioException - (IOError Nothing IllegalOperation "" - "handle is not open for reading" Nothing) -ioe_notWritable = ioException - (IOError Nothing IllegalOperation "" - "handle is not open for writing" Nothing) -ioe_notSeekable = ioException - (IOError Nothing IllegalOperation "" - "handle is not seekable" Nothing) -ioe_notSeekable_notBin = ioException - (IOError Nothing IllegalOperation "" - "seek operations on text-mode handles are not allowed on this platform" - Nothing) - -ioe_bufsiz :: Int -> IO a -ioe_bufsiz n = ioException - (IOError Nothing InvalidArgument "hSetBuffering" - ("illegal buffer size " ++ showsPrec 9 n []) Nothing) - -- 9 => should be parens'ified. - --- ----------------------------------------------------------------------------- --- Handle Finalizers - --- For a duplex handle, we arrange that the read side points to the write side --- (and hence keeps it alive if the read side is alive). This is done by --- having the haType field of the read side be ReadSideHandle with a pointer --- to the write side. The finalizer is then placed on the write side, and --- the handle only gets finalized once, when both sides are no longer --- required. - -addFinalizer :: Handle -> IO () -addFinalizer (FileHandle m) = addMVarFinalizer m (handleFinalizer m) -addFinalizer (DuplexHandle _ w) = addMVarFinalizer w (handleFinalizer w) - -stdHandleFinalizer :: MVar Handle__ -> IO () -stdHandleFinalizer m = do - h_ <- takeMVar m - flushWriteBufferOnly h_ - -handleFinalizer :: MVar Handle__ -> IO () -handleFinalizer m = do - h_ <- takeMVar m - flushWriteBufferOnly h_ - let fd = fromIntegral (haFD h_) - unlockFile fd - -- ToDo: closesocket() for a WINSOCK socket? - when (fd /= -1) (c_close fd >> return ()) - return () - --- --------------------------------------------------------------------------- --- Grimy buffer operations - -#ifdef DEBUG -checkBufferInvariants h_ = do - let ref = haBuffer h_ - Buffer{ bufWPtr=w, bufRPtr=r, bufSize=size, bufState=state } <- readIORef ref - if not ( - size > 0 - && r <= w - && w <= size - && ( r /= w || (r == 0 && w == 0) ) - && ( state /= WriteBuffer || r == 0 ) - && ( state /= WriteBuffer || w < size ) -- write buffer is never full - ) - then error "buffer invariant violation" - else return () -#else -checkBufferInvariants h_ = return () -#endif - -newEmptyBuffer :: RawBuffer -> BufferState -> Int -> Buffer -newEmptyBuffer b state size - = Buffer{ bufBuf=b, bufRPtr=0, bufWPtr=0, bufSize=size, bufState=state } - -allocateBuffer :: Int -> BufferState -> IO Buffer -allocateBuffer sz@(I## size) state = IO $ \s -> - case newByteArray## size s of { (## s, b ##) -> - (## s, newEmptyBuffer b state sz ##) } - -writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int -writeCharIntoBuffer slab (I## off) (C## c) - = IO $ \s -> case writeCharArray## slab off c s of - s -> (## s, I## (off +## 1##) ##) - -readCharFromBuffer :: RawBuffer -> Int -> IO (Char, Int) -readCharFromBuffer slab (I## off) - = IO $ \s -> case readCharArray## slab off s of - (## s, c ##) -> (## s, (C## c, I## (off +## 1##)) ##) - -dEFAULT_BUFFER_SIZE = (#const BUFSIZ) :: Int - -getBuffer :: FD -> BufferState -> IO (IORef Buffer, BufferMode) -getBuffer fd state = do - buffer <- allocateBuffer dEFAULT_BUFFER_SIZE state - ioref <- newIORef buffer - is_tty <- fdIsTTY fd - - let buffer_mode - | is_tty = LineBuffering - | otherwise = BlockBuffering Nothing - - return (ioref, buffer_mode) - -mkUnBuffer :: IO (IORef Buffer) -mkUnBuffer = do - buffer <- allocateBuffer 1 ReadBuffer - newIORef buffer - --- flushWriteBufferOnly flushes the buffer iff it contains pending write data. -flushWriteBufferOnly :: Handle__ -> IO () -flushWriteBufferOnly h_ = do - let fd = haFD h_ - ref = haBuffer h_ - buf <- readIORef ref - new_buf <- if bufferIsWritable buf - then flushWriteBuffer fd buf - else return buf - writeIORef ref new_buf - --- flushBuffer syncs the file with the buffer, including moving the --- file pointer backwards in the case of a read buffer. -flushBuffer :: Handle__ -> IO () -flushBuffer h_ = do - let ref = haBuffer h_ - buf <- readIORef ref - - flushed_buf <- - case bufState buf of - ReadBuffer -> flushReadBuffer (haFD h_) buf - WriteBuffer -> flushWriteBuffer (haFD h_) buf - - writeIORef ref flushed_buf - --- When flushing a read buffer, we seek backwards by the number of --- characters in the buffer. The file descriptor must therefore be --- seekable: attempting to flush the read buffer on an unseekable --- handle is not allowed. - -flushReadBuffer :: FD -> Buffer -> IO Buffer -flushReadBuffer fd buf - | bufferEmpty buf = return buf - | otherwise = do - let off = negate (bufWPtr buf - bufRPtr buf) -# ifdef DEBUG_DUMP - puts ("flushReadBuffer: new file offset = " ++ show off ++ "\n") -# endif - throwErrnoIfMinus1Retry "flushReadBuffer" - (c_lseek (fromIntegral fd) (fromIntegral off) (#const SEEK_CUR)) - return buf{ bufWPtr=0, bufRPtr=0 } - -flushWriteBuffer :: FD -> Buffer -> IO Buffer -flushWriteBuffer fd buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } = do - let bytes = w - r -#ifdef DEBUG_DUMP - puts ("flushWriteBuffer, fd=" ++ show fd ++ ", bytes=" ++ show bytes ++ "\n") -#endif - if bytes == 0 - then return (buf{ bufRPtr=0, bufWPtr=0 }) - else do - res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer" - (write_off (fromIntegral fd) b (fromIntegral r) - (fromIntegral bytes)) - (threadWaitWrite fd) - let res' = fromIntegral res - if res' < bytes - then flushWriteBuffer fd (buf{ bufRPtr = r + res' }) - else return buf{ bufRPtr=0, bufWPtr=0 } - -foreign import "write_PrelHandle_wrap" unsafe - write_off :: CInt -> RawBuffer -> Int -> CInt -> IO CInt -#def inline \ -int write_PrelHandle_wrap(int fd, void *ptr, HsInt off, int size) \ -{ return write(fd, ptr + off, size); } - - -fillReadBuffer :: FD -> Bool -> Buffer -> IO Buffer -fillReadBuffer fd is_line - buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } = - -- buffer better be empty: - assert (r == 0 && w == 0) $ do - fillReadBufferLoop fd is_line buf b w size - --- For a line buffer, we just get the first chunk of data to arrive, --- and don't wait for the whole buffer to be full (but we *do* wait --- until some data arrives). This isn't really line buffering, but it --- appears to be what GHC has done for a long time, and I suspect it --- is more useful than line buffering in most cases. - -fillReadBufferLoop fd is_line buf b w size = do - let bytes = size - w - if bytes == 0 -- buffer full? - then return buf{ bufRPtr=0, bufWPtr=w } - else do -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n") -#endif - res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer" - (read_off fd b (fromIntegral w) (fromIntegral bytes)) - (threadWaitRead fd) - let res' = fromIntegral res -#ifdef DEBUG_DUMP - puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n") -#endif - if res' == 0 - then if w == 0 - then ioe_EOF - else return buf{ bufRPtr=0, bufWPtr=w } - else if res' < bytes && not is_line - then fillReadBufferLoop fd is_line buf b (w+res') size - else return buf{ bufRPtr=0, bufWPtr=w+res' } - -foreign import "read_PrelHandle_wrap" unsafe - read_off :: FD -> RawBuffer -> Int -> CInt -> IO CInt -#def inline \ -int read_PrelHandle_wrap(int fd, void *ptr, HsInt off, int size) \ -{ return read(fd, ptr + off, size); } - --- --------------------------------------------------------------------------- --- Standard Handles - --- Three handles are allocated during program initialisation. The first --- two manage input or output from the Haskell program's standard input --- or output channel respectively. The third manages output to the --- standard error channel. These handles are initially open. - -fd_stdin = 0 :: FD -fd_stdout = 1 :: FD -fd_stderr = 2 :: FD - -stdin :: Handle -stdin = unsafePerformIO $ do - -- ToDo: acquire lock - setNonBlockingFD fd_stdin - (buf, bmode) <- getBuffer fd_stdin ReadBuffer - spares <- newIORef BufferListNil - newFileHandle stdHandleFinalizer - (Handle__ { haFD = fd_stdin, - haType = ReadHandle, - haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, - haBufferMode = bmode, - haFilePath = "", - haBuffer = buf, - haBuffers = spares - }) - -stdout :: Handle -stdout = unsafePerformIO $ do - -- ToDo: acquire lock - -- We don't set non-blocking mode on stdout or sterr, because - -- some shells don't recover properly. - -- setNonBlockingFD fd_stdout - (buf, bmode) <- getBuffer fd_stdout WriteBuffer - spares <- newIORef BufferListNil - newFileHandle stdHandleFinalizer - (Handle__ { haFD = fd_stdout, - haType = WriteHandle, - haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, - haBufferMode = bmode, - haFilePath = "", - haBuffer = buf, - haBuffers = spares - }) - -stderr :: Handle -stderr = unsafePerformIO $ do - -- ToDo: acquire lock - -- We don't set non-blocking mode on stdout or sterr, because - -- some shells don't recover properly. - -- setNonBlockingFD fd_stderr - buffer <- mkUnBuffer - spares <- newIORef BufferListNil - newFileHandle stdHandleFinalizer - (Handle__ { haFD = fd_stderr, - haType = WriteHandle, - haIsBin = dEFAULT_OPEN_IN_BINARY_MODE, - haBufferMode = NoBuffering, - haFilePath = "", - haBuffer = buffer, - haBuffers = spares - }) - --- --------------------------------------------------------------------------- --- Opening and Closing Files - -{- -Computation `openFile file mode' allocates and returns a new, open -handle to manage the file `file'. It manages input if `mode' -is `ReadMode', output if `mode' is `WriteMode' or `AppendMode', -and both input and output if mode is `ReadWriteMode'. - -If the file does not exist and it is opened for output, it should be -created as a new file. If `mode' is `WriteMode' and the file -already exists, then it should be truncated to zero length. The -handle is positioned at the end of the file if `mode' is -`AppendMode', and otherwise at the beginning (in which case its -internal position is 0). - -Implementations should enforce, locally to the Haskell process, -multiple-reader single-writer locking on files, which is to say that -there may either be many handles on the same file which manage input, -or just one handle on the file which manages output. If any open or -semi-closed handle is managing a file for output, no new handle can be -allocated for that file. If any open or semi-closed handle is -managing a file for input, new handles can only be allocated if they -do not manage output. - -Two files are the same if they have the same absolute name. An -implementation is free to impose stricter conditions. --} - -data IOMode = ReadMode | WriteMode | AppendMode | ReadWriteMode - deriving (Eq, Ord, Ix, Enum, Read, Show) - -data IOModeEx - = BinaryMode IOMode - | TextMode IOMode - deriving (Eq, Read, Show) - -addFilePathToIOError fun fp (IOException (IOError h iot _ str _)) - = IOException (IOError h iot fun str (Just fp)) -addFilePathToIOError _ _ other_exception - = other_exception - -openFile :: FilePath -> IOMode -> IO Handle -openFile fp im = - catch - (openFile' fp (if dEFAULT_OPEN_IN_BINARY_MODE - then BinaryMode im - else TextMode im)) - (\e -> throw (addFilePathToIOError "openFile" fp e)) - -openFileEx :: FilePath -> IOModeEx -> IO Handle -openFileEx fp m = - catch - (openFile' fp m) - (\e -> throw (addFilePathToIOError "openFileEx" fp e)) - - -openFile' filepath ex_mode = - withCString filepath $ \ f -> - - let - (mode, binary) = - case ex_mode of - BinaryMode bmo -> (bmo, True) - TextMode tmo -> (tmo, False) - - oflags1 = case mode of - ReadMode -> read_flags - WriteMode -> write_flags - ReadWriteMode -> rw_flags - AppendMode -> append_flags - - truncate | WriteMode <- mode = True - | otherwise = False - - binary_flags -#ifdef HAVE_O_BINARY - | binary = o_BINARY -#endif - | otherwise = 0 - - oflags = oflags1 .|. binary_flags - in do - - -- the old implementation had a complicated series of three opens, - -- which is perhaps because we have to be careful not to open - -- directories. However, the man pages I've read say that open() - -- always returns EISDIR if the file is a directory and was opened - -- for writing, so I think we're ok with a single open() here... - fd <- fromIntegral `liftM` - throwErrnoIfMinus1Retry "openFile" - (c_open f (fromIntegral oflags) 0o666) - - openFd fd filepath mode binary truncate - -- ASSERT: if we just created the file, then openFd won't fail - -- (so we don't need to worry about removing the newly created file - -- in the event of an error). - - -std_flags = o_NONBLOCK .|. o_NOCTTY -output_flags = std_flags .|. o_CREAT -read_flags = std_flags .|. o_RDONLY -write_flags = output_flags .|. o_WRONLY -rw_flags = output_flags .|. o_RDWR -append_flags = write_flags .|. o_APPEND - --- --------------------------------------------------------------------------- --- openFd - -openFd :: FD -> FilePath -> IOMode -> Bool -> Bool -> IO Handle -openFd fd filepath mode binary truncate = do - -- turn on non-blocking mode - setNonBlockingFD fd - - let (ha_type, write) = - case mode of - ReadMode -> ( ReadHandle, False ) - WriteMode -> ( WriteHandle, True ) - ReadWriteMode -> ( ReadWriteHandle, True ) - AppendMode -> ( AppendHandle, True ) - - -- open() won't tell us if it was a directory if we only opened for - -- reading, so check again. - fd_type <- fdType fd - case fd_type of - Directory -> - ioException (IOError Nothing InappropriateType "openFile" - "is a directory" Nothing) - - Stream - | ReadWriteHandle <- ha_type -> mkDuplexHandle fd filepath binary - | otherwise -> mkFileHandle fd filepath ha_type binary - - -- regular files need to be locked - RegularFile -> do - r <- lockFile (fromIntegral fd) (fromBool write) 1{-exclusive-} - when (r == -1) $ - ioException (IOError Nothing ResourceBusy "openFile" - "file is locked" Nothing) - - -- truncate the file if necessary - when truncate (fileTruncate filepath) - - mkFileHandle fd filepath ha_type binary - - -foreign import "lockFile" unsafe - lockFile :: CInt -> CInt -> CInt -> IO CInt - -foreign import "unlockFile" unsafe - unlockFile :: CInt -> IO CInt - -mkFileHandle :: FD -> FilePath -> HandleType -> Bool -> IO Handle -mkFileHandle fd filepath ha_type binary = do - (buf, bmode) <- getBuffer fd (initBufferState ha_type) - spares <- newIORef BufferListNil - newFileHandle handleFinalizer - (Handle__ { haFD = fd, - haType = ha_type, - haIsBin = binary, - haBufferMode = bmode, - haFilePath = filepath, - haBuffer = buf, - haBuffers = spares - }) - -mkDuplexHandle :: FD -> FilePath -> Bool -> IO Handle -mkDuplexHandle fd filepath binary = do - (w_buf, w_bmode) <- getBuffer fd WriteBuffer - w_spares <- newIORef BufferListNil - let w_handle_ = - Handle__ { haFD = fd, - haType = WriteHandle, - haIsBin = binary, - haBufferMode = w_bmode, - haFilePath = filepath, - haBuffer = w_buf, - haBuffers = w_spares - } - write_side <- newMVar w_handle_ - - (r_buf, r_bmode) <- getBuffer fd ReadBuffer - r_spares <- newIORef BufferListNil - let r_handle_ = - Handle__ { haFD = fd, - haType = ReadSideHandle write_side, - haIsBin = binary, - haBufferMode = r_bmode, - haFilePath = filepath, - haBuffer = r_buf, - haBuffers = r_spares - } - read_side <- newMVar r_handle_ - - addMVarFinalizer write_side (handleFinalizer write_side) - return (DuplexHandle read_side write_side) - - -initBufferState ReadHandle = ReadBuffer -initBufferState _ = WriteBuffer - --- --------------------------------------------------------------------------- --- Closing a handle - --- Computation `hClose hdl' makes handle `hdl' closed. Before the --- computation finishes, any items buffered for output and not already --- sent to the operating system are flushed as for `hFlush'. - --- For a duplex handle, we close&flush the write side, and just close --- the read side. - -hClose :: Handle -> IO () -hClose h@(FileHandle m) = hClose' h m -hClose h@(DuplexHandle r w) = do - hClose' h w - withHandle__' "hClose" h r $ \ handle_ -> do - return handle_{ haFD = -1, - haType = ClosedHandle - } - -hClose' h m = withHandle__' "hClose" h m $ hClose_help - -hClose_help handle_ = - case haType handle_ of - ClosedHandle -> return handle_ - _ -> do - let fd = fromIntegral (haFD handle_) - flushWriteBufferOnly handle_ - throwErrnoIfMinus1Retry_ "hClose" (c_close fd) - - -- free the spare buffers - writeIORef (haBuffers handle_) BufferListNil - - -- unlock it - unlockFile fd - - -- we must set the fd to -1, because the finalizer is going - -- to run eventually and try to close/unlock it. - return (handle_{ haFD = -1, - haType = ClosedHandle - }) - ------------------------------------------------------------------------------ --- Detecting the size of a file - --- For a handle `hdl' which attached to a physical file, `hFileSize --- hdl' returns the size of `hdl' in terms of the number of items --- which can be read from `hdl'. - -hFileSize :: Handle -> IO Integer -hFileSize handle = - withHandle_ "hFileSize" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - _ -> do flushWriteBufferOnly handle_ - r <- fdFileSize (haFD handle_) - if r /= -1 - then return r - else ioException (IOError Nothing InappropriateType "hFileSize" - "not a regular file" Nothing) - --- --------------------------------------------------------------------------- --- Detecting the End of Input - --- For a readable handle `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 --- the file. Otherwise, it returns `False'. - -hIsEOF :: Handle -> IO Bool -hIsEOF handle = - catch - (do hLookAhead handle; return False) - (\e -> if isEOFError e then return True else throw e) - -isEOF :: IO Bool -isEOF = hIsEOF stdin - --- --------------------------------------------------------------------------- --- Looking ahead - --- hLookahead returns the next character from the handle without --- removing it from the input buffer, blocking until a character is --- available. - -hLookAhead :: Handle -> IO Char -hLookAhead handle = do - wantReadableHandle "hLookAhead" handle $ \handle_ -> do - let ref = haBuffer handle_ - fd = haFD handle_ - is_line = haBufferMode handle_ == LineBuffering - buf <- readIORef ref - - -- fill up the read buffer if necessary - new_buf <- if bufferEmpty buf - then fillReadBuffer fd is_line buf - else return buf - - writeIORef ref new_buf - - (c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf) - return c - --- --------------------------------------------------------------------------- --- Buffering Operations - --- Three kinds of buffering are supported: line-buffering, --- block-buffering or no-buffering. See PrelIOBase for definition and --- further explanation of what the type represent. - --- Computation `hSetBuffering hdl mode' sets the mode of buffering for --- handle hdl on subsequent reads and writes. --- --- * If mode is LineBuffering, line-buffering should be enabled if possible. --- --- * If mode is `BlockBuffering size', then block-buffering --- should be enabled if possible. The size of the buffer is n items --- if size is `Just n' and is otherwise implementation-dependent. --- --- * If mode is NoBuffering, then buffering is disabled if possible. - --- If the buffer mode is changed from BlockBuffering or --- LineBuffering to NoBuffering, then any items in the output --- buffer are written to the device, and any items in the input buffer --- are discarded. The default buffering mode when a handle is opened --- is implementation-dependent and may depend on the object which is --- attached to that handle. - -hSetBuffering :: Handle -> BufferMode -> IO () -hSetBuffering handle mode = - withAllHandles__ "hSetBuffering" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> do - {- Note: - - we flush the old buffer regardless of whether - the new buffer could fit the contents of the old buffer - or not. - - allow a handle's buffering to change even if IO has - occurred (ANSI C spec. does not allow this, nor did - the previous implementation of IO.hSetBuffering). - - a non-standard extension is to allow the buffering - of semi-closed handles to change [sof 6/98] - -} - flushBuffer handle_ - - let state = initBufferState (haType handle_) - new_buf <- - case mode of - -- we always have a 1-character read buffer for - -- unbuffered handles: it's needed to - -- support hLookAhead. - NoBuffering -> allocateBuffer 1 ReadBuffer - LineBuffering -> allocateBuffer dEFAULT_BUFFER_SIZE state - BlockBuffering Nothing -> allocateBuffer dEFAULT_BUFFER_SIZE state - BlockBuffering (Just n) | n <= 0 -> ioe_bufsiz n - | otherwise -> allocateBuffer n state - writeIORef (haBuffer handle_) new_buf - - -- for input terminals we need to put the terminal into - -- cooked or raw mode depending on the type of buffering. - is_tty <- fdIsTTY (haFD handle_) - when (is_tty && isReadableHandleType (haType handle_)) $ - case mode of - NoBuffering -> setCooked (haFD handle_) False - _ -> setCooked (haFD handle_) True - - -- throw away spare buffers, they might be the wrong size - writeIORef (haBuffers handle_) BufferListNil - - return (handle_{ haBufferMode = mode }) - --- ----------------------------------------------------------------------------- --- hFlush - --- The action `hFlush hdl' causes any items buffered for output --- in handle `hdl' to be sent immediately to the operating --- system. - -hFlush :: Handle -> IO () -hFlush handle = - wantWritableHandle "hFlush" handle $ \ handle_ -> do - buf <- readIORef (haBuffer handle_) - if bufferIsWritable buf && not (bufferEmpty buf) - then do flushed_buf <- flushWriteBuffer (haFD handle_) buf - writeIORef (haBuffer handle_) flushed_buf - else return () - - --- ----------------------------------------------------------------------------- --- Repositioning Handles - -data HandlePosn = HandlePosn Handle HandlePosition - -instance Eq HandlePosn where - (HandlePosn h1 p1) == (HandlePosn h2 p2) = p1==p2 && h1==h2 - -instance Show HandlePosn where - showsPrec p (HandlePosn h pos) = - showsPrec p h . showString " at position " . shows pos - - -- 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 - --- Computation `hGetPosn hdl' returns the current I/O position of --- `hdl' as an abstract position. Computation `hSetPosn p' sets the --- position of `hdl' to a previously obtained position `p'. - -hGetPosn :: Handle -> IO HandlePosn -hGetPosn handle = - wantSeekableHandle "hGetPosn" handle $ \ handle_ -> do - -#if defined(_WIN32) - -- urgh, on Windows we have to worry about \n -> \r\n translation, - -- so we can't easily calculate the file position using the - -- current buffer size. Just flush instead. - flushBuffer handle_ -#endif - let fd = fromIntegral (haFD handle_) - posn <- fromIntegral `liftM` - throwErrnoIfMinus1Retry "hGetPosn" - (c_lseek fd 0 (#const SEEK_CUR)) - - let ref = haBuffer handle_ - buf <- readIORef ref - - let real_posn - | bufferIsWritable buf = posn + fromIntegral (bufWPtr buf) - | otherwise = posn - fromIntegral (bufWPtr buf - bufRPtr buf) -# ifdef DEBUG_DUMP - puts ("\nhGetPosn: (fd, posn, real_posn) = " ++ show (fd, posn, real_posn) ++ "\n") - puts (" (bufWPtr, bufRPtr) = " ++ show (bufWPtr buf, bufRPtr buf) ++ "\n") -# endif - return (HandlePosn handle real_posn) - - -hSetPosn :: HandlePosn -> IO () -hSetPosn (HandlePosn h i) = hSeek h AbsoluteSeek i - --- --------------------------------------------------------------------------- --- hSeek - -{- -The action `hSeek hdl mode i' sets the position of handle -`hdl' depending on `mode'. If `mode' is - - * 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. - - - we possibly deviate from the report on the issue of seeking within - the buffer and whether to flush it or not. The report isn't exactly - clear here. --} - -data SeekMode = AbsoluteSeek | RelativeSeek | SeekFromEnd - deriving (Eq, Ord, Ix, Enum, Read, Show) - -hSeek :: Handle -> SeekMode -> Integer -> IO () -hSeek handle mode offset = - wantSeekableHandle "hSeek" handle $ \ handle_ -> do -# ifdef DEBUG_DUMP - puts ("hSeek " ++ show (mode,offset) ++ "\n") -# endif - let ref = haBuffer handle_ - buf <- readIORef ref - let r = bufRPtr buf - w = bufWPtr buf - fd = haFD handle_ - - let do_seek = - throwErrnoIfMinus1Retry_ "hSeek" - (c_lseek (fromIntegral (haFD handle_)) (fromIntegral offset) whence) - - whence :: CInt - whence = case mode of - AbsoluteSeek -> (#const SEEK_SET) - RelativeSeek -> (#const SEEK_CUR) - SeekFromEnd -> (#const SEEK_END) - - if bufferIsWritable buf - then do new_buf <- flushWriteBuffer fd buf - writeIORef ref new_buf - do_seek - else do - - if mode == RelativeSeek && offset >= 0 && offset < fromIntegral (w - r) - then writeIORef ref buf{ bufRPtr = r + fromIntegral offset } - else do - - new_buf <- flushReadBuffer (haFD handle_) buf - writeIORef ref new_buf - do_seek - --- ----------------------------------------------------------------------------- --- Handle Properties - --- A number of operations return information about the properties of a --- handle. Each of these operations returns `True' if the handle has --- the specified property, and `False' otherwise. - -hIsOpen :: Handle -> IO Bool -hIsOpen handle = - withHandle_ "hIsOpen" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return False - SemiClosedHandle -> return False - _ -> return True - -hIsClosed :: Handle -> IO Bool -hIsClosed handle = - withHandle_ "hIsClosed" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return True - _ -> return False - -{- not defined, nor exported, but mentioned - here for documentation purposes: - - hSemiClosed :: Handle -> IO Bool - hSemiClosed h = do - ho <- hIsOpen h - hc <- hIsClosed h - return (not (ho || hc)) --} - -hIsReadable :: Handle -> IO Bool -hIsReadable (DuplexHandle _ _) = return True -hIsReadable handle = - withHandle_ "hIsReadable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - htype -> return (isReadableHandleType htype) - -hIsWritable :: Handle -> IO Bool -hIsWritable (DuplexHandle _ _) = return False -hIsWritable handle = - withHandle_ "hIsWritable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - htype -> return (isWritableHandleType htype) - --- Querying how a handle buffers its data: - -hGetBuffering :: Handle -> IO BufferMode -hGetBuffering handle = - withHandle_ "hGetBuffering" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> - -- We're being non-standard here, and allow the buffering - -- of a semi-closed handle to be queried. -- sof 6/98 - return (haBufferMode handle_) -- could be stricter.. - -hIsSeekable :: Handle -> IO Bool -hIsSeekable handle = - withHandle_ "hIsSeekable" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> return False - _ -> do t <- fdType (haFD handle_) - return (t == RegularFile - && (haIsBin handle_ || tEXT_MODE_SEEK_ALLOWED)) - --- ----------------------------------------------------------------------------- --- Changing echo status - --- Non-standard GHC extension is to allow the echoing status --- of a handles connected to terminals to be reconfigured: - -hSetEcho :: Handle -> Bool -> IO () -hSetEcho handle on = do - isT <- hIsTerminalDevice handle - if not isT - then return () - else - withHandle_ "hSetEcho" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> setEcho (haFD handle_) on - -hGetEcho :: Handle -> IO Bool -hGetEcho handle = do - isT <- hIsTerminalDevice handle - if not isT - then return False - else - withHandle_ "hGetEcho" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> getEcho (haFD handle_) - -hIsTerminalDevice :: Handle -> IO Bool -hIsTerminalDevice handle = do - withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> ioe_closedHandle - _ -> fdIsTTY (haFD handle_) - --- ----------------------------------------------------------------------------- --- hSetBinaryMode - -#ifdef _WIN32 -hSetBinaryMode handle bin = - withAllHandles__ "hSetBinaryMode" handle $ \ handle_ -> - do let flg | bin = (#const O_BINARY) - | otherwise = (#const O_TEXT) - throwErrnoIfMinus1_ "hSetBinaryMode" - (setmode (fromIntegral (haFD handle_)) flg) - return handle_{haIsBin=bin} - -foreign import "setmode" setmode :: CInt -> CInt -> IO CInt -#else -hSetBinaryMode handle bin = - withAllHandles__ "hSetBinaryMode" handle $ \ handle_ -> - return handle_{haIsBin=bin} -#endif - --- ----------------------------------------------------------------------------- --- Miscellaneous - --- These three functions are meant to get things out of an IOError. - -ioeGetFileName :: IOError -> Maybe FilePath -ioeGetErrorString :: IOError -> String -ioeGetHandle :: IOError -> Maybe Handle - -ioeGetHandle (IOException (IOError h _ _ _ _)) = h -ioeGetHandle (UserError _) = Nothing -ioeGetHandle _ = error "IO.ioeGetHandle: not an IO error" - -ioeGetErrorString (IOException (IOError _ iot _ _ _)) = show iot -ioeGetErrorString (UserError str) = str -ioeGetErrorString _ = error "IO.ioeGetErrorString: not an IO error" - -ioeGetFileName (IOException (IOError _ _ _ _ fn)) = fn -ioeGetFileName (UserError _) = Nothing -ioeGetFileName _ = error "IO.ioeGetFileName: not an IO error" - --- --------------------------------------------------------------------------- --- debugging - -#ifdef DEBUG_DUMP -puts :: String -> IO () -puts s = withCString s $ \cstr -> do c_write 1 cstr (fromIntegral (length s)) - return () -#endif diff --git a/ghc/lib/std/PrelIO.hsc b/ghc/lib/std/PrelIO.hsc deleted file mode 100644 index 67f909b..0000000 --- a/ghc/lib/std/PrelIO.hsc +++ /dev/null @@ -1,668 +0,0 @@ -{-# OPTIONS -fno-implicit-prelude #-} - -#undef DEBUG_DUMP - --- ----------------------------------------------------------------------------- --- $Id: PrelIO.hsc,v 1.16 2001/09/18 08:32:11 simonmar Exp $ --- --- (c) The University of Glasgow, 1992-2001 --- --- Module PrelIO - --- This module defines all basic IO operations. --- These are needed for the IO operations exported by Prelude, --- but as it happens they also do everything required by library --- module IO. - -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 PrelMarshalUtils -import PrelStorable -import PrelCError -import PrelCString -import PrelCTypes -import PrelCTypesISO - -import PrelIOBase -import PrelHandle -- much of the real stuff is in here - -import PrelMaybe -import PrelReal -import PrelNum -import PrelRead -import PrelShow -import PrelMaybe ( Maybe(..) ) -import PrelPtr -import PrelList -import PrelException ( ioError, catch, throw ) -import PrelConc - --- ----------------------------------------------------------------------------- --- Standard IO - -putChar :: Char -> IO () -putChar c = hPutChar stdout c - -putStr :: String -> IO () -putStr s = hPutStr stdout s - -putStrLn :: String -> IO () -putStrLn s = do putStr s - putChar '\n' - -print :: Show a => a -> IO () -print x = putStrLn (show x) - -getChar :: IO Char -getChar = hGetChar stdin - -getLine :: IO String -getLine = hGetLine stdin - -getContents :: IO String -getContents = hGetContents stdin - -interact :: (String -> String) -> IO () -interact f = do s <- getContents - putStr (f s) - -readFile :: FilePath -> IO String -readFile name = openFile name ReadMode >>= hGetContents - -writeFile :: FilePath -> String -> IO () -writeFile name str = do - hdl <- openFile name WriteMode - hPutStr hdl str - hClose hdl - -appendFile :: FilePath -> String -> IO () -appendFile name str = do - hdl <- openFile name AppendMode - hPutStr hdl str - hClose hdl - -readLn :: Read a => IO a -readLn = do l <- getLine - r <- readIO l - return r - - -- raises an exception instead of an error -readIO :: Read a => String -> IO a -readIO s = case (do { (x,t) <- reads s ; - ("","") <- lex t ; - return x }) of -#ifndef NEW_READS_REP - [x] -> return x - [] -> ioError (userError "Prelude.readIO: no parse") - _ -> ioError (userError "Prelude.readIO: ambiguous parse") -#else - Just x -> return x - Nothing -> ioError (userError "Prelude.readIO: no parse") -#endif - --- --------------------------------------------------------------------------- --- Simple input operations - --- Computation "hReady hdl" indicates whether at least --- one item is available for input from handle "hdl". - --- If hWaitForInput finds anything in the Handle's buffer, it --- immediately returns. If not, it tries to read from the underlying --- OS handle. Notice that for buffered Handles connected to terminals --- this means waiting until a complete line is available. - -hReady :: Handle -> IO Bool -hReady h = hWaitForInput h 0 - -hWaitForInput :: Handle -> Int -> IO Bool -hWaitForInput h msecs = do - wantReadableHandle "hReady" h $ \ handle_ -> do - let ref = haBuffer handle_ - buf <- readIORef ref - - if not (bufferEmpty buf) - then return True - else do - - r <- throwErrnoIfMinus1Retry "hReady" - (inputReady (fromIntegral (haFD handle_)) (fromIntegral msecs)) - return (r /= 0) - -foreign import "inputReady" - inputReady :: CInt -> CInt -> IO CInt - --- --------------------------------------------------------------------------- --- hGetChar - --- hGetChar reads the next character from a handle, --- blocking until a character is available. - -hGetChar :: Handle -> IO Char -hGetChar handle = - wantReadableHandle "hGetChar" handle $ \handle_ -> do - - let fd = haFD handle_ - ref = haBuffer handle_ - - buf <- readIORef ref - if not (bufferEmpty buf) - then hGetcBuffered fd ref buf - else do - - -- buffer is empty. - case haBufferMode handle_ of - LineBuffering -> do - new_buf <- fillReadBuffer fd True buf - hGetcBuffered fd ref new_buf - BlockBuffering _ -> do - new_buf <- fillReadBuffer fd False buf - hGetcBuffered fd ref new_buf - NoBuffering -> do - -- make use of the minimal buffer we already have - let raw = bufBuf buf - r <- throwErrnoIfMinus1RetryMayBlock "hGetChar" - (read_off (fromIntegral fd) raw 0 1) - (threadWaitRead fd) - if r == 0 - then ioe_EOF - else do (c,_) <- readCharFromBuffer raw 0 - return c - -hGetcBuffered fd ref buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w } - = do (c,r) <- readCharFromBuffer b r - let new_buf | r == w = buf{ bufRPtr=0, bufWPtr=0 } - | otherwise = buf{ bufRPtr=r } - writeIORef ref new_buf - return c - --- --------------------------------------------------------------------------- --- hGetLine - --- If EOF is reached before EOL is encountered, ignore the EOF and --- return the partial line. Next attempt at calling hGetLine on the --- handle will yield an EOF IO exception though. - --- ToDo: the unbuffered case is wrong: it doesn't lock the handle for --- the duration. -hGetLine :: Handle -> IO String -hGetLine h = do - m <- wantReadableHandle "hGetLine" h $ \ handle_ -> do - case haBufferMode handle_ of - NoBuffering -> return Nothing - LineBuffering -> do - l <- hGetLineBuffered handle_ - return (Just l) - BlockBuffering _ -> do - l <- hGetLineBuffered handle_ - return (Just l) - case m of - Nothing -> hGetLineUnBuffered h - Just l -> return l - - -hGetLineBuffered handle_ = do - let ref = haBuffer handle_ - buf <- readIORef ref - hGetLineBufferedLoop handle_ ref buf [] - - -hGetLineBufferedLoop handle_ ref - buf@Buffer{ bufRPtr=r, bufWPtr=w, bufBuf=raw } xss = - let - -- find the end-of-line character, if there is one - loop raw r - | r == w = return (False, w) - | otherwise = do - (c,r') <- readCharFromBuffer raw r - if c == '\n' - then return (True, r) -- NB. not r': don't include the '\n' - else loop raw r' - in do - (eol, off) <- loop raw r - -#ifdef DEBUG_DUMP - puts ("hGetLineBufferedLoop: r=" ++ show r ++ ", w=" ++ show w ++ ", off=" ++ show off ++ "\n") -#endif - - xs <- unpack raw r off - if eol - then do if w == off + 1 - then writeIORef ref buf{ bufRPtr=0, bufWPtr=0 } - else writeIORef ref buf{ bufRPtr = off + 1 } - return (concat (reverse (xs:xss))) - else do - maybe_buf <- maybeFillReadBuffer (haFD handle_) True - buf{ bufWPtr=0, bufRPtr=0 } - case maybe_buf of - -- Nothing indicates we caught an EOF, and we may have a - -- partial line to return. - Nothing -> let str = concat (reverse (xs:xss)) in - if not (null str) - then return str - else ioe_EOF - Just new_buf -> - 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 - where - unpack acc i s - | i <## r = (## s, acc ##) - | otherwise = - case readCharArray## buf i s of - (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s - - -hGetLineUnBuffered :: Handle -> IO String -hGetLineUnBuffered h = do - c <- hGetChar h - if c == '\n' then - return "" - else do - l <- getRest - return (c:l) - where - getRest = do - c <- - catch - (hGetChar h) - (\ err -> do - if isEOFError err then - return '\n' - else - ioError err) - if c == '\n' then - return "" - else do - s <- getRest - return (c:s) - --- ----------------------------------------------------------------------------- --- hGetContents - --- hGetContents returns the list of characters corresponding to the --- unread portion of the channel or file managed by the handle, which --- is made semi-closed. - --- hGetContents on a DuplexHandle only affects the read side: you can --- carry on writing to it afterwards. - -hGetContents :: Handle -> IO String -hGetContents handle = - withHandle "hGetContents" handle $ \handle_ -> - case haType handle_ of - ClosedHandle -> ioe_closedHandle - SemiClosedHandle -> ioe_closedHandle - AppendHandle -> ioe_notReadable - WriteHandle -> ioe_notReadable - _ -> do xs <- lazyRead handle - return (handle_{ haType=SemiClosedHandle}, xs ) - --- Note that someone may close the semi-closed handle (or change its --- buffering), so each time these lazy read functions are pulled on, --- they have to check whether the handle has indeed been closed. - -lazyRead :: Handle -> IO String -lazyRead handle = - unsafeInterleaveIO $ - withHandle "lazyRead" handle $ \ handle_ -> do - case haType handle_ of - ClosedHandle -> return (handle_, "") - SemiClosedHandle -> lazyRead' handle handle_ - _ -> ioException - (IOError (Just handle) IllegalOperation "lazyRead" - "illegal handle type" Nothing) - -lazyRead' h handle_ = do - let ref = haBuffer handle_ - fd = haFD handle_ - - -- even a NoBuffering handle can have a char in the buffer... - -- (see hLookAhead) - buf <- readIORef ref - if not (bufferEmpty buf) - then lazyReadHaveBuffer h handle_ fd ref buf - else do - - case haBufferMode handle_ of - NoBuffering -> do - -- make use of the minimal buffer we already have - let raw = bufBuf buf - fd = haFD handle_ - r <- throwErrnoIfMinus1RetryMayBlock "lazyRead" - (read_off (fromIntegral fd) raw 0 1) - (threadWaitRead fd) - if r == 0 - then do handle_ <- hClose_help handle_ - return (handle_, "") - else do (c,_) <- readCharFromBuffer raw 0 - rest <- lazyRead h - return (handle_, c : rest) - - 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 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] -unpackAcc buf r 0 acc = return "" -unpackAcc buf (I## r) (I## len) acc = IO $ \s -> unpack acc (len -## 1##) s - where - unpack acc i s - | i <## r = (## s, acc ##) - | otherwise = - case readCharArray## buf i s of - (## s, ch ##) -> unpack (C## ch : acc) (i -## 1##) s - --- --------------------------------------------------------------------------- --- hPutChar - --- `hPutChar hdl ch' writes the character `ch' to the file or channel --- managed by `hdl'. Characters may be buffered if buffering is --- enabled for `hdl'. - -hPutChar :: Handle -> Char -> IO () -hPutChar handle c = - c `seq` do -- must evaluate c before grabbing the handle lock - wantWritableHandle "hPutChar" handle $ \ handle_ -> do - let fd = haFD handle_ - case haBufferMode handle_ of - LineBuffering -> hPutcBuffered handle_ True c - BlockBuffering _ -> hPutcBuffered handle_ False c - NoBuffering -> - withObject (castCharToCChar c) $ \buf -> - throwErrnoIfMinus1RetryMayBlock_ "hPutChar" - (c_write (fromIntegral fd) buf 1) - (threadWaitWrite fd) - - -hPutcBuffered handle_ is_line c = do - let ref = haBuffer handle_ - buf <- readIORef ref - let w = bufWPtr buf - w' <- writeCharIntoBuffer (bufBuf buf) w c - let new_buf = buf{ bufWPtr = w' } - if bufferFull new_buf || is_line && c == '\n' - then do - flushed_buf <- flushWriteBuffer (haFD handle_) new_buf - writeIORef ref flushed_buf - else do - writeIORef ref new_buf - - -hPutChars :: Handle -> [Char] -> IO () -hPutChars handle [] = return () -hPutChars handle (c:cs) = hPutChar handle c >> hPutChars handle cs - --- --------------------------------------------------------------------------- --- hPutStr - --- `hPutStr hdl s' writes the string `s' to the file or --- hannel managed by `hdl', buffering the output if needs be. - --- We go to some trouble to avoid keeping the handle locked while we're --- evaluating the string argument to hPutStr, in case doing so triggers another --- I/O operation on the same handle which would lead to deadlock. The classic --- case is --- --- putStr (trace "hello" "world") --- --- so the basic scheme is this: --- --- * copy the string into a fresh buffer, --- * "commit" the buffer to the handle. --- --- Committing may involve simply copying the contents of the new --- buffer into the handle's buffer, flushing one or both buffers, or --- maybe just swapping the buffers over (if the handle's buffer was --- empty). See commitBuffer below. - -hPutStr :: Handle -> String -> IO () -hPutStr handle str = do - buffer_mode <- wantWritableHandle "hPutStr" handle - (\ handle_ -> do getSpareBuffer handle_) - case buffer_mode of - (NoBuffering, _) -> do - hPutChars handle str -- v. slow, but we don't care - (LineBuffering, buf) -> do - writeLines handle buf str - (BlockBuffering _, buf) -> do - writeBlocks handle buf str - - -getSpareBuffer :: Handle__ -> IO (BufferMode, Buffer) -getSpareBuffer Handle__{haBuffer=ref, - haBuffers=spare_ref, - haBufferMode=mode} - = do - case mode of - NoBuffering -> return (mode, error "no buffer!") - _ -> do - bufs <- readIORef spare_ref - buf <- readIORef ref - case bufs of - BufferListCons b rest -> do - writeIORef spare_ref rest - return ( mode, newEmptyBuffer b WriteBuffer (bufSize buf)) - BufferListNil -> do - new_buf <- allocateBuffer (bufSize buf) WriteBuffer - return (mode, new_buf) - - -writeLines :: Handle -> Buffer -> String -> IO () -writeLines hdl Buffer{ bufBuf=raw, bufSize=len } s = - let - shoveString :: Int -> [Char] -> IO () - -- 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 - 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 - 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 - -writeBlocks :: Handle -> Buffer -> String -> IO () -writeBlocks hdl Buffer{ bufBuf=raw, bufSize=len } s = - let - shoveString :: Int -> [Char] -> IO () - -- 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 - 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 - in - shoveString 0 s - --- ----------------------------------------------------------------------------- --- commitBuffer handle buf sz count flush release --- --- 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. - -commitBuffer - :: Handle -- handle to commit to - -> RawBuffer -> Int -- address and size (in bytes) of buffer - -> Int -- number of bytes of data in buffer - -> Bool -- True <=> flush the handle afterward - -> Bool -- release the buffer? - -> IO Buffer - -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 - ++ ", flush=" ++ show flush ++ ", release=" ++ show release ++"\n") -#endif - - old_buf@Buffer{ bufBuf=old_raw, bufRPtr=r, bufWPtr=w, bufSize=size } - <- readIORef ref - - buf_ret <- - -- enough room in handle buffer? - if (not flush && (size - w > 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. - - -- not flushing, and there's enough room in the buffer: - -- just copy the data in and update bufWPtr. - then do memcpy_off old_raw w raw (fromIntegral count) - writeIORef ref old_buf{ bufWPtr = w + count } - return (newEmptyBuffer raw WriteBuffer sz) - - -- else, we have to flush - else do flushed_buf <- flushWriteBuffer fd old_buf - - let this_buf = - Buffer{ bufBuf=raw, bufState=WriteBuffer, - bufRPtr=0, bufWPtr=count, bufSize=sz } - - -- 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... - if (not flush && sz == size && count /= sz) - then do - writeIORef ref this_buf - return flushed_buf - - -- otherwise, we have to flush the new data too, - -- and start with a fresh buffer - else do - flushWriteBuffer fd this_buf - writeIORef ref flushed_buf - -- if the sizes were different, then allocate - -- a new buffer of the correct size. - if sz == size - then return (newEmptyBuffer raw WriteBuffer sz) - else allocateBuffer size WriteBuffer - - -- release the buffer if necessary - 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 buf_ret_raw spare_bufs) - return buf_ret - else - return buf_ret - - -foreign import "memcpy_PrelIO_wrap" unsafe - memcpy_off :: RawBuffer -> Int -> RawBuffer -> CSize -> IO (Ptr ()) -#def inline \ -void *memcpy_PrelIO_wrap(char *dst, HsInt dst_off, const char *src, size_t sz) \ -{ return memcpy(dst+dst_off, src, sz); } - --- --------------------------------------------------------------------------- --- hPutStrLn - --- Derived action `hPutStrLn hdl str' writes the string `str' to --- the handle `hdl', adding a newline at the end. - -hPutStrLn :: Handle -> String -> IO () -hPutStrLn hndl str = do - hPutStr hndl str - hPutChar hndl '\n' - --- --------------------------------------------------------------------------- --- hPrint - --- Computation `hPrint hdl t' writes the string representation of `t' --- given by the `shows' function to the file or channel managed by `hdl'. - -hPrint :: Show a => Handle -> a -> IO () -hPrint hdl = hPutStrLn hdl . show -- 1.7.10.4