[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:  libraries/base    |                 Version:  7.10.1
      Resolution:                    |                Keywords:
Operating System:  Linux             |            Architecture:
 Type of failure:  Incorrect result  |  Unknown/Multiple
  at runtime                         |               Test Case:
      Blocked By:                    |                Blocking:
 Related Tickets:                    |  Differential Revisions:
-------------------------------------+-------------------------------------

Comment (by akio):

 Bryan Buecking has confirmed that the following patch fixes the issue. The
 patch was taken from the base commit of D849. Strangely I can't find the
 commit (635619c) in the repository.

 {{{
 diff --git a/libraries/base/GHC/Event/Manager.hs
 b/libraries/base/GHC/Event/Manager.hs
 index 11b01ad..cd039b1 100644
 --- a/libraries/base/GHC/Event/Manager.hs
 +++ b/libraries/base/GHC/Event/Manager.hs
 @@ -456,20 +456,26 @@ onFdEvent mgr fd evs

    | otherwise = do
      fdds <- withMVar (callbackTableVar mgr fd) $ \tbl ->
 -        IT.delete (fromIntegral fd) tbl >>= maybe (return [])
 selectCallbacks
 +        IT.delete (fromIntegral fd) tbl >>= maybe (return [])
 (selectCallbacks tbl)
      forM_ fdds $ \(FdData reg _ cb) -> cb reg evs
    where
      -- | Here we look through the list of registrations for the fd of
 interest
      -- and sort out which match the events that were triggered. We re-arm
 -    -- the fd as appropriate and return this subset.
 -    selectCallbacks :: [FdData] -> IO [FdData]
 -    selectCallbacks fdds = do
 +    -- the fd as appropriate and return a list containing the callbacks
 +    -- that should be invoked.
 +    selectCallbacks :: IntTable [FdData] -> [FdData] -> IO [FdData]
 +    selectCallbacks tbl fdds = do
          let matches :: FdData -> Bool
              matches fd' = evs `I.eventIs` I.elEvent (fdEvents fd')
 -            (triggered, saved) = partition matches fdds
 +            (triggered, notTriggered) = partition matches fdds
 +            saved = notTriggered ++ filter (\fd' -> I.elLifetime
 (fdEvents fd') == MultiShot) triggered
              savedEls = eventsOf saved
              allEls = eventsOf fdds

 +        -- Reinsert multishot registrations.
 +        -- We deleted the table entry for this fd above so we there isn't
 a preexisting entry
 +        IT.insertWith (\_ _-> saved) (fromIntegral fd) saved tbl
 +
          case I.elLifetime allEls of
            -- we previously armed the fd for multiple shots, no need to
 rearm
            MultiShot | allEls == savedEls ->
 }}}

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