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 |