Fix #2363: getChar cannot be interrupted with -threaded

Now in -threaded mode, instead of just making a blocking call to
read(), we call select() first to make sure the read() won't block,
and if it would block, then we use threadWaitRead.

The idea is that the current thread must be interruptible while it
blocks.  This is a little slower than before, but the overhead only
applies to blocking Handles (stdin/stdout/stderr, and those created by
System.Process).

diff --git a/GHC/Handle.hs b/GHC/Handle.hs
index ddec90f..bbab74d 100644 (file)
--- a/GHC/Handle.hs
+++ b/GHC/Handle.hs
@@ -546,42 +546,52 @@ cases are wrong here.  The cases that are wrong:
     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 False)
                       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 False)
                       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 False
                       if r /= 0 then safe_read
                                 else return 0
        -- XXX see note [nonblock]
@@ -592,8 +602,8 @@ readRawBufferNoBlock loc fd is_nonblock 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
+  | is_nonblock  = unsafe_read -- unsafe is ok, it can't block
+  | otherwise    = do r <- unsafe_fdReady (fromIntegral fd) 0 0 False
                       if r /= 0 then safe_read
                                 else return 0
        -- XXX see note [nonblock]
@@ -604,29 +614,29 @@ readRawBufferPtrNoBlock loc fd is_nonblock buf off len
 
 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 False
                      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 False
                      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)
 
@@ -645,6 +655,9 @@ foreign import ccall unsafe "__hscore_PrelHandle_write"
 foreign import ccall safe "fdReady"
   fdReady :: CInt -> CInt -> CInt -> Bool -> IO CInt
 
+foreign import ccall unsafe "fdReady"
+  unsafe_fdReady :: CInt -> CInt -> CInt -> Bool -> IO CInt
+
 #else /* mingw32_HOST_OS.... */
 
 readRawBuffer :: String -> FD -> Bool -> RawBuffer -> Int -> CInt -> IO CInt