-{-# OPTIONS_GHC -fno-implicit-prelude -#include "HsBase.h" #-}
+{-# OPTIONS_GHC -XNoImplicitPrelude -#include "HsBase.h" #-}
{-# OPTIONS_HADDOCK hide #-}
#undef DEBUG_DUMP
stdin, stdout, stderr,
IOMode(..), openFile, openBinaryFile, fdToHandle_stat, fdToHandle, fdToHandle',
- hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hSetBuffering, hSetBinaryMode,
+ hFileSize, hSetFileSize, hIsEOF, isEOF, hLookAhead, hLookAhead', hSetBuffering, hSetBinaryMode,
hFlush, hDuplicate, hDuplicateTo,
hClose, hClose_help,
) where
import Control.Monad
-import Data.Bits
import Data.Maybe
import Foreign
import Foreign.C
import GHC.Enum
import GHC.Num ( Integer(..), Num(..) )
import GHC.Show
-import GHC.Real ( toInteger )
#if defined(DEBUG_DUMP)
import GHC.Pack
#endif
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- (h',v) <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ (h',v) <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
checkBufferInvariants h'
putMVar m h'
return v
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- v <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ v <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
checkBufferInvariants h_
putMVar m h_
return v
block $ do
h_ <- takeMVar m
checkBufferInvariants h_
- h' <- catchException (act h_)
- (\ err -> putMVar m h_ >>
- case err of
- IOException ex -> ioError (augmentIOError ex fun h)
- _ -> throw err)
+ h' <- (act h_ `catchAny` \err -> putMVar m h_ >> throw err)
+ `catchException` \ex -> ioError (augmentIOError ex fun h)
checkBufferInvariants h'
putMVar m h'
return ()
"seek operations on text-mode handles are not allowed on this platform"
Nothing)
-ioe_finalizedHandle fp = throw (IOException
+ioe_finalizedHandle fp = throw
(IOError Nothing IllegalOperation ""
- "handle is finalized" (Just fp)))
+ "handle is finalized" (Just fp))
ioe_bufsiz :: Int -> IO a
ioe_bufsiz n = ioException
handle_ <- takeMVar m
case haType handle_ of
ClosedHandle -> return ()
- _ -> do flushWriteBufferOnly handle_ `catchException` \_ -> return ()
+ _ -> do flushWriteBufferOnly handle_ `catchAny` \_ -> return ()
-- ignore errors and async exceptions, and close the
-- descriptor anyway...
hClose_handle_ handle_
but that leaves a small race window where the data can be read
from the file descriptor before we issue our blocking read().
* readRawBufferNoBlock for a blocking FD
+
+NOTE [2363]:
+
+In the threaded RTS we could just make safe calls to read()/write()
+for file descriptors in blocking mode without worrying about blocking
+other threads, but the problem with this is that the thread will be
+uninterruptible while it is blocked in the foreign call. See #2363.
+So now we always call fdReady() before reading, and if fdReady
+indicates that there's no data, we call threadWaitRead.
+
-}
readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBuffer loc fd is_nonblock buf off len
- | is_nonblock = unsafe_read
- | threaded = safe_read
+ | is_nonblock = unsafe_read -- unsafe is ok, it can't block
| otherwise = do r <- throwErrnoIfMinus1 loc
- (fdReady (fromIntegral fd) 0 0 False)
+ (unsafe_fdReady (fromIntegral fd) 0 0 0)
if r /= 0
- then unsafe_read
- else do threadWaitRead (fromIntegral fd); unsafe_read
+ then read
+ else do threadWaitRead (fromIntegral fd); read
where
do_read call = throwErrnoIfMinus1RetryMayBlock loc call
(threadWaitRead (fromIntegral fd))
+ read = if threaded then safe_read else unsafe_read
unsafe_read = do_read (read_rawBuffer fd buf off len)
safe_read = do_read (safe_read_rawBuffer fd buf off len)
readRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
readRawBufferPtr loc fd is_nonblock buf off len
- | is_nonblock = unsafe_read
- | threaded = safe_read
+ | is_nonblock = unsafe_read -- unsafe is ok, it can't block
| otherwise = do r <- throwErrnoIfMinus1 loc
- (fdReady (fromIntegral fd) 0 0 False)
+ (unsafe_fdReady (fromIntegral fd) 0 0 0)
if r /= 0
- then unsafe_read
- else do threadWaitRead (fromIntegral fd); unsafe_read
+ then read
+ else do threadWaitRead (fromIntegral fd); read
where
- do_read call = throwErrnoIfMinus1RetryMayBlock loc call
- (threadWaitRead (fromIntegral fd))
- unsafe_read = do_read (read_off fd buf off len)
- safe_read = do_read (safe_read_off fd buf off len)
+ do_read call = throwErrnoIfMinus1RetryMayBlock loc call
+ (threadWaitRead (fromIntegral fd))
+ read = if threaded then safe_read else unsafe_read
+ unsafe_read = do_read (read_off fd buf off len)
+ safe_read = do_read (safe_read_off fd buf off len)
readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
readRawBufferNoBlock loc fd is_nonblock buf off len
- | is_nonblock = unsafe_read
- | otherwise = do r <- fdReady (fromIntegral fd) 0 0 False
+ | is_nonblock = unsafe_read -- unsafe is ok, it can't block
+ | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0
if r /= 0 then safe_read
else return 0
-- XXX see note [nonblock]
readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
readRawBufferPtrNoBlock loc fd is_nonblock buf off len
- | is_nonblock = unsafe_read
- | otherwise = do r <- fdReady (fromIntegral fd) 0 0 False
+ | is_nonblock = unsafe_read -- unsafe is ok, it can't block
+ | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 0 0 0
if r /= 0 then safe_read
else return 0
-- XXX see note [nonblock]
writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
writeRawBuffer loc fd is_nonblock buf off len
- | is_nonblock = unsafe_write
- | threaded = safe_write
- | otherwise = do r <- fdReady (fromIntegral fd) 1 0 False
+ | is_nonblock = unsafe_write -- unsafe is ok, it can't block
+ | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0
if r /= 0
- then safe_write
- else do threadWaitWrite (fromIntegral fd); unsafe_write
+ then write
+ else do threadWaitWrite (fromIntegral fd); write
where
do_write call = throwErrnoIfMinus1RetryMayBlock loc call
(threadWaitWrite (fromIntegral fd))
+ write = if threaded then safe_write else unsafe_write
unsafe_write = do_write (write_rawBuffer fd buf off len)
safe_write = do_write (safe_write_rawBuffer (fromIntegral fd) buf off len)
writeRawBufferPtr :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
writeRawBufferPtr loc fd is_nonblock buf off len
- | is_nonblock = unsafe_write
- | threaded = safe_write
- | otherwise = do r <- fdReady (fromIntegral fd) 1 0 False
+ | is_nonblock = unsafe_write -- unsafe is ok, it can't block
+ | otherwise = do r <- unsafe_fdReady (fromIntegral fd) 1 0 0
if r /= 0
- then safe_write
- else do threadWaitWrite (fromIntegral fd); unsafe_write
+ then write
+ else do threadWaitWrite (fromIntegral fd); write
where
do_write call = throwErrnoIfMinus1RetryMayBlock loc call
(threadWaitWrite (fromIntegral fd))
+ write = if threaded then safe_write else unsafe_write
unsafe_write = do_write (write_off fd buf off len)
safe_write = do_write (safe_write_off (fromIntegral fd) buf off len)
foreign import ccall unsafe "__hscore_PrelHandle_write"
write_off :: CInt -> Ptr CChar -> Int -> CInt -> IO CInt
-foreign import ccall safe "fdReady"
- fdReady :: CInt -> CInt -> CInt -> Bool -> IO CInt
+foreign import ccall unsafe "fdReady"
+ unsafe_fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
#else /* mingw32_HOST_OS.... */
stat@(fd_type,_,_) <- fdStat fd
h <- fdToHandle_stat fd (Just stat) False filepath mode binary
- `catchException` \e -> do c_close fd; throw e
+ `catchAny` \e -> do c_close fd; throw e
-- NB. don't forget to close the FD if fdToHandle' fails, otherwise
-- this FD leaks.
-- ASSERT: if we just created the file, then fdToHandle' won't fail
-> IO Handle
fdToHandle_stat fd mb_stat is_socket filepath mode binary = do
- -- turn on non-blocking mode
- setNonBlockingFD fd
#ifdef mingw32_HOST_OS
- -- On Windows, the is_stream flag indicates that the Handle is a socket
- let is_stream = is_socket
+ -- On Windows, the is_socket flag indicates that the Handle is a socket
#else
- -- On Unix, the is_stream flag indicates that the FD is non-blocking
- let is_stream = True
+ -- On Unix, the is_socket flag indicates that the FD can be made non-blocking
+ let non_blocking = is_socket
+
+ when non_blocking $ setNonBlockingFD fd
+ -- turn on non-blocking mode
#endif
let (ha_type, write) =
-- regular files need to be locked
RegularFile -> do
#ifndef mingw32_HOST_OS
+ -- On Windows we use explicit exclusion via sopen() to implement
+ -- this locking (see __hscore_open()); on Unix we have to
+ -- implment it in the RTS.
r <- lockFile fd dev ino (fromBool write)
when (r == -1) $
ioException (IOError Nothing ResourceBusy "openFile"
"file is locked" Nothing)
#endif
- mkFileHandle fd is_stream filepath ha_type binary
+ mkFileHandle fd is_socket filepath ha_type binary
Stream
-- only *Streams* can be DuplexHandles. Other read/write
-- Handles must share a buffer.
| ReadWriteHandle <- ha_type ->
- mkDuplexHandle fd is_stream filepath binary
+ mkDuplexHandle fd is_socket filepath binary
| otherwise ->
- mkFileHandle fd is_stream filepath ha_type binary
+ mkFileHandle fd is_socket filepath ha_type binary
RawDevice ->
- mkFileHandle fd is_stream filepath ha_type binary
+ mkFileHandle fd is_socket filepath ha_type binary
-- | Old API kept to avoid breaking clients
fdToHandle' :: FD -> Maybe FDType -> Bool -> FilePath -> IOMode -> Bool
fdToHandle fd = do
mode <- fdGetMode fd
let fd_str = "<file descriptor: " ++ show fd ++ ">"
- fdToHandle_stat fd Nothing False{-XXX!-} fd_str mode True{-bin mode-}
-
+ fdToHandle_stat fd Nothing False fd_str mode True{-bin mode-}
+ -- NB. the is_socket flag is False, meaning that:
+ -- on Unix the file descriptor will *not* be put in non-blocking mode
+ -- on Windows we're guessing this is not a socket (XXX)
#ifndef mingw32_HOST_OS
foreign import ccall unsafe "lockFile"
-- then closed immediately. We have to be careful with DuplexHandles
-- though: we have to leave the closing to the finalizer in that case,
-- because the write side may still be in use.
-hClose_help :: Handle__ -> IO (Handle__, Maybe Exception)
+hClose_help :: Handle__ -> IO (Handle__, Maybe SomeException)
hClose_help handle_ =
case haType handle_ of
ClosedHandle -> return (handle_,Nothing)
_ -> do flushWriteBufferOnly handle_ -- interruptible
hClose_handle_ handle_
+hClose_handle_ :: Handle__ -> IO (Handle__, Maybe SomeException)
hClose_handle_ handle_ = do
let fd = haFD handle_
-- * 'isEOFError' if the end of file has been reached.
hLookAhead :: Handle -> IO Char
-hLookAhead handle = do
- wantReadableHandle "hLookAhead" handle $ \handle_ -> do
+hLookAhead handle =
+ wantReadableHandle "hLookAhead" handle hLookAhead'
+
+hLookAhead' :: Handle__ -> IO Char
+hLookAhead' handle_ = do
let ref = haBuffer handle_
fd = haFD handle_
is_line = haBufferMode handle_ == LineBuffering
new_buf <- if bufferEmpty buf
then fillReadBuffer fd True (haIsStream handle_) buf
else return buf
-
+
writeIORef ref new_buf
(c,_) <- readCharFromBuffer (bufBuf buf) (bufRPtr buf)
projects / ghc-base.git / blobdiff