newEmptyBuffer, allocateBuffer, readCharFromBuffer, writeCharIntoBuffer,
flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, fillReadBuffer,
- read_off, read_off_ba,
- write_off, write_off_ba, unlockFile,
+ readRawBuffer, readRawBufferPtr,
+ writeRawBuffer, writeRawBufferPtr,
+ unlockFile,
+
+ {- ought to be unnecessary, but just in case.. -}
+ write_off, write_rawBuffer,
+ read_off, read_rawBuffer,
ioe_closedHandle, ioe_EOF, ioe_notReadable, ioe_notWritable,
) where
+#include "config.h"
+
import Control.Monad
import Data.Bits
import Data.Maybe
import Foreign
import Foreign.C
import System.IO.Error
+import System.Posix.Internals
-import GHC.Posix
import GHC.Real
import GHC.Arr
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- (h',v) <- catch (act h_)
- (\ ex -> putMVar m h_ >> ioError (augmentIOError ex fun h h_))
+ (h',v) <- catchException (act h_)
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h h_)
+ _ -> throw err)
checkBufferInvariants h'
putMVar m h'
return v
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- v <- catch (act h_)
- (\ ex -> putMVar m h_ >> ioError (augmentIOError ex fun h h_))
+ v <- catchException (act h_)
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h h_)
+ _ -> throw err)
checkBufferInvariants h_
putMVar m h_
return v
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- h' <- catch (act h_)
- (\ ex -> putMVar m h_ >> ioError (augmentIOError ex fun h h_))
+ h' <- catchException (act h_)
+ (\ err -> putMVar m h_ >>
+ case err of
+ IOException ex -> ioError (augmentIOError ex fun h h_)
+ _ -> throw err)
checkBufferInvariants h'
putMVar m h'
return ()
handleFinalizer :: MVar Handle__ -> IO ()
handleFinalizer m = do
- h_ <- takeMVar m
- let
- -- hClose puts both the fd and the handle's type
- -- into a closed state, so it's a bit excessive
- -- to test for both here, but caution sometimes
- -- pays off..
- alreadyClosed =
- case haType h_ of { ClosedHandle{} -> True; _ -> False }
- fd = fromIntegral (haFD h_)
-
- when (not alreadyClosed && fd /= -1) $ do
- flushWriteBufferOnly h_
- unlockFile fd
-#ifdef mingw32_TARGET_OS
- (closeFd (haIsStream h_) fd >> return ())
-#else
- (c_close fd >> return ())
-#endif
+ handle_ <- takeMVar m
+ case haType handle_ of
+ ClosedHandle -> return ()
+ _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
+ -- ignore errors and async exceptions, and close the
+ -- descriptor anyway...
+ hClose_handle_ handle_
+ return ()
-- ---------------------------------------------------------------------------
-- Grimy buffer operations
allocateBuffer :: Int -> BufferState -> IO Buffer
allocateBuffer sz@(I# size) state = IO $ \s ->
+#ifdef mingw32_TARGET_OS
+ -- To implement asynchronous I/O under Win32, we have to pass
+ -- buffer references to external threads that handles the
+ -- filling/emptying of their contents. Hence, the buffer cannot
+ -- be moved around by the GC.
+ case newPinnedByteArray# size s of { (# s, b #) ->
+#else
case newByteArray# size s of { (# s, b #) ->
+#endif
(# s, newEmptyBuffer b state sz #) }
writeCharIntoBuffer :: RawBuffer -> Int -> Char -> IO Int
if bytes == 0
then return (buf{ bufRPtr=0, bufWPtr=0 })
else do
- res <- throwErrnoIfMinus1RetryMayBlock "flushWriteBuffer"
- (write_off_ba (fromIntegral fd) is_stream b (fromIntegral r)
- (fromIntegral bytes))
- (threadWaitWrite fd)
+ res <- writeRawBuffer "flushWriteBuffer" (fromIntegral fd) is_stream b
+ (fromIntegral r) (fromIntegral bytes)
let res' = fromIntegral res
if res' < bytes
then flushWriteBuffer fd is_stream (buf{ bufRPtr = r + res' })
else return buf{ bufRPtr=0, bufWPtr=0 }
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_off_ba :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
-
-foreign import ccall unsafe "__hscore_PrelHandle_write"
- write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
-
fillReadBuffer :: FD -> Bool -> Bool -> Buffer -> IO Buffer
fillReadBuffer fd is_line is_stream
buf@Buffer{ bufBuf=b, bufRPtr=r, bufWPtr=w, bufSize=size } =
#ifdef DEBUG_DUMP
puts ("fillReadBufferLoop: bytes = " ++ show bytes ++ "\n")
#endif
- res <- throwErrnoIfMinus1RetryMayBlock "fillReadBuffer"
- (read_off_ba fd is_stream b (fromIntegral w) (fromIntegral bytes))
- (threadWaitRead fd)
+ res <- readRawBuffer "fillReadBuffer" fd is_stream b
+ (fromIntegral w) (fromIntegral bytes)
let res' = fromIntegral res
#ifdef DEBUG_DUMP
puts ("fillReadBufferLoop: res' = " ++ show res' ++ "\n")
then fillReadBufferLoop fd is_line is_stream buf b (w+res') size
else return buf{ bufRPtr=0, bufWPtr=w+res' }
+
+-- Low level routines for reading/writing to (raw)buffers:
+
+#ifndef mingw32_TARGET_OS
+readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBuffer loc fd is_stream buf off len =
+ throwErrnoIfMinus1RetryMayBlock loc
+ (read_rawBuffer fd is_stream buf off len)
+ (threadWaitRead fd)
+
+readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+readRawBufferPtr loc fd is_stream buf off len =
+ throwErrnoIfMinus1RetryMayBlock loc
+ (read_off fd is_stream buf off len)
+ (threadWaitRead fd)
+
+writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+writeRawBuffer loc fd is_stream buf off len =
+ throwErrnoIfMinus1RetryMayBlock loc
+ (write_rawBuffer (fromIntegral fd) is_stream buf off len)
+ (threadWaitWrite fd)
+
+writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+writeRawBufferPtr loc fd is_stream buf off len =
+ throwErrnoIfMinus1RetryMayBlock loc
+ (write_off (fromIntegral fd) is_stream buf off len)
+ (threadWaitWrite fd)
+
foreign import ccall unsafe "__hscore_PrelHandle_read"
- read_off_ba :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+ read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
foreign import ccall unsafe "__hscore_PrelHandle_read"
read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+
+#else
+readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+readRawBuffer loc fd is_stream buf off len = do
+ (l, rc) <- asyncReadBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+readRawBufferPtr loc fd is_stream buf off len = do
+ (l, rc) <- asyncRead fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+writeRawBuffer loc fd is_stream buf off len = do
+ (l, rc) <- asyncWriteBA fd (if is_stream then 1 else 0) (fromIntegral len) off buf
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+writeRawBufferPtr loc fd is_stream buf off len = do
+ (l, rc) <- asyncWrite fd (if is_stream then 1 else 0) (fromIntegral len) (buf `plusPtr` off)
+ if l == (-1)
+ then
+ ioError (errnoToIOError loc (Errno (fromIntegral rc)) Nothing Nothing)
+ else return (fromIntegral l)
+
+foreign import ccall unsafe "__hscore_PrelHandle_read"
+ read_rawBuffer :: FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_PrelHandle_read"
+ read_off :: FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_rawBuffer :: CInt -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
+
+foreign import ccall unsafe "__hscore_PrelHandle_write"
+ write_off :: CInt -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+
+#endif
+
-- ---------------------------------------------------------------------------
-- Standard Handles
}
read_side <- newMVar r_handle_
- addMVarFinalizer read_side (handleFinalizer read_side)
+ addMVarFinalizer write_side (handleFinalizer write_side)
return (DuplexHandle read_side write_side)
hClose_help handle_ =
case haType handle_ of
ClosedHandle -> return handle_
- _ -> do
- let fd = haFD handle_
- c_fd = fromIntegral fd
-
- flushWriteBufferOnly handle_
-
- -- close the file descriptor, but not when this is the read
- -- side of a duplex handle, and not when this is one of the
- -- std file handles.
- case haOtherSide handle_ of
- Nothing ->
- when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
- throwErrnoIfMinus1Retry_ "hClose"
+ _ -> do flushWriteBufferOnly handle_ -- interruptible
+ hClose_handle_ handle_
+
+hClose_handle_ handle_ = do
+ let fd = haFD handle_
+ c_fd = fromIntegral fd
+
+ -- close the file descriptor, but not when this is the read
+ -- side of a duplex handle, and not when this is one of the
+ -- std file handles.
+ case haOtherSide handle_ of
+ Nothing ->
+ when (fd /= fd_stdin && fd /= fd_stdout && fd /= fd_stderr) $
+ throwErrnoIfMinus1Retry_ "hClose"
#ifdef mingw32_TARGET_OS
(closeFd (haIsStream handle_) c_fd)
#else
(c_close c_fd)
#endif
- Just _ -> return ()
-
- -- free the spare buffers
- writeIORef (haBuffers handle_) BufferListNil
+ Just _ -> return ()
- -- unlock it
- unlockFile c_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
- })
+ -- free the spare buffers
+ writeIORef (haBuffers handle_) BufferListNil
+
+ -- unlock it
+ unlockFile c_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
is_tty <- fdIsTTY (haFD handle_)
when (is_tty && isReadableHandleType (haType handle_)) $
case mode of
+#ifndef mingw32_TARGET_OS
+ -- 'raw' mode under win32 is a bit too specialised (and troublesome
+ -- for most common uses), so simply disable its use here.
NoBuffering -> setCooked (haFD handle_) False
+#endif
_ -> setCooked (haFD handle_) True
-- throw away spare buffers, they might be the wrong size
|| tEXT_MODE_SEEK_ALLOWED))
-- -----------------------------------------------------------------------------
--- Changing echo status
+-- Changing echo status (Non-standard GHC extensions)
--- Non-standard GHC extension is to allow the echoing status
--- of a handles connected to terminals to be reconfigured:
+-- | Set the echoing status of a handle connected to a terminal (GHC only).
hSetEcho :: Handle -> Bool -> IO ()
hSetEcho handle on = do
ClosedHandle -> ioe_closedHandle
_ -> setEcho (haFD handle_) on
+-- | Get the echoing status of a handle connected to a terminal (GHC only).
+
hGetEcho :: Handle -> IO Bool
hGetEcho handle = do
isT <- hIsTerminalDevice handle
ClosedHandle -> ioe_closedHandle
_ -> getEcho (haFD handle_)
+-- | Is the handle connected to a terminal? (GHC only)
+
hIsTerminalDevice :: Handle -> IO Bool
hIsTerminalDevice handle = do
withHandle_ "hIsTerminalDevice" handle $ \ handle_ -> do
#ifdef DEBUG_DUMP
puts :: String -> IO ()
-puts s = withCString s $ \cstr -> do write_off_ba 1 False cstr 0 (fromIntegral (length s))
+puts s = withCString s $ \cstr -> do write_rawBuffer 1 False cstr 0 (fromIntegral (length s))
return ()
#endif
projects / ghc-base.git / blobdiff