"thread blocked indefinitely" exception while blocking on a socket

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

{-# 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 sending, causing the "receiver" thread to deadlock.

Trac metadata

Trac field	Value
Version	7.10.1
Type	Bug
TypeOfFailure	OtherFailure
Priority	normal
Resolution	Unresolved
Component	libraries/base
Test case
Differential revisions
BlockedBy
Related
Blocking
CC	ekmett, hvr
Operating system
Architecture