[GHC] #8684: hWaitForInput cannot be interrupted by async exceptions on unix

[GHC]

#8684: hWaitForInput cannot be interrupted by async exceptions on unix
-------------------------------------+------------------------------------
        Reporter:  nh2               |            Owner:
            Type:  bug               |           Status:  new
        Priority:  normal            |        Milestone:
       Component:  libraries/base    |          Version:  7.6.3
      Resolution:                    |         Keywords:
Operating System:  Unknown/Multiple  |     Architecture:  Unknown/Multiple
 Type of failure:  None/Unknown      |       Difficulty:  Unknown
       Test Case:                    |       Blocked By:
        Blocking:                    |  Related Tickets:
-------------------------------------+------------------------------------

Comment (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 {

 }}}

--
Ticket URL: <http://ghc.haskell.org/trac/ghc/ticket/8684#comment:3>
GHC <http://www.haskell.org/ghc/>
The Glasgow Haskell Compiler