From 29d970ffba3201eaafed574e6f67e2786a80021f Mon Sep 17 00:00:00 2001 From: Simon Marlow Date: Thu, 19 Feb 2009 10:22:03 +0000 Subject: [PATCH] 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. --- GHC/Conc.lhs | 120 +++++++++++++++++++++++++++++++++++++++++----------- GHC/IOBase.lhs | 6 ++- GHC/TopHandler.lhs | 22 +++------- include/HsBase.h | 7 +++ 4 files changed, 114 insertions(+), 41 deletions(-) diff --git a/GHC/Conc.lhs b/GHC/Conc.lhs index 1d5cc9c..796e4c7 100644 --- 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 --- 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 --- 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 --- 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 ) { -- 1.7.10.4