[GHC] #1187: GHC.Conc.prodServiceThread can deadlock

[GHC]

#1187: GHC.Conc.prodServiceThread can deadlock
-------------------------------+--------------------------------------------
    Reporter:  ms43            |       Owner:          
        Type:  bug             |      Status:  new     
    Priority:  normal          |   Milestone:          
   Component:  libraries/base  |     Version:  6.6     
    Severity:  normal          |    Keywords:          
  Difficulty:  Easy (1 hr)     |    Testcase:          
Architecture:  Multiple        |          Os:  Multiple
-------------------------------+--------------------------------------------
i am using GHC 6.6 from darcs (checked out on 2007-02-18).
 there is a race condition in GHC.Conc.prodServiceThread:
 if an async exception arrives between taking the MVar prodding
 and putting the value back, the MVar will be left empty.
 in this case, any further calls to e.g. threadDelay will try
 to take the empty MVar and deadlock.
 this can only happen on -threaded with at least -N2.
 this results in stack traces like this (all threads look like
 this up to frame 4):

 {{{
 Thread 3 (Thread 16386 (LWP 6185)):
 #0  0x400a7604 in __pthread_sigsuspend () from /lib/libpthread.so.0
 #1  0x400a73c8 in __pthread_wait_for_restart_signal ()
    from /lib/libpthread.so.0
 #2  0x400a3f2b in pthread_cond_wait at GLIBC_2.0 () from /lib/libpthread.so.0
 #3  0x080da958 in waitCondition (pCond=0xfffffffc, pMut=0xfffffffc)
     at posix/OSThreads.c:65
 #4  0x080e3fe4 in yieldCapability (pCap=0xbf7ffa9c, task=0x811ee80)
     at Capability.c:498
 #5  0x080d5615 in schedule (initialCapability=0x8116d2c, task=0x811ee80)
     at Schedule.c:365
 #6  0x080d6646 in workerStart (task=0x811ee80) at Schedule.c:2660
 }}}

 here is a patch which should fix the race condition.
 well, at least i could no longer reproduce it,
 so it might actually be correct :)
 (note that i have not tested on win32)

 {{{
 --- ghc/libraries/base/GHC/Conc.lhs     2007-02-18 22:45:27.000000000
 +0100
 +++ /home/ms/stuff/ghc/libraries/base/GHC/Conc.lhs      2007-02-28
 00:55:11.000000000 +0100
 @@ -100,7 +101,8 @@
  #ifndef mingw32_HOST_OS
  import GHC.Base                ( Int(..) )
  #endif
 -import GHC.Exception    ( catchException, Exception(..),
 AsyncException(..) )
 +import GHC.Exception    ( catchException, Exception(..),
 AsyncException(..),
 +                          block )
  import GHC.Pack                ( packCString# )
  import GHC.Ptr          ( Ptr(..), plusPtr, FunPtr(..) )
  import GHC.STRef
 @@ -773,13 +788,16 @@
  prodding = unsafePerformIO (newMVar False)

  prodServiceThread :: IO ()
 -prodServiceThread = do
 +prodServiceThread = block $ do
    b <- takeMVar prodding
 -  if (not b)
 -    then do hdl <- readIORef stick
 -            c_sendIOManagerEvent io_MANAGER_WAKEUP
 -    else return ()
 -  putMVar prodding True
 +  catchException (do
 +      if (not b)
 +        then do hdl <- readIORef stick
 +                c_sendIOManagerEvent io_MANAGER_WAKEUP
 +        else return ()
 +      putMVar prodding True)
 +    (\e -> do putMVar prodding True
 +              throw e)

  -- Walk the queue of pending delays, waking up any that have passed
  -- and return the smallest delay to wait for.  The queue of pending
 @@ -932,14 +950,17 @@
  prodding = unsafePerformIO (newMVar False)

  prodServiceThread :: IO ()
 -prodServiceThread = do
 +prodServiceThread = block $ do
    b <- takeMVar prodding
 -  if (not b)
 -    then do fd <- readIORef stick
 -           with io_MANAGER_WAKEUP $ \pbuf -> do
 -               c_write (fromIntegral fd) pbuf 1; return ()
 -    else return ()
 -  putMVar prodding True
 +  catchException (do
 +      if (not b)
 +        then do fd <- readIORef stick
 +               with io_MANAGER_WAKEUP $ \pbuf -> do
 +                       c_write (fromIntegral fd) pbuf 1; return ()
 +        else return ()
 +      putMVar prodding True)
 +    (\e -> do putMVar prodding True
 +              throw e)

  foreign import ccall "&signal_handlers" handlers :: Ptr (Ptr (StablePtr
 (IO ())))
 }}}

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