Opened 3 months ago

Last modified 2 months ago

#8684 patch bug

hWaitForInput cannot be interrupted by async exceptions on unix

Reported by: nh2 Owned by:
Priority: normal Milestone:
Component: libraries/base Version: 7.6.3
Keywords: Cc: mail@…
Operating System: Unknown/Multiple Architecture: Unknown/Multiple
Type of failure: None/Unknown Difficulty: Unknown
Test Case: Blocked By:
Blocking: Related Tickets:

Description

http://hackage.haskell.org/package/base-4.6.0.1/docs/System-Timeout.html

claims that timeout can interrupt hWaitForInput, but in fact that's false (e.g. mentioned in https://ghc.haskell.org/trac/ghc/ticket/7353#comment:4).

-- import Control.Concurrent
import System.IO
import System.Timeout

main = timeout (1 * 1000000) $ hWaitForInput stdin (5 * 1000)

will not be killed after 1 second, but instead wait for the full 5 seconds timeout passed to hWaitForInput.

The implementation is ready at http://www.haskell.org/ghc/docs/latest/html/libraries/base/src/GHC-IO-FD.html, where we have two foreign calls: safe fdReady and unsafe unsafe_fdReady.

The actual C implementation is at https://github.com/haskell-suite/base/blob/master/cbits/inputReady.c#L16. It uses select on Unix, and does check for EINTR, so I believe that according to http://www.haskell.org/ghc/docs/7.6.3/html/users_guide/ffi.html#ffi-interruptible both foreign calls can be replaced by a single interruptible one.

Is that true?

If not, it's a documentation bug in timeout at least.

Also, does interruptible, apart from allowing the function to be interrupted, behave more like safe or unsafe?

Change History (4)

comment:1 in reply to: ↑ description ; follow-up: Changed 3 months ago by ezyang

Replying to nh2:

Is that true?

This would work fine for Unix. It would be good to test if it does the right thing with CancelSynchronousIO as well.

Also, does interruptible, apart from allowing the function to be interrupted, behave more like safe or unsafe?

Interruptible acts like safe, except for the extra signal throwing behavior.

comment:2 in reply to: ↑ 1 Changed 3 months ago by nh2

Replying to ezyang:

This would work fine for Unix. It would be good to test if it does the right thing with CancelSynchronousIO as well.

Ah, great.

I guess we should update the documentation until this is actually implemented.

comment:3 Changed 2 months ago by lnandor

I have tried to fix the bug by replacing select with pselect to ignore the SIGVTALRM signal sent by the runtime, but to properly terminate when SIGPIPE is received.
https://github.com/nandor/packages-base/compare/fix-8684?expand=1

diff --git a/GHC/IO/FD.hs b/GHC/IO/FD.hs
index 2023526..0b0b1de 100644
--- a/GHC/IO/FD.hs
+++ b/GHC/IO/FD.hs
@@ -3,6 +3,7 @@
            , NoImplicitPrelude
            , BangPatterns
            , DeriveDataTypeable
+           , InterruptibleFFI
   #-}
 {-# OPTIONS_GHC -fno-warn-identities #-}
 -- Whether there are identities depends on the platform
@@ -395,7 +396,7 @@ setNonBlockingMode fd set = do
 
 ready :: FD -> Bool -> Int -> IO Bool
 ready fd write msecs = do
-  r <- throwErrnoIfMinus1Retry "GHC.IO.FD.ready" $
+  r <- throwErrnoIfMinus1 "GHC.IO.FD.ready" $
           fdReady (fdFD fd) (fromIntegral $ fromEnum $ write)
                             (fromIntegral msecs)
 #if defined(mingw32_HOST_OS)
@@ -405,7 +406,7 @@ ready fd write msecs = do
 #endif
   return (toEnum (fromIntegral r))
 
-foreign import ccall safe "fdReady"
+foreign import ccall interruptible "fdReady"
   fdReady :: CInt -> CInt -> CInt -> CInt -> IO CInt
 
 -- ---------------------------------------------------------------------------
@@ -502,7 +503,7 @@ indicates that there's no data, we call threadWaitRead.
 readRawBufferPtr :: String -> FD -> Ptr Word8 -> Int -> CSize -> IO Int
 readRawBufferPtr loc !fd buf off len
   | isNonBlocking fd = unsafe_read -- unsafe is ok, it can't block
-  | otherwise    = do r <- throwErrnoIfMinus1 loc 
+  | otherwise    = do r <- throwErrnoIfMinus1Retry loc
                                 (unsafe_fdReady (fdFD fd) 0 0 0)
                       if r /= 0
                         then read
diff --git a/GHC/IO/Handle/Text.hs b/GHC/IO/Handle/Text.hs
index f182e7f..31f2cac 100644
--- a/GHC/IO/Handle/Text.hs
+++ b/GHC/IO/Handle/Text.hs
@@ -106,7 +106,6 @@ hWaitForInput h msecs = do
                writeIORef haCharBuffer cbuf'
 
                if not (isEmptyBuffer cbuf') then return True else do
-
                 r <- IODevice.ready haDevice False{-read-} msecs
                 if r then do -- Call hLookAhead' to throw an EOF
                              -- exception if appropriate
diff --git a/cbits/inputReady.c b/cbits/inputReady.c
index 51f278f..9d51750 100644
--- a/cbits/inputReady.c
+++ b/cbits/inputReady.c
@@ -22,9 +22,10 @@ fdReady(int fd, int write, int msecs, int isSock)
 #else
     ( 1 ) {
 #endif
-	int maxfd, ready;
+    int maxfd;
     fd_set rfd, wfd;
-	struct timeval tv;
+    struct timespec tv;
+    sigset_t set;
 
     FD_ZERO(&rfd);
     FD_ZERO(&wfd);
@@ -39,16 +40,14 @@ fdReady(int fd, int write, int msecs, int isSock)
      */
     maxfd = fd + 1;
     tv.tv_sec  = msecs / 1000;
-	tv.tv_usec = (msecs % 1000) * 1000;
+    tv.tv_nsec = (msecs % 1000) * 1000000;
 
-	while ((ready = select(maxfd, &rfd, &wfd, NULL, &tv)) < 0 ) {
-	    if (errno != EINTR ) {
-		return -1;
-	    }
-	}
+    /* Block SIGVTALRM */
+    sigprocmask(SIG_BLOCK, NULL, &set);
+    sigaddset(&set, SIGVTALRM);
 
     /* 1 => Input ready, 0 => not ready, -1 => error */
-	return (ready);
+    return pselect(maxfd, &rfd, &wfd, NULL, &tv, &set);
     }
 #if defined(_MSC_VER) || defined(__MINGW32__) || defined(_WIN32)
     else {

comment:4 Changed 2 months ago by nh2

  • Status changed from new to patch
Note: See TracTickets for help on using tickets.