aboutsummaryrefslogtreecommitdiffhomepage
diff options
context:
space:
mode:
Diffstat
-rw-r--r--System/Posix.hs12
-rw-r--r--System/Posix/Process.hsc55
-rw-r--r--System/Posix/Process/Internals.hs55
-rw-r--r--System/Posix/Signals.hsc (renamed from System/Posix/Signals.hs)166
-rw-r--r--tests/all.T2
-rw-r--r--tests/signals004.hs24
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
generated by cgit v1.2.3 (git 2.39.1) at 2024-05-18 06:15:13 +0000