GHC.Conc.prodServiceThread can deadlock

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@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 ())))

Trac metadata

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