protect against concurrent access to the signal handlers (#1922)

[ghc-base.git] / GHC / Conc.lhs

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 094ff05..142115c 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -80,6 +80,10 @@ module GHC.Conc
        , asyncWriteBA  -- :: Int -> Int -> Int -> Int -> MutableByteArray# RealWorld -> IO (Int, Int)
 #endif
 
+#ifndef mingw32_HOST_OS
+        , signalHandlerLock
+#endif
+
        , ensureIOManagerIsRunning
         ) where
 
@@ -103,7 +107,7 @@ import GHC.Real             ( fromIntegral, div )
 #ifndef mingw32_HOST_OS
 import GHC.Base                ( Int(..) )
 #endif
-import GHC.Exception    ( catchException, Exception(..), AsyncException(..) )
+import GHC.Exception
 import GHC.Pack                ( packCString# )
 import GHC.Ptr          ( Ptr(..), plusPtr, FunPtr(..) )
 import GHC.STRef
@@ -246,7 +250,7 @@ until the call has completed.  This is the case regardless of whether
 the call is inside a 'block' or not.
 
 Important note: the behaviour of 'throwTo' differs from that described in
-the paper "Asynchronous exceptions in Haskell" 
+the paper \"Asynchronous exceptions in Haskell\"
 (<http://research.microsoft.com/~simonpj/Papers/asynch-exns.htm>).
 In the paper, 'throwTo' is non-blocking; but the library implementation adopts
 a more synchronous design in which 'throwTo' does not return until the exception
@@ -569,7 +573,7 @@ addMVarFinalizer (MVar m) finalizer =
 \begin{code}
 #ifdef mingw32_HOST_OS
 
--- Note: threadDelay, threadWaitRead and threadWaitWrite aren't really functional
+-- Note: threadWaitRead and threadWaitWrite aren't really functional
 -- on Win32, but left in there because lib code (still) uses them (the manner
 -- in which they're used doesn't cause problems on a Win32 platform though.)
 
@@ -958,9 +962,11 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
                 case s of
                  _ | s == io_MANAGER_WAKEUP -> return False
                  _ | s == io_MANAGER_DIE    -> return True
-                 _ -> do handler_tbl <- peek handlers
+                 _ -> withMVar signalHandlerLock $ \_ -> do
+                          handler_tbl <- peek handlers
                          sp <- peekElemOff handler_tbl (fromIntegral s)
-                         forkIO (do io <- deRefStablePtr sp; io)
+                          io <- deRefStablePtr sp
+                         forkIO io
                          return False
 
   if exit then return () else do
@@ -972,6 +978,15 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
 
   service_loop wakeup readfds writefds ptimeval reqs' delays'
 
+withMVar :: MVar a -> (a -> IO b) -> IO b
+withMVar m io = 
+  block $ do
+    a <- takeMVar m
+    b <- catchException (unblock (io a))
+           (\e -> do putMVar m a; throw e)
+    putMVar m a
+    return b
+
 io_MANAGER_WAKEUP = 0xff :: CChar
 io_MANAGER_DIE    = 0xfe :: CChar
 
@@ -985,6 +1000,12 @@ wakeupIOManager = do
   with io_MANAGER_WAKEUP $ \pbuf -> do 
     c_write (fromIntegral fd) pbuf 1; return ()
 
+-- Lock used to protect concurrent access to signal_handlers.  Symptom of
+-- this race condition is #1922, although that bug was on Windows a similar
+-- bug also exists on Unix.
+signalHandlerLock :: MVar ()
+signalHandlerLock = unsafePerformIO (newMVar ())
+
 foreign import ccall "&signal_handlers" handlers :: Ptr (Ptr (StablePtr (IO ())))
 
 foreign import ccall "setIOManagerPipe"