diff options
Diffstat (limited to 'System/Posix/Signals.hs')
| -rw-r--r-- | System/Posix/Signals.hs | 528 |
1 files changed, 528 insertions, 0 deletions
diff --git a/System/Posix/Signals.hs b/System/Posix/Signals.hs new file mode 100644 index 0000000..1aa9dca --- /dev/null +++ b/System/Posix/Signals.hs @@ -0,0 +1,528 @@ +----------------------------------------------------------------------------- +-- | +-- Module : System.Posix.Signals +-- Copyright : (c) The University of Glasgow 2002 +-- License : BSD-style (see the file libraries/base/LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : provisional +-- Portability : non-portable (requires POSIX) +-- +-- POSIX signal support +-- +----------------------------------------------------------------------------- + +#include "HsBaseConfig.h" + +module System.Posix.Signals ( + -- * The Signal type + Signal, + + -- * Specific signals + nullSignal, + internalAbort, sigABRT, + realTimeAlarm, sigALRM, + busError, sigBUS, + processStatusChanged, sigCHLD, + continueProcess, sigCONT, + floatingPointException, sigFPE, + lostConnection, sigHUP, + illegalInstruction, sigILL, + keyboardSignal, sigINT, + killProcess, sigKILL, + openEndedPipe, sigPIPE, + keyboardTermination, sigQUIT, + segmentationViolation, sigSEGV, + softwareStop, sigSTOP, + softwareTermination, sigTERM, + keyboardStop, sigTSTP, + backgroundRead, sigTTIN, + backgroundWrite, sigTTOU, + userDefinedSignal1, sigUSR1, + userDefinedSignal2, sigUSR2, +#if CONST_SIGPOLL != -1 + pollableEvent, sigPOLL, +#endif + profilingTimerExpired, sigPROF, + badSystemCall, sigSYS, + breakpointTrap, sigTRAP, + urgentDataAvailable, sigURG, + virtualTimerExpired, sigVTALRM, + cpuTimeLimitExceeded, sigXCPU, + fileSizeLimitExceeded, sigXFSZ, + + -- * Sending signals + raiseSignal, + signalProcess, + signalProcessGroup, + +#ifdef __GLASGOW_HASKELL__ + -- * Handling signals + Handler(..), + installHandler, +#endif + + -- * Signal sets + SignalSet, + emptySignalSet, fullSignalSet, + addSignal, deleteSignal, inSignalSet, + + -- * The process signal mask + getSignalMask, setSignalMask, blockSignals, unblockSignals, + + -- * The alarm timer + scheduleAlarm, + + -- * Waiting for signals + getPendingSignals, +#ifndef cygwin32_HOST_OS + awaitSignal, +#endif + +#ifdef __GLASGOW_HASKELL__ + -- * The @NOCLDSTOP@ flag + setStoppedChildFlag, queryStoppedChildFlag, +#endif + + -- MISSING FUNCTIONALITY: + -- sigaction(), (inc. the sigaction structure + flags etc.) + -- the siginfo structure + -- sigaltstack() + -- sighold, sigignore, sigpause, sigrelse, sigset + -- siginterrupt + ) where + +import Foreign +import Foreign.C +import System.IO.Unsafe +import System.Posix.Types +import System.Posix.Internals + +#ifdef __GLASGOW_HASKELL__ +#include "Signals.h" +import GHC.Conc ( ensureIOManagerIsRunning ) +#endif + +-- ----------------------------------------------------------------------------- +-- Specific signals + +type Signal = CInt + +nullSignal :: Signal +nullSignal = 0 + +sigABRT :: CInt +sigABRT = CONST_SIGABRT +sigALRM :: CInt +sigALRM = CONST_SIGALRM +sigBUS :: CInt +sigBUS = CONST_SIGBUS +sigCHLD :: CInt +sigCHLD = CONST_SIGCHLD +sigCONT :: CInt +sigCONT = CONST_SIGCONT +sigFPE :: CInt +sigFPE = CONST_SIGFPE +sigHUP :: CInt +sigHUP = CONST_SIGHUP +sigILL :: CInt +sigILL = CONST_SIGILL +sigINT :: CInt +sigINT = CONST_SIGINT +sigKILL :: CInt +sigKILL = CONST_SIGKILL +sigPIPE :: CInt +sigPIPE = CONST_SIGPIPE +sigQUIT :: CInt +sigQUIT = CONST_SIGQUIT +sigSEGV :: CInt +sigSEGV = CONST_SIGSEGV +sigSTOP :: CInt +sigSTOP = CONST_SIGSTOP +sigTERM :: CInt +sigTERM = CONST_SIGTERM +sigTSTP :: CInt +sigTSTP = CONST_SIGTSTP +sigTTIN :: CInt +sigTTIN = CONST_SIGTTIN +sigTTOU :: CInt +sigTTOU = CONST_SIGTTOU +sigUSR1 :: CInt +sigUSR1 = CONST_SIGUSR1 +sigUSR2 :: CInt +sigUSR2 = CONST_SIGUSR2 +sigPOLL :: CInt +sigPOLL = CONST_SIGPOLL +sigPROF :: CInt +sigPROF = CONST_SIGPROF +sigSYS :: CInt +sigSYS = CONST_SIGSYS +sigTRAP :: CInt +sigTRAP = CONST_SIGTRAP +sigURG :: CInt +sigURG = CONST_SIGURG +sigVTALRM :: CInt +sigVTALRM = CONST_SIGVTALRM +sigXCPU :: CInt +sigXCPU = CONST_SIGXCPU +sigXFSZ :: CInt +sigXFSZ = CONST_SIGXFSZ + +internalAbort ::Signal +internalAbort = sigABRT + +realTimeAlarm :: Signal +realTimeAlarm = sigALRM + +busError :: Signal +busError = sigBUS + +processStatusChanged :: Signal +processStatusChanged = sigCHLD + +continueProcess :: Signal +continueProcess = sigCONT + +floatingPointException :: Signal +floatingPointException = sigFPE + +lostConnection :: Signal +lostConnection = sigHUP + +illegalInstruction :: Signal +illegalInstruction = sigILL + +keyboardSignal :: Signal +keyboardSignal = sigINT + +killProcess :: Signal +killProcess = sigKILL + +openEndedPipe :: Signal +openEndedPipe = sigPIPE + +keyboardTermination :: Signal +keyboardTermination = sigQUIT + +segmentationViolation :: Signal +segmentationViolation = sigSEGV + +softwareStop :: Signal +softwareStop = sigSTOP + +softwareTermination :: Signal +softwareTermination = sigTERM + +keyboardStop :: Signal +keyboardStop = sigTSTP + +backgroundRead :: Signal +backgroundRead = sigTTIN + +backgroundWrite :: Signal +backgroundWrite = sigTTOU + +userDefinedSignal1 :: Signal +userDefinedSignal1 = sigUSR1 + +userDefinedSignal2 :: Signal +userDefinedSignal2 = sigUSR2 + +#if CONST_SIGPOLL != -1 +pollableEvent :: Signal +pollableEvent = sigPOLL +#endif + +profilingTimerExpired :: Signal +profilingTimerExpired = sigPROF + +badSystemCall :: Signal +badSystemCall = sigSYS + +breakpointTrap :: Signal +breakpointTrap = sigTRAP + +urgentDataAvailable :: Signal +urgentDataAvailable = sigURG + +virtualTimerExpired :: Signal +virtualTimerExpired = sigVTALRM + +cpuTimeLimitExceeded :: Signal +cpuTimeLimitExceeded = sigXCPU + +fileSizeLimitExceeded :: Signal +fileSizeLimitExceeded = sigXFSZ + +-- ----------------------------------------------------------------------------- +-- Signal-related functions + +-- | @signalProcess int pid@ calls @kill@ to signal process @pid@ +-- with interrupt signal @int@. +signalProcess :: Signal -> ProcessID -> IO () +signalProcess sig pid + = throwErrnoIfMinus1_ "signalProcess" (c_kill (fromIntegral pid) sig) + +foreign import ccall unsafe "kill" + c_kill :: CPid -> CInt -> IO CInt + + +-- | @signalProcessGroup int pgid@ calls @kill@ to signal +-- all processes in group @pgid@ with interrupt signal @int@. +signalProcessGroup :: Signal -> ProcessGroupID -> IO () +signalProcessGroup sig pgid + = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg (fromIntegral pgid) sig) + +foreign import ccall unsafe "killpg" + c_killpg :: CPid -> CInt -> IO CInt + +-- | @raiseSignal int@ calls @kill@ to signal the current process +-- with interrupt signal @int@. +raiseSignal :: Signal -> IO () +raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig) + +#if defined(__GLASGOW_HASKELL__) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS)) +foreign import ccall unsafe "genericRaise" + c_raise :: CInt -> IO CInt +#else +foreign import ccall unsafe "raise" + c_raise :: CInt -> IO CInt +#endif + +#ifdef __GLASGOW_HASKELL__ +data Handler = Default + | Ignore + -- not yet: | Hold + | Catch (IO ()) + | CatchOnce (IO ()) + +-- | @installHandler int handler iset@ calls @sigaction@ to install an +-- interrupt handler for signal @int@. If @handler@ is @Default@, +-- @SIG_DFL@ is installed; if @handler@ is @Ignore@, @SIG_IGN@ is +-- installed; if @handler@ is @Catch action@, a handler is installed +-- which will invoke @action@ in a new thread when (or shortly after) the +-- signal is received. +-- If @iset@ is @Just s@, then the @sa_mask@ of the @sigaction@ structure +-- is set to @s@; otherwise it is cleared. The previously installed +-- signal handler for @int@ is returned +installHandler :: Signal + -> Handler + -> Maybe SignalSet -- ^ other signals to block + -> IO Handler -- ^ old handler + +#ifdef __PARALLEL_HASKELL__ +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 = + 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 int STG_SIG_HAN + CatchOnce m -> hinstall m p_sp mask int 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 int 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 + +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 + +#endif /* !__PARALLEL_HASKELL__ */ +#endif /* __GLASGOW_HASKELL__ */ + +-- ----------------------------------------------------------------------------- +-- Alarms + +-- | @scheduleAlarm i@ calls @alarm@ to schedule a real time +-- alarm at least @i@ seconds in the future. +scheduleAlarm :: Int -> IO Int +scheduleAlarm secs = do + r <- c_alarm (fromIntegral secs) + return (fromIntegral r) + +foreign import ccall unsafe "alarm" + c_alarm :: CUInt -> IO CUInt + +#ifdef __GLASGOW_HASKELL__ +-- ----------------------------------------------------------------------------- +-- The NOCLDSTOP flag + +foreign import ccall "&nocldstop" nocldstop :: Ptr Int + +-- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when +-- installing new signal handlers. +setStoppedChildFlag :: Bool -> IO Bool +setStoppedChildFlag b = do + rc <- peek nocldstop + poke nocldstop $ fromEnum (not b) + return (rc == (0::Int)) + +-- | Queries the current state of the stopped child flag. +queryStoppedChildFlag :: IO Bool +queryStoppedChildFlag = do + rc <- peek nocldstop + return (rc == (0::Int)) +#endif /* __GLASGOW_HASKELL__ */ + +-- ----------------------------------------------------------------------------- +-- Manipulating signal sets + +newtype SignalSet = SignalSet (ForeignPtr CSigset) + +emptySignalSet :: SignalSet +emptySignalSet = unsafePerformIO $ do + fp <- mallocForeignPtrBytes sizeof_sigset_t + throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset) + return (SignalSet fp) + +fullSignalSet :: SignalSet +fullSignalSet = unsafePerformIO $ do + fp <- mallocForeignPtrBytes sizeof_sigset_t + throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset) + return (SignalSet fp) + +infixr `addSignal`, `deleteSignal` +addSignal :: Signal -> SignalSet -> SignalSet +addSignal sig (SignalSet fp1) = unsafePerformIO $ do + fp2 <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> do + copyBytes p2 p1 sizeof_sigset_t + throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig) + return (SignalSet fp2) + +deleteSignal :: Signal -> SignalSet -> SignalSet +deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do + fp2 <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp1 $ \p1 -> + withForeignPtr fp2 $ \p2 -> do + copyBytes p2 p1 sizeof_sigset_t + throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig) + return (SignalSet fp2) + +inSignalSet :: Signal -> SignalSet -> Bool +inSignalSet sig (SignalSet fp) = unsafePerformIO $ + withForeignPtr fp $ \p -> do + r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig) + return (r /= 0) + +-- | @getSignalMask@ calls @sigprocmask@ to determine the +-- set of interrupts which are currently being blocked. +getSignalMask :: IO SignalSet +getSignalMask = do + fp <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp $ \p -> + throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p) + return (SignalSet fp) + +sigProcMask :: String -> CInt -> SignalSet -> IO () +sigProcMask fn how (SignalSet set) = + withForeignPtr set $ \p_set -> + throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr) + +-- | @setSignalMask mask@ calls @sigprocmask@ with +-- @SIG_SETMASK@ to block all interrupts in @mask@. +setSignalMask :: SignalSet -> IO () +setSignalMask set = sigProcMask "setSignalMask" (CONST_SIG_SETMASK :: CInt) set + +-- | @blockSignals mask@ calls @sigprocmask@ with +-- @SIG_BLOCK@ to add all interrupts in @mask@ to the +-- set of blocked interrupts. +blockSignals :: SignalSet -> IO () +blockSignals set = sigProcMask "blockSignals" (CONST_SIG_BLOCK :: CInt) set + +-- | @unblockSignals mask@ calls @sigprocmask@ with +-- @SIG_UNBLOCK@ to remove all interrupts in @mask@ from the +-- set of blocked interrupts. +unblockSignals :: SignalSet -> IO () +unblockSignals set = sigProcMask "unblockSignals" (CONST_SIG_UNBLOCK :: CInt) set + +-- | @getPendingSignals@ calls @sigpending@ to obtain +-- the set of interrupts which have been received but are currently blocked. +getPendingSignals :: IO SignalSet +getPendingSignals = do + fp <- mallocForeignPtrBytes sizeof_sigset_t + withForeignPtr fp $ \p -> + throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p) + return (SignalSet fp) + +#ifndef cygwin32_HOST_OS + +-- | @awaitSignal iset@ suspends execution until an interrupt is received. +-- If @iset@ is @Just s@, @awaitSignal@ calls @sigsuspend@, installing +-- @s@ as the new signal mask before suspending execution; otherwise, it +-- calls @pause@. @awaitSignal@ returns on receipt of a signal. If you +-- have installed any signal handlers with @installHandler@, it may be +-- wise to call @yield@ directly after @awaitSignal@ to ensure that the +-- signal handler runs as promptly as possible. +awaitSignal :: Maybe SignalSet -> IO () +awaitSignal maybe_sigset = do + fp <- case maybe_sigset of + Nothing -> do SignalSet fp <- getSignalMask; return fp + Just (SignalSet fp) -> return fp + withForeignPtr fp $ \p -> do + c_sigsuspend p + return () + -- ignore the return value; according to the docs it can only ever be + -- (-1) with errno set to EINTR. + +foreign import ccall unsafe "sigsuspend" + c_sigsuspend :: Ptr CSigset -> IO CInt +#endif + +#ifdef __HUGS__ +foreign import ccall unsafe "sigdelset" + c_sigdelset :: Ptr CSigset -> CInt -> IO CInt + +foreign import ccall unsafe "sigfillset" + c_sigfillset :: Ptr CSigset -> IO CInt + +foreign import ccall unsafe "sigismember" + c_sigismember :: Ptr CSigset -> CInt -> IO CInt +#else +foreign import ccall unsafe "__hscore_sigdelset" + c_sigdelset :: Ptr CSigset -> CInt -> IO CInt + +foreign import ccall unsafe "__hscore_sigfillset" + c_sigfillset :: Ptr CSigset -> IO CInt + +foreign import ccall unsafe "__hscore_sigismember" + c_sigismember :: Ptr CSigset -> CInt -> IO CInt +#endif /* __HUGS__ */ + +foreign import ccall unsafe "sigpending" + c_sigpending :: Ptr CSigset -> IO CInt + |