[GHC] #10380: "thread blocked indefinitely" exception while blocking on a socket

[GHC]

#10380: "thread blocked indefinitely" exception while blocking on a socket
-------------------------------------+-------------------------------------
              Reporter:  akio        |             Owner:
                  Type:  bug         |            Status:  new
              Priority:  normal      |         Milestone:
             Component:              |           Version:  7.10.1
  libraries/base                     |  Operating System:  Linux
              Keywords:              |   Type of failure:  Incorrect result
          Architecture:              |  at runtime
  Unknown/Multiple                   |        Blocked By:
             Test Case:              |   Related Tickets:
              Blocking:              |
Differential Revisions:              |
-------------------------------------+-------------------------------------
 First start a TCP server, e.g. nc.

 {{{
 % nc localhost -l 1234 > /dev/null
 }}}

 On another shell, compile the following program and run it:

 {{{
 % ghc -threaded sock.hs
 % ./sock localhost 1234
 receiver: thread blocked indefinitely in an MVar operation
 }}}

 {{{#!hs
 {-# LANGUAGE ViewPatterns #-}

 import Control.Applicative -- GHC 7.8 compatibility
 import Control.Concurrent
 import qualified Control.Exception as Ex
 import Control.Monad
 import qualified Data.ByteString.Char8 as S
 import Network.Socket
 import qualified Network.Socket.ByteString as Sock
 import Network.BSD (getHostByName, hostAddresses)
 import System.Environment
 import System.Mem

 main :: IO ()
 main = do
   [host, read -> fromInteger -> port] <- getArgs
   sock <- connectTo host port
   forkVerbose "sender" $ forever $ do
     _ <- Sock.send sock $ S.replicate 40000 '0'
     return ()
   forkVerbose "receiver" $ forever $ do
     dat <- Sock.recv sock 2048
     putStrLn $ "received: " ++ show dat
   forever $ do
     threadDelay 1000000
     performGC

 forkVerbose :: String -> IO () -> IO ()
 forkVerbose name act = void $ forkIO $ do act; msg "exiting normally"
   `Ex.catch` \e -> msg $ show (e :: Ex.SomeException)
   where
     msg s = putStrLn $ name ++ ": " ++ s

 connectTo :: HostName -> PortNumber -> IO Socket
 connectTo hostName port = do
   addr <- SockAddrInet port <$> lookupHost hostName
   sock <- socket AF_INET Stream 0
   connect sock addr
   return sock

 lookupHost :: String -> IO HostAddress
 lookupHost name = do
   hostInfo <- getHostByName name
   case hostAddresses hostInfo of
     []    -> error ("Invalid host name: " ++ name)
     (a:_) -> return a
 }}}

 GHC 7.8.3 doesn't have this problem.

 I suspect that this is a regression in the event manager. When there is an
 event, `GHC.Event.Manager.onFdEvent` seems to remove all callbacks
 associated to the `fd`, whether or not they match the current event. In
 the program above, the callback for `recv` may be removed permanently when
 the socket becomes ready for `send`ing, causing the "receiver" thread to
 deadlock.

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