FIX #1936: hGetBufNonBlocking was blocking on stdin/stdout/stderr

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 43eb55c..e175b12 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -27,6 +27,7 @@ module GHC.Handle (
   flushWriteBufferOnly, flushWriteBuffer, flushReadBuffer, 
   fillReadBuffer, fillReadBufferWithoutBlocking,
   readRawBuffer, readRawBufferPtr,
+  readRawBufferNoBlock, readRawBufferPtrNoBlock,
   writeRawBuffer, writeRawBufferPtr,
 
 #ifndef mingw32_HOST_OS
@@ -589,6 +590,18 @@ readRawBufferNoBlock loc fd is_nonblock buf off len
    unsafe_read  = do_read (read_rawBuffer fd buf off len)
    safe_read    = do_read (safe_read_rawBuffer fd buf off len)
 
+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
+                      if r /= 0 then safe_read
+                                else return 0
+       -- XXX see note [nonblock]
+ where
+   do_read call = throwErrnoIfMinus1RetryOnBlock loc call (return 0)
+   unsafe_read  = do_read (read_off fd buf off len)
+   safe_read    = do_read (safe_read_off fd buf off len)
+
 writeRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 writeRawBuffer loc fd is_nonblock buf off len
   | is_nonblock = unsafe_write
@@ -658,6 +671,8 @@ writeRawBufferPtr loc fd is_stream buf off len
 readRawBufferNoBlock :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt
 readRawBufferNoBlock = readRawBuffer
 
+readRawBufferPtrNoBlock :: String -> FD -> Bool -> Ptr CChar -> Int -> CInt -> IO CInt
+readRawBufferPtrNoBlock = readRawBufferPtr
 -- Async versions of the read/write primitives, for the non-threaded RTS
 
 asyncReadRawBuffer loc fd is_stream buf off len = do

diff --git a/GHC/IO.hs b/GHC/IO.hs
index 8d167e8..151d251 100644 (file)
--- a/GHC/IO.hs
+++ b/GHC/IO.hs
@@ -906,24 +906,13 @@ bufReadNonBlocking fd ref is_stream ptr so_far count =
 
 readChunkNonBlocking :: FD -> Bool -> Ptr a -> Int -> IO Int
 readChunkNonBlocking fd is_stream ptr bytes = do
-#ifndef mingw32_HOST_OS
-    ssize <- c_read fd (castPtr ptr) (fromIntegral bytes)
-    let r = fromIntegral ssize :: Int
-    if (r == -1)
-      then do errno <- getErrno
-             if (errno == eAGAIN || errno == eWOULDBLOCK)
-                then return 0
-                else throwErrno "readChunk"
-      else return r
-#else
     fromIntegral `liftM`
-        readRawBufferPtr "readChunkNonBlocking" fd is_stream 
+        readRawBufferPtrNoBlock "readChunkNonBlocking" fd is_stream 
                            (castPtr ptr) 0 (fromIntegral bytes)
 
     -- we don't have non-blocking read support on Windows, so just invoke
     -- the ordinary low-level read which will block until data is available,
     -- but won't wait for the whole buffer to fill.
-#endif
 
 slurpFile :: FilePath -> IO (Ptr (), Int)
 slurpFile fname = do