From: Simon Marlow <simonmar@microsoft.com>
Date: Thu, 24 Jan 2008 09:22:03 +0000 (+0000)
Subject: FIX #1936: hGetBufNonBlocking was blocking on stdin/stdout/stderr
X-Git-Tag: 2008-05-28~80
X-Git-Url: http://git.megacz.com/?a=commitdiff_plain;ds=sidebyside;h=52a9458efa0639b26c12111961f3df53d1b6c12a;p=ghc-base.git

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

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index 43eb55c..e175b12 100644
--- 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
--- 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