Rewrite of signal-handling.

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.

6 files changed, 217 insertions, 97 deletions

diff --git a/System/Posix.hs b/System/Posix.hs
index 40fb85d..f45983b 100644
--- a/System/Posix.hs
+++ b/System/Posix.hs
@@ -12,6 +12,18 @@
 --
 -----------------------------------------------------------------------------
 
+#if MIN_VERSION_base(3,0,0)
+#warning 3
+#endif
+
+#if MIN_VERSION_base(4,0,0)
+#warning 4
+#endif
+
+#if MIN_VERSION_base(4,0,1)
+#warning 401
+#endif
+
 module System.Posix (
   module System.Posix.Types,
   module System.Posix.Signals,
diff --git a/System/Posix/Process.hsc b/System/Posix/Process.hsc
index 71c286e..8e12739 100644
--- a/System/Posix/Process.hsc
+++ b/System/Posix/Process.hsc
@@ -72,12 +72,10 @@ import Foreign.Ptr ( Ptr, nullPtr )
 import Foreign.StablePtr ( StablePtr, newStablePtr, freeStablePtr )
 import Foreign.Storable ( Storable(..) )
 import System.IO
-import System.IO.Error
 import System.Exit
 import System.Posix.Error
-import System.Posix.Process.Internals ( pPrPr_disableITimers, c_execvpe )
+import System.Posix.Process.Internals
 import System.Posix.Types
-import System.Posix.Signals
 import Control.Monad
 
 #ifdef __GLASGOW_HASKELL__
@@ -316,11 +314,6 @@ foreign import ccall unsafe "execve"
 -- -----------------------------------------------------------------------------
 -- Waiting for process termination
 
-data ProcessStatus = Exited ExitCode
-                   | Terminated Signal
-                   | Stopped Signal
-		   deriving (Eq, Ord, Show)
-
 -- | @'getProcessStatus' blk stopped pid@ calls @waitpid@, returning
 --   @'Just' tc@, the 'ProcessStatus' for process @pid@ if it is
 --   available, 'Nothing' otherwise.  If @blk@ is 'False', then
@@ -334,7 +327,7 @@ getProcessStatus block stopped pid =
 		(c_waitpid pid wstatp (waitOptions block stopped))
     case pid' of
       0  -> return Nothing
-      _  -> do ps <- decipherWaitStatus wstatp
+      _  -> do ps <- readWaitStatus wstatp
 	       return (Just ps)
 
 -- safe, because this call might block
@@ -358,7 +351,7 @@ getGroupProcessStatus block stopped pgid =
 		(c_waitpid (-pgid) wstatp (waitOptions block stopped))
     case pid of
       0  -> return Nothing
-      _  -> do ps <- decipherWaitStatus wstatp
+      _  -> do ps <- readWaitStatus wstatp
 	       return (Just (pid, ps))
 -- | @'getAnyProcessStatus' blk stopped@ calls @waitpid@, returning
 --   @'Just' (pid, tc)@, the 'ProcessID' and 'ProcessStatus' for any
@@ -378,46 +371,10 @@ waitOptions True  True  = (#const WUNTRACED)
 
 -- Turn a (ptr to a) wait status into a ProcessStatus
 
-decipherWaitStatus :: Ptr CInt -> IO ProcessStatus
-decipherWaitStatus wstatp = do
+readWaitStatus :: Ptr CInt -> IO ProcessStatus
+readWaitStatus wstatp = do
   wstat <- peek wstatp
-  if c_WIFEXITED wstat /= 0
-      then do
-        let exitstatus = c_WEXITSTATUS wstat
-        if exitstatus == 0
-	   then return (Exited ExitSuccess)
-	   else return (Exited (ExitFailure (fromIntegral exitstatus)))
-      else do
-        if c_WIFSIGNALED wstat /= 0
-	   then do
-		let termsig = c_WTERMSIG wstat
-		return (Terminated (fromIntegral termsig))
-	   else do
-		if c_WIFSTOPPED wstat /= 0
-		   then do
-			let stopsig = c_WSTOPSIG wstat
-			return (Stopped (fromIntegral stopsig))
-		   else do
-			ioError (mkIOError illegalOperationErrorType
-				   "waitStatus" Nothing Nothing)
-
-foreign import ccall unsafe "__hsunix_wifexited"
-  c_WIFEXITED :: CInt -> CInt 
-
-foreign import ccall unsafe "__hsunix_wexitstatus"
-  c_WEXITSTATUS :: CInt -> CInt
-
-foreign import ccall unsafe "__hsunix_wifsignaled"
-  c_WIFSIGNALED :: CInt -> CInt
-
-foreign import ccall unsafe "__hsunix_wtermsig"
-  c_WTERMSIG :: CInt -> CInt 
-
-foreign import ccall unsafe "__hsunix_wifstopped"
-  c_WIFSTOPPED :: CInt -> CInt
-
-foreign import ccall unsafe "__hsunix_wstopsig"
-  c_WSTOPSIG :: CInt -> CInt
+  decipherWaitStatus wstat
 
 -- -----------------------------------------------------------------------------
 -- Exiting
diff --git a/System/Posix/Process/Internals.hs b/System/Posix/Process/Internals.hs
index 8639819..deb1992 100644
--- a/System/Posix/Process/Internals.hs
+++ b/System/Posix/Process/Internals.hs
@@ -1,8 +1,20 @@
 
-module System.Posix.Process.Internals (pPrPr_disableITimers, c_execvpe) where
+module System.Posix.Process.Internals (
+       pPrPr_disableITimers, c_execvpe,
+       decipherWaitStatus, ProcessStatus(..) ) where
 
 import Foreign
 import Foreign.C
+import System.Exit
+import System.IO.Error
+import GHC.Conc (Signal)
+
+-- we had to move this into GHC.Conc in GHC to avoid recursive dependencies.
+-- it can be moved back when the signal handling stuff in base is moved out.
+data ProcessStatus = Exited ExitCode
+                   | Terminated Signal
+                   | Stopped Signal
+		   deriving (Eq, Ord, Show)
 
 -- this function disables the itimer, which would otherwise cause confusing
 -- signals to be sent to the new process.
@@ -11,3 +23,44 @@ foreign import ccall unsafe "pPrPr_disableITimers"
 
 foreign import ccall unsafe "execvpe"
   c_execvpe :: CString -> Ptr CString -> Ptr CString -> IO CInt
+
+decipherWaitStatus :: CInt -> IO ProcessStatus
+decipherWaitStatus wstat =
+  if c_WIFEXITED wstat /= 0
+      then do
+        let exitstatus = c_WEXITSTATUS wstat
+        if exitstatus == 0
+	   then return (Exited ExitSuccess)
+	   else return (Exited (ExitFailure (fromIntegral exitstatus)))
+      else do
+        if c_WIFSIGNALED wstat /= 0
+	   then do
+		let termsig = c_WTERMSIG wstat
+		return (Terminated (fromIntegral termsig))
+	   else do
+		if c_WIFSTOPPED wstat /= 0
+		   then do
+			let stopsig = c_WSTOPSIG wstat
+			return (Stopped (fromIntegral stopsig))
+		   else do
+			ioError (mkIOError illegalOperationErrorType
+				   "waitStatus" Nothing Nothing)
+
+foreign import ccall unsafe "__hsunix_wifexited"
+  c_WIFEXITED :: CInt -> CInt 
+
+foreign import ccall unsafe "__hsunix_wexitstatus"
+  c_WEXITSTATUS :: CInt -> CInt
+
+foreign import ccall unsafe "__hsunix_wifsignaled"
+  c_WIFSIGNALED :: CInt -> CInt
+
+foreign import ccall unsafe "__hsunix_wtermsig"
+  c_WTERMSIG :: CInt -> CInt 
+
+foreign import ccall unsafe "__hsunix_wifstopped"
+  c_WIFSTOPPED :: CInt -> CInt
+
+foreign import ccall unsafe "__hsunix_wstopsig"
+  c_WSTOPSIG :: CInt -> CInt
+
diff --git a/System/Posix/Signals.hs b/System/Posix/Signals.hsc
index 459c042..9045b29 100644
--- a/System/Posix/Signals.hs
+++ b/System/Posix/Signals.hsc
@@ -1,3 +1,5 @@
+{-# LANGUAGE DeriveDataTypeable,PatternGuards #-}
+{-# OPTIONS_GHC -fno-cse #-} -- global variables
 -----------------------------------------------------------------------------
 -- |
 -- Module      :  System.Posix.Signals
@@ -13,6 +15,11 @@
 -----------------------------------------------------------------------------
 
 #include "HsUnixConfig.h"
+##include "HsUnixConfig.h"
+
+#ifdef HAVE_SIGNAL_H
+#include <signal.h>
+#endif
 
 module System.Posix.Signals (
   -- * The Signal type
@@ -58,7 +65,7 @@ module System.Posix.Signals (
 
 #ifdef __GLASGOW_HASKELL__
   -- * Handling signals
-  Handler(..),
+  Handler(Default,Ignore,Catch,CatchOnce),
   installHandler,
 #endif
 
@@ -94,21 +101,22 @@ module System.Posix.Signals (
 
 import Foreign
 import Foreign.C
-import System.IO.Unsafe
 import System.Posix.Types
 import System.Posix.Internals
-import Control.Concurrent (withMVar)
+import System.Posix.Process.Internals
+import System.Posix.Process
+import Control.Monad
+import Data.Dynamic
 
 #ifdef __GLASGOW_HASKELL__
-#include "Signals.h"
-import GHC.Conc	( ensureIOManagerIsRunning, signalHandlerLock )
+##include "Signals.h"
+import GHC.IOBase
+import GHC.Conc hiding (Signal)
 #endif
 
 -- -----------------------------------------------------------------------------
 -- Specific signals
 
-type Signal = CInt
-
 nullSignal :: Signal
 nullSignal = 0
 
@@ -293,11 +301,35 @@ foreign import ccall unsafe "raise"
 #endif
 
 #ifdef __GLASGOW_HASKELL__
+type Signal = CInt
+
+
+-- | The actions to perform when a signal is received.
 data Handler = Default
              | Ignore
 	     -- not yet: | Hold 
              | Catch (IO ())
              | CatchOnce (IO ())
+             | CatchInfo (SignalInfo -> IO ())
+             | CatchInfoOnce (SignalInfo -> IO ())
+  deriving (Typeable)
+
+-- | Information about a received signal (derived from @siginfo_t@).
+data SignalInfo = SignalInfo {
+      siginfoSignal   :: Signal,
+      siginfoError    :: Errno,
+      siginfoSpecific :: SignalSpecificInfo
+  }
+
+-- | Information specific to a particular type of signal
+-- (derived from @siginfo_t@).
+data SignalSpecificInfo
+  = NoSignalSpecificInfo
+  | SigChldInfo {
+      siginfoPid    :: ProcessID,
+      siginfoUid    :: UserID,
+      siginfoStatus :: ProcessStatus
+    }
 
 -- | @installHandler int handler iset@ calls @sigaction@ to install an
 --   interrupt handler for signal @int@.  If @handler@ is @Default@,
@@ -318,52 +350,92 @@ installHandler =
   error "installHandler: not available for Parallel Haskell"
 #else
 
-installHandler int handler maybe_mask = do
-    ensureIOManagerIsRunning  -- for the threaded RTS
-    case maybe_mask of
-	Nothing -> install' nullPtr
-        Just (SignalSet x) -> withForeignPtr x $ install' 
-  where 
-    install' mask = 
-         -- prevent race with the IO manager thread, see #1922
-      withMVar signalHandlerLock $ \_ ->
-      alloca $ \p_sp -> do
-
-      rc <- case handler of
-      	      Default      -> stg_sig_install int STG_SIG_DFL p_sp mask
-      	      Ignore       -> stg_sig_install int STG_SIG_IGN p_sp mask
-      	      Catch m      -> hinstall m p_sp mask STG_SIG_HAN
-      	      CatchOnce m  -> hinstall m p_sp mask STG_SIG_RST
-
-      case rc of
-	STG_SIG_DFL -> return Default
-	STG_SIG_IGN -> return Ignore
-	STG_SIG_ERR -> throwErrno "installHandler"
-	STG_SIG_HAN -> do
-        	m <- peekHandler p_sp
-		return (Catch m)
-	STG_SIG_RST -> do
-        	m <- peekHandler p_sp
-		return (CatchOnce m)
-	_other ->
-	   error "internal error: System.Posix.Signals.installHandler"
-
-    hinstall m p_sp mask reset = do
-      sptr <- newStablePtr m
-      poke p_sp sptr
-      stg_sig_install int reset p_sp mask
-
-    peekHandler p_sp = do
-      osptr <- peek p_sp
-      deRefStablePtr osptr
+installHandler sig handler _maybe_mask = do
+  ensureIOManagerIsRunning  -- for the threaded RTS
+
+  -- if we're setting the action to DFL or IGN, we should do that *first*
+  -- if we're setting a handler,
+  --   if the previous action was handle, then setHandler is ok
+  --   if the previous action was IGN/DFL, then setHandler followed by sig_install
+  (old_action, old_handler) <-
+    case handler of
+      Ignore  -> do
+        old_action  <- stg_sig_install sig STG_SIG_IGN nullPtr
+        old_handler <- setHandler sig Nothing
+        return (old_action, old_handler)
+
+      Default -> do
+        old_action  <- stg_sig_install sig STG_SIG_DFL nullPtr
+        old_handler <- setHandler sig Nothing
+        return (old_action, old_handler)
+
+      _some_kind_of_catch -> do
+        -- I don't think it's possible to get CatchOnce right.  If
+        -- there's a signal in flight, then we might run the handler
+        -- more than once.
+        let dyn = toDyn handler
+        old_handler <- case handler of
+            Catch         action -> setHandler sig (Just (const action,dyn))
+            CatchOnce     action -> setHandler sig (Just (const action,dyn))
+            CatchInfo     action -> setHandler sig (Just (getinfo action,dyn))
+            CatchInfoOnce action -> setHandler sig (Just (getinfo action,dyn))
+            _                    -> error "installHandler"
+            
+        let action = case handler of
+                Catch _         -> STG_SIG_HAN
+                CatchOnce _     -> STG_SIG_RST
+                CatchInfo _     -> STG_SIG_HAN
+                CatchInfoOnce _ -> STG_SIG_RST
+                _               -> error "installHandler"
+
+        old_action <- stg_sig_install sig action nullPtr
+                   -- mask is pointless, so leave it NULL
+
+        return (old_action, old_handler)
+
+  case (old_handler,old_action) of
+    (_,       STG_SIG_DFL) -> return $ Default
+    (_,       STG_SIG_IGN) -> return $ Ignore
+    (Nothing, _)           -> return $ Ignore
+    (Just (_,dyn),  _)
+        | Just h <- fromDynamic dyn  -> return h
+        | Just io <- fromDynamic dyn -> return (Catch io)
+        -- handlers put there by the base package have type IO ()
+        | otherwise                  -> return Default
 
 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 CSigset			-- (in, out) blocked
-	-> IO CInt			-- (ret) action code
+	-> IO CInt			-- (ret) old action code
+
+getinfo :: (SignalInfo -> IO ()) -> ForeignPtr Word8 -> IO ()
+getinfo handler fp_info = do
+  si <- unmarshalSigInfo fp_info
+  handler si
+
+unmarshalSigInfo :: ForeignPtr Word8 -> IO SignalInfo
+unmarshalSigInfo fp = do
+  withForeignPtr fp $ \p -> do
+    sig   <- (#peek siginfo_t, si_signo) p
+    errno <- (#peek siginfo_t, si_errno) p
+    extra <- case sig of
+                _ | sig == sigCHLD -> do
+                    pid <- (#peek siginfo_t, si_pid) p
+                    uid <- (#peek siginfo_t, si_uid) p
+                    wstat <- (#peek siginfo_t, si_status) p
+                    pstat <- decipherWaitStatus wstat
+                    return SigChldInfo { siginfoPid = pid,
+                                         siginfoUid = uid,
+                                         siginfoStatus = pstat }
+                _ | otherwise ->
+                    return NoSignalSpecificInfo
+    return
+      SignalInfo {
+        siginfoSignal = sig,
+        siginfoError  = Errno errno,
+        siginfoSpecific = extra }
 
 #endif /* !__PARALLEL_HASKELL__ */
 #endif /* __GLASGOW_HASKELL__ */
diff --git a/tests/all.T b/tests/all.T
index 8647812..6746643 100644
--- a/tests/all.T
+++ b/tests/all.T
@@ -24,3 +24,5 @@ test('getGroupEntryForName', compose(conf, expect_fail), compile_and_run,
 test('getUserEntryForName', compose(conf, expect_fail), compile_and_run,
      ['-package unix'])
 
+
+test('signals004', normal, compile_and_run, ['-package unix'])
diff --git a/tests/signals004.hs b/tests/signals004.hs
new file mode 100644
index 0000000..711a6eb
--- /dev/null
+++ b/tests/signals004.hs
@@ -0,0 +1,24 @@
+import Control.Concurrent
+import System.Posix
+import Control.Monad
+
+-- signal stress test: threads installing signal handlers while
+-- signals are being constantly thrown and caught.
+
+installers = 50
+sigs = 10000
+
+main = do
+  c <- newChan
+  m <- newEmptyMVar
+  installHandler sigUSR1 (handler c) Nothing
+  replicateM_ installers (forkIO $ do replicateM_ 1000 (install c); putMVar m ())
+  replicateM_ sigs (forkIO $ raiseSignal sigUSR1)
+  replicateM_ installers (takeMVar m)
+  replicateM_ sigs (readChan c)
+
+handler c = Catch (writeChan c ())
+
+install c = do
+  old <- installHandler sigUSR1 (handler c) Nothing
+  installHandler sigUSR1 old Nothing