[GHC] #13903: KQueue evtmgr backend fails to register for write events

[GHC]

#13903: KQueue evtmgr backend fails to register for write events
-------------------------------------+-------------------------------------
           Reporter:  waldheinz      |             Owner:  (none)
               Type:  bug            |            Status:  new
           Priority:  normal         |         Milestone:
          Component:  Runtime        |           Version:  8.0.2
  System                             |
           Keywords:                 |  Operating System:  FreeBSD
       Architecture:                 |   Type of failure:  Incorrect result
  Unknown/Multiple                   |  at runtime
          Test Case:                 |        Blocked By:
           Blocking:                 |   Related Tickets:
Differential Rev(s):                 |         Wiki Page:
-------------------------------------+-------------------------------------
 The root of the problem is that the `GHC.Event.KQueue.toFilter` function
 has type `GHC.Event.Internal.Event -> Filter` with GHC's `Event` being a
 bitmask which can represent read events, write events or a combination of
 those.

 It happens that the event manager requests it's backend to be notified
 about read ''and'' write events on some fd, and because the kqueue
 `EVFILT_*`s are ''not'' bitmasks, the above function cannot capture this,
 silently dropping the desire to be notified about write events.

 The following program triggers the problematic behaviour:

 {{{

 import           Control.Concurrent ( forkIO, killThread )
 import           Control.Exception ( finally )
 import           Control.Monad.Trans.Resource ( runResourceT )
 import           Control.Monad.IO.Class ( liftIO )
 import qualified Data.ByteString as BS
 import           Data.Conduit ( ($$), ($=) )
 import qualified Data.Conduit.Binary as CB
 import qualified Data.Conduit.List as CL
 import qualified Data.Conduit.Network as CN
 import           Data.IORef ( newIORef, modifyIORef', readIORef)

 main :: IO ()
 main = CN.runTCPClient (CN.clientSettings 5555 "192.168.2.11") client
   where
     logMsg cnt = CL.mapM $ \bs -> liftIO $ do
         modifyIORef' cnt (+ 1)
         readIORef cnt >>= \x -> putStrLn $
             "msg #" ++ show x ++  " of size: " ++ show (BS.length bs)
         return bs

     client ad = do
         reader <- forkIO (runResourceT $ CN.appSource ad
             $$ CL.mapM_ ( \bs -> (liftIO . putStrLn) $
                 "read " ++ show (BS.length bs) ++ " bytes"))
         cnt <- newIORef ( 0 :: Int )

         let
             runPipe = runResourceT $ CB.sourceFile "cool-linux-distro.iso"
                 $$ logMsg cnt
                 $= CN.appSink ad

         runPipe `finally` (killThread reader)
 }}}

 Having a `nc -l -p 5555 > /dev/null` running on another machine is
 sufficient to sink the data.

 Assuming that we can read `bigfile.iso` faster than we can send out over
 the socket, the `send` syscall will at some point give an `EAGAIN` as can
 be seen in the `truss` output:

 {{{
 write(1,"msg #20 of size: 32752\n",23)           = 23 (0x17)
 sendto(12,"\f\2409\0\M^RA\^T\M-&A\M-'\M-d8"...,32752,0x0,NULL,0x0) = 32752
 (0x7ff0)
 read(13,"\M^?\0'\\\M-B\M-:+\^]D\M-0\M-="...,32752) = 32752 (0x7ff0)
 poll({ 1/POLLOUT },1,0)                          = 1 (0x1)
 msg #21 of size: 32752
 write(1,"msg #21 of size: 32752\n",23)           = 23 (0x17)
 sendto(12,"\M^?\0'\\\M-B\M-:+\^]D\M-0\M-="...,32752,0x0,NULL,0x0) = 19204
 (0x4b04)
 sendto(12,"\M-j$2\M^BH\M-#-\^A\M-E\^O\M^Y\a"...,13548,0x0,NULL,0x0) ERR#35
 'Resource temporarily unavailable'
 SIGNAL 26 (SIGVTALRM)
 sigprocmask(SIG_SETMASK,{ SIGVTALRM },0x0)       = 0 (0x0)
 sigreturn(0x7fffffff9c60)                        ERR#35 'Resource
 temporarily unavailable'
 kevent(3,{ 12,EVFILT_READ,EV_ADD|EV_ONESHOT,0x0,0x0,0x0 },1,0x0,0,{
 0.000000000 }) = 0 (0x0)
 _umtx_op(0x800c71ed0,UMTX_OP_WAIT_UINT_PRIVATE,0x0,0x0,0x0) ERR#4
 'Interrupted system call'
 SIGNAL 26 (SIGVTALRM)
 sigprocmask(SIG_SETMASK,{ SIGVTALRM },0x0)       = 0 (0x0)
 sigreturn(0x7fffffffdc00)                        ERR#4 'Interrupted system
 call'
 _umtx_op(0x800c71ed0,UMTX_OP_WAIT_UINT_PRIVATE,0x0,0x0,0x0) ERR#4
 'Interrupted system call'
 SIGNAL 26 (SIGVTALRM)
 }}}

 Not the `sendto` call on fd 12 resulting in `ERR#35`, soon followed by an
 `kevent` call for that same fd and only `EVFILT_READ` set. This makes
 little sense as it was an attempt to ''write'' that just failed. This is
 caused by `toFilter` giving precedence to `read` events, dropping the
 write event. Not starting the `reader` thread prevents bad things from
 happening as then the `write` events are properly passed thru to kqueue.

 I have an initial version of a patch fixing this.

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