Rewrite of signal-handling (base patch; see also ghc and unix patches)

The API is the same (for now).  The new implementation has the
capability to define signal handlers that have access to the siginfo
of the signal (#592), but this functionality is not exposed in this
patch.

#2451 is the ticket for the new API.

The main purpose of bringing this in now is to fix race conditions in
the old signal handling code (#2858).  Later we can enable the new
API in the HEAD.

Implementation differences:

 - More of the signal-handling is moved into Haskell.  We store the
   table of signal handlers in an MVar, rather than having a table of
   StablePtrs in the RTS.

 - In the threaded RTS, the siginfo of the signal is passed down the
   pipe to the IO manager thread, which manages the business of
   starting up new signal handler threads.  In the non-threaded RTS,
   the siginfo of caught signals is stored in the RTS, and the
   scheduler starts new signal handler threads.

diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs
index 1d5cc9c..796e4c7 100644 (file)
--- a/GHC/Conc.lhs
+++ b/GHC/Conc.lhs
@@ -88,10 +88,11 @@ module GHC.Conc
 #endif
 
 #ifndef mingw32_HOST_OS
-        , signalHandlerLock
+        , Signal, HandlerFun, setHandler, runHandlers
 #endif
 
         , ensureIOManagerIsRunning
+        , syncIOManager
 
 #ifdef mingw32_HOST_OS
         , ConsoleEvent(..)
@@ -111,13 +112,16 @@ import System.Posix.Internals
 import Foreign
 import Foreign.C
 
+import Data.Dynamic
 import Data.Maybe
+import Control.Monad
 
 import GHC.Base
 import {-# SOURCE #-} GHC.Handle
 import GHC.IOBase
 import GHC.Num          ( Num(..) )
 import GHC.Real         ( fromIntegral )
+import GHC.Arr          ( inRange )
 #ifdef mingw32_HOST_OS
 import GHC.Real         ( div )
 import GHC.Ptr          ( plusPtr, FunPtr(..) )
@@ -691,15 +695,6 @@ isEmptyMVar (MVar mv#) = IO $ \ s# ->
 addMVarFinalizer :: MVar a -> IO () -> IO ()
 addMVarFinalizer (MVar m) finalizer = 
   IO $ \s -> case mkWeak# m () finalizer s of { (# s1, _ #) -> (# s1, () #) }
-
-withMVar :: MVar a -> (a -> IO b) -> IO b
-withMVar m io = 
-  block $ do
-    a <- takeMVar m
-    b <- catchAny (unblock (io a))
-            (\e -> do putMVar m a; throw e)
-    putMVar m a
-    return b
 \end{code}
 
 
@@ -1055,6 +1050,8 @@ startIOManagerThread = do
         throwErrnoIfMinus1 "startIOManagerThread" (c_pipe fds)
         rd_end <- peekElemOff fds 0
         wr_end <- peekElemOff fds 1
+        setNonBlockingFD wr_end -- writes happen in a signal handler, we
+                                -- don't want them to block.
         writeIORef stick (fromIntegral wr_end)
         c_setIOManagerPipe wr_end
         forkIO $ do
@@ -1122,17 +1119,24 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
         if b == 0 
           then return False
           else alloca $ \p -> do 
-                 c_read (fromIntegral wakeup) p 1; return ()
+                 c_read (fromIntegral wakeup) p 1
                  s <- peek p            
                  case s of
                   _ | s == io_MANAGER_WAKEUP -> return False
                   _ | s == io_MANAGER_DIE    -> return True
-                  _ -> withMVar signalHandlerLock $ \_ -> do
-                          handler_tbl <- peek handlers
-                          sp <- peekElemOff handler_tbl (fromIntegral s)
-                          io <- deRefStablePtr sp
-                          forkIO io
-                          return False
+                  _ | s == io_MANAGER_SYNC   -> do
+                       mvars <- readIORef sync
+                       mapM_ (flip putMVar ()) mvars
+                       return False
+                  _ -> do
+                       fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
+                       withForeignPtr fp $ \p_siginfo -> do
+                         r <- c_read (fromIntegral wakeup) (castPtr p_siginfo)
+                                 sizeof_siginfo_t
+                         when (r /= fromIntegral sizeof_siginfo_t) $
+                            error "failed to read siginfo_t"
+                       runHandlers' fp (fromIntegral s)
+                       return False
 
   if exit then return () else do
 
@@ -1143,31 +1147,87 @@ service_loop wakeup readfds writefds ptimeval old_reqs old_delays = do
 
   service_loop wakeup readfds writefds ptimeval reqs' delays'
 
-io_MANAGER_WAKEUP, io_MANAGER_DIE :: CChar
+io_MANAGER_WAKEUP, io_MANAGER_DIE, io_MANAGER_SYNC :: CChar
 io_MANAGER_WAKEUP = 0xff
 io_MANAGER_DIE    = 0xfe
+io_MANAGER_SYNC   = 0xfd
 
+-- | the stick is for poking the IO manager with
 stick :: IORef Fd
 {-# NOINLINE stick #-}
 stick = unsafePerformIO (newIORef 0)
 
+{-# NOINLINE sync #-}
+sync :: IORef [MVar ()]
+sync = unsafePerformIO (newIORef [])
+
+-- waits for the IO manager to drain the pipe
+syncIOManager :: IO ()
+syncIOManager = do
+  m <- newEmptyMVar
+  atomicModifyIORef sync (\old -> (m:old,()))
+  fd <- readIORef stick
+  with io_MANAGER_SYNC $ \pbuf -> do 
+    c_write (fromIntegral fd) pbuf 1; return ()
+  takeMVar m
+
 wakeupIOManager :: IO ()
 wakeupIOManager = do
   fd <- readIORef stick
   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 ())))
+-- For the non-threaded RTS
+runHandlers :: Ptr Word8 -> Int -> IO ()
+runHandlers p_info sig = do
+  fp <- mallocForeignPtrBytes (fromIntegral sizeof_siginfo_t)
+  withForeignPtr fp $ \p -> do
+    copyBytes p p_info (fromIntegral sizeof_siginfo_t)
+    free p_info
+  runHandlers' fp (fromIntegral sig)
+
+runHandlers' :: ForeignPtr Word8 -> Signal -> IO ()
+runHandlers' p_info sig = do
+  let int = fromIntegral sig
+  withMVar signal_handlers $ \arr ->
+      if not (inRange (boundsIOArray arr) int)
+         then return ()
+         else do handler <- unsafeReadIOArray arr int
+                 case handler of
+                    Nothing -> return ()
+                    Just (f,_)  -> do forkIO (f p_info); return ()
 
 foreign import ccall "setIOManagerPipe"
   c_setIOManagerPipe :: CInt -> IO ()
 
+foreign import ccall "__hscore_sizeof_siginfo_t"
+  sizeof_siginfo_t :: CSize
+
+type Signal = CInt
+
+maxSig = 64 :: Int
+
+type HandlerFun = ForeignPtr Word8 -> IO ()
+
+-- 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.
+{-# NOINLINE signal_handlers #-}
+signal_handlers :: MVar (IOArray Int (Maybe (HandlerFun,Dynamic)))
+signal_handlers = unsafePerformIO $ do
+   arr <- newIOArray (0,maxSig) Nothing
+   newMVar arr
+
+setHandler :: Signal -> Maybe (HandlerFun,Dynamic) -> IO (Maybe (HandlerFun,Dynamic))
+setHandler sig handler = do
+  let int = fromIntegral sig
+  withMVar signal_handlers $ \arr -> 
+     if not (inRange (boundsIOArray arr) int)
+        then error "GHC.Conc.setHandler: signal out of range"
+        else do old <- unsafeReadIOArray arr int
+                unsafeWriteIOArray arr int handler
+                return old
+
 -- -----------------------------------------------------------------------------
 -- IO requests
 
@@ -1328,4 +1388,14 @@ setUncaughtExceptionHandler = writeIORef uncaughtExceptionHandler
 
 getUncaughtExceptionHandler :: IO (SomeException -> IO ())
 getUncaughtExceptionHandler = readIORef uncaughtExceptionHandler
+
+
+withMVar :: MVar a -> (a -> IO b) -> IO b
+withMVar m io = 
+  block $ do
+    a <- takeMVar m
+    b <- catchAny (unblock (io a))
+            (\e -> do putMVar m a; throw e)
+    putMVar m a
+    return b
 \end{code}

diff --git a/GHC/IOBase.lhs b/GHC/IOBase.lhs
index a952bd5..0a19d80 100644 (file)
--- a/GHC/IOBase.lhs
+++ b/GHC/IOBase.lhs
@@ -27,7 +27,8 @@ module GHC.IOBase(
 
         -- References
     IORef(..), newIORef, readIORef, writeIORef, 
-    IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, unsafeWriteIOArray,
+    IOArray(..), newIOArray, readIOArray, writeIOArray, unsafeReadIOArray, 
+    unsafeWriteIOArray, boundsIOArray,
     MVar(..),
 
         -- Handles, file descriptors,
@@ -606,6 +607,9 @@ readIOArray (IOArray marr) i = stToIO (readSTArray marr i)
 writeIOArray :: Ix i => IOArray i e -> i -> e -> IO ()
 writeIOArray (IOArray marr) i e = stToIO (writeSTArray marr i e)
 
+{-# INLINE boundsIOArray #-}
+boundsIOArray :: IOArray i e -> (i,i)  
+boundsIOArray (IOArray marr) = boundsSTArray marr
 
 -- ---------------------------------------------------------------------------
 -- Show instance for Handles

diff --git a/GHC/TopHandler.lhs b/GHC/TopHandler.lhs
index 6a2520a..c61de0d 100644 (file)
--- a/GHC/TopHandler.lhs
+++ b/GHC/TopHandler.lhs
@@ -28,6 +28,7 @@ module GHC.TopHandler (
 
 import Control.Exception
 import Data.Maybe
+import Data.Dynamic (toDyn)
 
 import Foreign
 import Foreign.C
@@ -79,27 +80,18 @@ install_interrupt_handler handler = do
 -- isn't available here.
 install_interrupt_handler handler = do
    let sig = CONST_SIGINT :: CInt
-   withSignalHandlerLock $
-     alloca $ \p_sp -> do
-       sptr <- newStablePtr handler
-       poke p_sp sptr
-       stg_sig_install sig STG_SIG_RST p_sp nullPtr
-       return ()
-
-withSignalHandlerLock :: IO () -> IO ()
-withSignalHandlerLock io
- = block $ do
-       takeMVar signalHandlerLock
-       catchAny (unblock io) (\e -> do putMVar signalHandlerLock (); throw e)
-       putMVar signalHandlerLock ()
+   setHandler sig (Just (const handler, toDyn handler))
+   stg_sig_install sig STG_SIG_RST nullPtr
+     -- STG_SIG_RST: the second ^C kills us for real, just in case the
+     -- RTS or program is unresponsive.
+   return ()
 
 foreign import ccall unsafe
   stg_sig_install
        :: CInt                         -- sig no.
        -> CInt                         -- action code (STG_SIG_HAN etc.)
-       -> Ptr (StablePtr (IO ()))      -- (in, out) Haskell handler
        -> Ptr ()                       -- (in, out) blocked
-       -> IO CInt                      -- (ret) action code
+       -> IO CInt                      -- (ret) old action code
 #endif
 
 -- make a weak pointer to a ThreadId: holding the weak pointer doesn't

diff --git a/include/HsBase.h b/include/HsBase.h
index dfc545f..862cf44 100644 (file)
--- a/include/HsBase.h
+++ b/include/HsBase.h
@@ -632,6 +632,13 @@ INLINE int __hscore_sig_setmask( void )
 #endif
 }
 
+#ifndef __MINGW32__
+INLINE size_t __hscore_sizeof_siginfo_t (void)
+{
+    return sizeof(siginfo_t);
+}
+#endif
+
 INLINE int
 __hscore_f_getfl( void )
 {