1{-# LANGUAGE CApiFFI, CPP, DeriveDataTypeable, NondecreasingIndentation #-}
2{-# OPTIONS_GHC -fno-cse #-} -- global variables
3{-# LANGUAGE Trustworthy #-}
4-----------------------------------------------------------------------------
5-- |
6-- Module      :  System.Posix.Signals
7-- Copyright   :  (c) The University of Glasgow 2002
8-- License     :  BSD-style (see the file libraries/base/LICENSE)
9--
10-- Maintainer  :  libraries@haskell.org
11-- Stability   :  provisional
12-- Portability :  non-portable (requires POSIX)
13--
14-- POSIX signal support
15--
16-----------------------------------------------------------------------------
17
18#include "HsUnixConfig.h"
19##include "HsUnixConfig.h"
20
21#ifdef HAVE_SIGNAL_H
22#include <signal.h>
23#endif
24
25module System.Posix.Signals (
26  -- * The Signal type
27  Signal,
28
29  -- * Specific signals
30  nullSignal,
31  internalAbort, sigABRT,
32  realTimeAlarm, sigALRM,
33  busError, sigBUS,
34  processStatusChanged, sigCHLD,
35  continueProcess, sigCONT,
36  floatingPointException, sigFPE,
37  lostConnection, sigHUP,
38  illegalInstruction, sigILL,
39  keyboardSignal, sigINT,
40  killProcess, sigKILL,
41  openEndedPipe, sigPIPE,
42  keyboardTermination, sigQUIT,
43  segmentationViolation, sigSEGV,
44  softwareStop, sigSTOP,
45  softwareTermination, sigTERM,
46  keyboardStop, sigTSTP,
47  backgroundRead, sigTTIN,
48  backgroundWrite, sigTTOU,
49  userDefinedSignal1, sigUSR1,
50  userDefinedSignal2, sigUSR2,
51#if CONST_SIGPOLL != -1
52  pollableEvent, sigPOLL,
53#endif
54  profilingTimerExpired, sigPROF,
55  badSystemCall, sigSYS,
56  breakpointTrap, sigTRAP,
57  urgentDataAvailable, sigURG,
58  virtualTimerExpired, sigVTALRM,
59  cpuTimeLimitExceeded, sigXCPU,
60  fileSizeLimitExceeded, sigXFSZ,
61
62  -- * Sending signals
63  raiseSignal,
64  signalProcess,
65  signalProcessGroup,
66
67  -- * Handling signals
68  Handler(Default,Ignore,Catch,CatchOnce,CatchInfo,CatchInfoOnce),
69  SignalInfo(..), SignalSpecificInfo(..),
70  installHandler,
71
72  -- * Signal sets
73  SignalSet,
74  emptySignalSet, fullSignalSet, reservedSignals,
75  addSignal, deleteSignal, inSignalSet,
76
77  -- * The process signal mask
78  getSignalMask, setSignalMask, blockSignals, unblockSignals,
79
80  -- * The alarm timer
81  scheduleAlarm,
82
83  -- * Waiting for signals
84  getPendingSignals,
85  awaitSignal,
86
87  -- * The @NOCLDSTOP@ flag
88  setStoppedChildFlag, queryStoppedChildFlag,
89
90  -- MISSING FUNCTIONALITY:
91  -- sigaction(), (inc. the sigaction structure + flags etc.)
92  -- the siginfo structure
93  -- sigaltstack()
94  -- sighold, sigignore, sigpause, sigrelse, sigset
95  -- siginterrupt
96  ) where
97
98import Data.Word
99import Foreign.C
100import Foreign.ForeignPtr
101import Foreign.Marshal
102import Foreign.Ptr
103import Foreign.Storable
104import System.IO.Unsafe (unsafePerformIO)
105import System.Posix.Types
106import System.Posix.Internals
107import System.Posix.Process
108import System.Posix.Process.Internals
109import Data.Dynamic
110
111##include "rts/Signals.h"
112
113import GHC.Conc hiding (Signal)
114
115-- -----------------------------------------------------------------------------
116-- Specific signals
117
118nullSignal :: Signal
119nullSignal = 0
120
121sigABRT   :: CInt
122sigABRT   = CONST_SIGABRT
123sigALRM   :: CInt
124sigALRM   = CONST_SIGALRM
125sigBUS    :: CInt
126sigBUS    = CONST_SIGBUS
127sigCHLD   :: CInt
128sigCHLD   = CONST_SIGCHLD
129sigCONT   :: CInt
130sigCONT   = CONST_SIGCONT
131sigFPE    :: CInt
132sigFPE    = CONST_SIGFPE
133sigHUP    :: CInt
134sigHUP    = CONST_SIGHUP
135sigILL    :: CInt
136sigILL    = CONST_SIGILL
137sigINT    :: CInt
138sigINT    = CONST_SIGINT
139sigKILL   :: CInt
140sigKILL   = CONST_SIGKILL
141sigPIPE   :: CInt
142sigPIPE   = CONST_SIGPIPE
143sigQUIT   :: CInt
144sigQUIT   = CONST_SIGQUIT
145sigSEGV   :: CInt
146sigSEGV   = CONST_SIGSEGV
147sigSTOP   :: CInt
148sigSTOP   = CONST_SIGSTOP
149sigTERM   :: CInt
150sigTERM   = CONST_SIGTERM
151sigTSTP   :: CInt
152sigTSTP   = CONST_SIGTSTP
153sigTTIN   :: CInt
154sigTTIN   = CONST_SIGTTIN
155sigTTOU   :: CInt
156sigTTOU   = CONST_SIGTTOU
157sigUSR1   :: CInt
158sigUSR1   = CONST_SIGUSR1
159sigUSR2   :: CInt
160sigUSR2   = CONST_SIGUSR2
161#if CONST_SIGPOLL != -1
162sigPOLL   :: CInt
163sigPOLL   = CONST_SIGPOLL
164#endif
165sigPROF   :: CInt
166sigPROF   = CONST_SIGPROF
167sigSYS    :: CInt
168sigSYS    = CONST_SIGSYS
169sigTRAP   :: CInt
170sigTRAP   = CONST_SIGTRAP
171sigURG    :: CInt
172sigURG    = CONST_SIGURG
173sigVTALRM :: CInt
174sigVTALRM = CONST_SIGVTALRM
175sigXCPU   :: CInt
176sigXCPU   = CONST_SIGXCPU
177sigXFSZ   :: CInt
178sigXFSZ   = CONST_SIGXFSZ
179
180internalAbort ::Signal
181internalAbort = sigABRT
182
183realTimeAlarm :: Signal
184realTimeAlarm = sigALRM
185
186busError :: Signal
187busError = sigBUS
188
189processStatusChanged :: Signal
190processStatusChanged = sigCHLD
191
192continueProcess :: Signal
193continueProcess = sigCONT
194
195floatingPointException :: Signal
196floatingPointException = sigFPE
197
198lostConnection :: Signal
199lostConnection = sigHUP
200
201illegalInstruction :: Signal
202illegalInstruction = sigILL
203
204keyboardSignal :: Signal
205keyboardSignal = sigINT
206
207killProcess :: Signal
208killProcess = sigKILL
209
210openEndedPipe :: Signal
211openEndedPipe = sigPIPE
212
213keyboardTermination :: Signal
214keyboardTermination = sigQUIT
215
216segmentationViolation :: Signal
217segmentationViolation = sigSEGV
218
219softwareStop :: Signal
220softwareStop = sigSTOP
221
222softwareTermination :: Signal
223softwareTermination = sigTERM
224
225keyboardStop :: Signal
226keyboardStop = sigTSTP
227
228backgroundRead :: Signal
229backgroundRead = sigTTIN
230
231backgroundWrite :: Signal
232backgroundWrite = sigTTOU
233
234userDefinedSignal1 :: Signal
235userDefinedSignal1 = sigUSR1
236
237userDefinedSignal2 :: Signal
238userDefinedSignal2 = sigUSR2
239
240#if CONST_SIGPOLL != -1
241pollableEvent :: Signal
242pollableEvent = sigPOLL
243#endif
244
245profilingTimerExpired :: Signal
246profilingTimerExpired = sigPROF
247
248badSystemCall :: Signal
249badSystemCall = sigSYS
250
251breakpointTrap :: Signal
252breakpointTrap = sigTRAP
253
254urgentDataAvailable :: Signal
255urgentDataAvailable = sigURG
256
257virtualTimerExpired :: Signal
258virtualTimerExpired = sigVTALRM
259
260cpuTimeLimitExceeded :: Signal
261cpuTimeLimitExceeded = sigXCPU
262
263fileSizeLimitExceeded :: Signal
264fileSizeLimitExceeded = sigXFSZ
265
266-- -----------------------------------------------------------------------------
267-- Signal-related functions
268
269-- | @signalProcess int pid@ calls @kill@ to signal process @pid@
270--   with interrupt signal @int@.
271signalProcess :: Signal -> ProcessID -> IO ()
272signalProcess sig pid
273 = throwErrnoIfMinus1_ "signalProcess" (c_kill pid sig)
274
275foreign import ccall unsafe "kill"
276  c_kill :: CPid -> CInt -> IO CInt
277
278
279-- | @signalProcessGroup int pgid@ calls @kill@ to signal
280--  all processes in group @pgid@ with interrupt signal @int@.
281signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
282signalProcessGroup sig pgid
283  = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg pgid sig)
284
285foreign import ccall unsafe "killpg"
286  c_killpg :: CPid -> CInt -> IO CInt
287
288-- | @raiseSignal int@ calls @kill@ to signal the current process
289--   with interrupt signal @int@.
290raiseSignal :: Signal -> IO ()
291raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig)
292
293-- See also note in GHC's rts/RtsUtils.c
294-- This is somewhat fragile because we need to keep the
295-- `#if`-conditional in sync with GHC's runtime.
296#if (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS) || defined(dragonfly_HOST_OS) || defined(netbsd_HOST_OS) || defined(darwin_HOST_OS))
297foreign import ccall unsafe "genericRaise"
298  c_raise :: CInt -> IO CInt
299#else
300foreign import ccall unsafe "raise"
301  c_raise :: CInt -> IO CInt
302#endif
303
304
305type Signal = CInt
306
307-- | The actions to perform when a signal is received.
308data Handler = Default
309             | Ignore
310             -- not yet: | Hold
311             | Catch (IO ())
312             | CatchOnce (IO ())
313             | CatchInfo (SignalInfo -> IO ())     -- ^ @since 2.7.0.0
314             | CatchInfoOnce (SignalInfo -> IO ()) -- ^ @since 2.7.0.0
315  deriving (Typeable)
316
317-- | Information about a received signal (derived from @siginfo_t@).
318--
319-- @since 2.7.0.0
320data SignalInfo = SignalInfo {
321      siginfoSignal   :: Signal,
322      siginfoError    :: Errno,
323      siginfoSpecific :: SignalSpecificInfo
324  }
325
326-- | Information specific to a particular type of signal
327-- (derived from @siginfo_t@).
328--
329-- @since 2.7.0.0
330data SignalSpecificInfo
331  = NoSignalSpecificInfo
332  | SigChldInfo {
333      siginfoPid    :: ProcessID,
334      siginfoUid    :: UserID,
335      siginfoStatus :: ProcessStatus
336    }
337
338-- | @installHandler int handler iset@ calls @sigaction@ to install an
339--   interrupt handler for signal @int@.  If @handler@ is @Default@,
340--   @SIG_DFL@ is installed; if @handler@ is @Ignore@, @SIG_IGN@ is
341--   installed; if @handler@ is @Catch action@, a handler is installed
342--   which will invoke @action@ in a new thread when (or shortly after) the
343--   signal is received.
344--   If @iset@ is @Just s@, then the @sa_mask@ of the @sigaction@ structure
345--   is set to @s@; otherwise it is cleared.  The previously installed
346--   signal handler for @int@ is returned
347installHandler :: Signal
348               -> Handler
349               -> Maybe SignalSet       -- ^ other signals to block
350               -> IO Handler            -- ^ old handler
351
352#ifdef __PARALLEL_HASKELL__
353installHandler =
354  error "installHandler: not available for Parallel Haskell"
355#else
356
357installHandler sig handler _maybe_mask = do
358  ensureIOManagerIsRunning  -- for the threaded RTS
359
360  -- if we're setting the action to DFL or IGN, we should do that *first*
361  -- if we're setting a handler,
362  --   if the previous action was handle, then setHandler is ok
363  --   if the previous action was IGN/DFL, then setHandler followed by sig_install
364  (old_action, old_handler) <-
365    case handler of
366      Ignore  -> do
367        old_action  <- stg_sig_install sig STG_SIG_IGN nullPtr
368        old_handler <- setHandler sig Nothing
369        return (old_action, old_handler)
370
371      Default -> do
372        old_action  <- stg_sig_install sig STG_SIG_DFL nullPtr
373        old_handler <- setHandler sig Nothing
374        return (old_action, old_handler)
375
376      _some_kind_of_catch -> do
377        -- I don't think it's possible to get CatchOnce right.  If
378        -- there's a signal in flight, then we might run the handler
379        -- more than once.
380        let dyn = toDyn handler
381        old_handler <- case handler of
382            Catch         action -> setHandler sig (Just (const action,dyn))
383            CatchOnce     action -> setHandler sig (Just (const action,dyn))
384            CatchInfo     action -> setHandler sig (Just (getinfo action,dyn))
385            CatchInfoOnce action -> setHandler sig (Just (getinfo action,dyn))
386            _                    -> error "installHandler"
387
388        let action = case handler of
389                Catch _         -> STG_SIG_HAN
390                CatchOnce _     -> STG_SIG_RST
391                CatchInfo _     -> STG_SIG_HAN
392                CatchInfoOnce _ -> STG_SIG_RST
393                _               -> error "installHandler"
394
395        old_action <- stg_sig_install sig action nullPtr
396                   -- mask is pointless, so leave it NULL
397
398        return (old_action, old_handler)
399
400  case (old_handler,old_action) of
401    (_,       STG_SIG_DFL) -> return $ Default
402    (_,       STG_SIG_IGN) -> return $ Ignore
403    (Nothing, _)           -> return $ Ignore
404    (Just (_,dyn),  _)
405        | Just h <- fromDynamic dyn  -> return h
406        | Just io <- fromDynamic dyn -> return (Catch io)
407        -- handlers put there by the base package have type IO ()
408        | otherwise                  -> return Default
409
410foreign import ccall unsafe
411  stg_sig_install
412        :: CInt                         -- sig no.
413        -> CInt                         -- action code (STG_SIG_HAN etc.)
414        -> Ptr CSigset                  -- (in, out) blocked
415        -> IO CInt                      -- (ret) old action code
416
417getinfo :: (SignalInfo -> IO ()) -> ForeignPtr Word8 -> IO ()
418getinfo handler fp_info = do
419  si <- unmarshalSigInfo fp_info
420  handler si
421
422unmarshalSigInfo :: ForeignPtr Word8 -> IO SignalInfo
423unmarshalSigInfo fp = do
424  withForeignPtr fp $ \p -> do
425    sig   <- (#peek siginfo_t, si_signo) p
426    errno <- (#peek siginfo_t, si_errno) p
427    extra <- case sig of
428                _ | sig == sigCHLD -> do
429                    pid <- (#peek siginfo_t, si_pid) p
430                    uid <- (#peek siginfo_t, si_uid) p
431                    wstat <- (#peek siginfo_t, si_status) p
432                    pstat <- decipherWaitStatus wstat
433                    return SigChldInfo { siginfoPid = pid,
434                                         siginfoUid = uid,
435                                         siginfoStatus = pstat }
436                _ | otherwise ->
437                    return NoSignalSpecificInfo
438    return
439      SignalInfo {
440        siginfoSignal = sig,
441        siginfoError  = Errno errno,
442        siginfoSpecific = extra }
443
444#endif /* !__PARALLEL_HASKELL__ */
445
446-- -----------------------------------------------------------------------------
447-- Alarms
448
449-- | @scheduleAlarm i@ calls @alarm@ to schedule a real time
450--   alarm at least @i@ seconds in the future.
451scheduleAlarm :: Int -> IO Int
452scheduleAlarm secs = do
453   r <- c_alarm (fromIntegral secs)
454   return (fromIntegral r)
455
456foreign import ccall unsafe "alarm"
457  c_alarm :: CUInt -> IO CUInt
458
459-- -----------------------------------------------------------------------------
460-- The NOCLDSTOP flag
461
462foreign import ccall "&nocldstop" nocldstop :: Ptr Int
463
464-- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when
465-- installing new signal handlers.
466setStoppedChildFlag :: Bool -> IO Bool
467setStoppedChildFlag b = do
468    rc <- peek nocldstop
469    poke nocldstop $ fromEnum (not b)
470    return (rc == (0::Int))
471
472-- | Queries the current state of the stopped child flag.
473queryStoppedChildFlag :: IO Bool
474queryStoppedChildFlag = do
475    rc <- peek nocldstop
476    return (rc == (0::Int))
477
478-- -----------------------------------------------------------------------------
479-- Manipulating signal sets
480
481newtype SignalSet = SignalSet (ForeignPtr CSigset)
482
483emptySignalSet :: SignalSet
484emptySignalSet = unsafePerformIO $ do
485  fp <- mallocForeignPtrBytes sizeof_sigset_t
486  throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
487  return (SignalSet fp)
488
489fullSignalSet :: SignalSet
490fullSignalSet = unsafePerformIO $ do
491  fp <- mallocForeignPtrBytes sizeof_sigset_t
492  throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
493  return (SignalSet fp)
494
495-- | A set of signals reserved for use by the implementation.  In GHC, this will normally
496-- include either `sigVTALRM` or `sigALRM`.
497reservedSignals :: SignalSet
498reservedSignals = addSignal rtsTimerSignal emptySignalSet
499
500foreign import ccall rtsTimerSignal :: CInt
501
502infixr `addSignal`, `deleteSignal`
503addSignal :: Signal -> SignalSet -> SignalSet
504addSignal sig (SignalSet fp1) = unsafePerformIO $ do
505  fp2 <- mallocForeignPtrBytes sizeof_sigset_t
506  withForeignPtr fp1 $ \p1 ->
507    withForeignPtr fp2 $ \p2 -> do
508      copyBytes p2 p1 sizeof_sigset_t
509      throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
510  return (SignalSet fp2)
511
512deleteSignal :: Signal -> SignalSet -> SignalSet
513deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
514  fp2 <- mallocForeignPtrBytes sizeof_sigset_t
515  withForeignPtr fp1 $ \p1 ->
516    withForeignPtr fp2 $ \p2 -> do
517      copyBytes p2 p1 sizeof_sigset_t
518      throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
519  return (SignalSet fp2)
520
521inSignalSet :: Signal -> SignalSet -> Bool
522inSignalSet sig (SignalSet fp) = unsafePerformIO $
523  withForeignPtr fp $ \p -> do
524    r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
525    return (r /= 0)
526
527-- | @getSignalMask@ calls @sigprocmask@ to determine the
528--   set of interrupts which are currently being blocked.
529getSignalMask :: IO SignalSet
530getSignalMask = do
531  fp <- mallocForeignPtrBytes sizeof_sigset_t
532  withForeignPtr fp $ \p ->
533    throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p)
534  return (SignalSet fp)
535
536sigProcMask :: String -> CInt -> SignalSet -> IO ()
537sigProcMask fn how (SignalSet set) =
538  withForeignPtr set $ \p_set ->
539    throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)
540
541-- | @setSignalMask mask@ calls @sigprocmask@ with
542--   @SIG_SETMASK@ to block all interrupts in @mask@.
543setSignalMask :: SignalSet -> IO ()
544setSignalMask set = sigProcMask "setSignalMask" (CONST_SIG_SETMASK :: CInt) set
545
546-- | @blockSignals mask@ calls @sigprocmask@ with
547--   @SIG_BLOCK@ to add all interrupts in @mask@ to the
548--  set of blocked interrupts.
549blockSignals :: SignalSet -> IO ()
550blockSignals set = sigProcMask "blockSignals" (CONST_SIG_BLOCK :: CInt) set
551
552-- | @unblockSignals mask@ calls @sigprocmask@ with
553--   @SIG_UNBLOCK@ to remove all interrupts in @mask@ from the
554--   set of blocked interrupts.
555unblockSignals :: SignalSet -> IO ()
556unblockSignals set = sigProcMask "unblockSignals" (CONST_SIG_UNBLOCK :: CInt) set
557
558-- | @getPendingSignals@ calls @sigpending@ to obtain
559--   the set of interrupts which have been received but are currently blocked.
560getPendingSignals :: IO SignalSet
561getPendingSignals = do
562  fp <- mallocForeignPtrBytes sizeof_sigset_t
563  withForeignPtr fp $ \p ->
564   throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
565  return (SignalSet fp)
566
567-- | @awaitSignal iset@ suspends execution until an interrupt is received.
568-- If @iset@ is @Just s@, @awaitSignal@ calls @sigsuspend@, installing
569-- @s@ as the new signal mask before suspending execution; otherwise, it
570-- calls @sigsuspend@ with current signal mask. Note that RTS
571-- scheduler signal (either 'virtualTimerExpired' or 'realTimeAlarm')
572-- could cause premature termination of this call. It might be necessary to block that
573-- signal before invocation of @awaitSignal@ with 'blockSignals' 'reservedSignals'.
574--
575-- @awaitSignal@ returns when signal was received and processed by a
576-- signal handler, or if the signal could not be caught. If you have
577-- installed any signal handlers with @installHandler@, it may be wise
578-- to call @yield@ directly after @awaitSignal@ to ensure that the
579-- signal handler runs as promptly as possible.
580awaitSignal :: Maybe SignalSet -> IO ()
581awaitSignal maybe_sigset = do
582  fp <- case maybe_sigset of
583          Nothing -> do SignalSet fp <- getSignalMask; return fp
584          Just (SignalSet fp) -> return fp
585  withForeignPtr fp $ \p -> do
586  _ <- c_sigsuspend p
587  return ()
588  -- ignore the return value; according to the docs it can only ever be
589  -- (-1) with errno set to EINTR.
590  -- XXX My manpage says it can also return EFAULT. And why is ignoring
591  -- EINTR the right thing to do?
592
593foreign import ccall unsafe "sigsuspend"
594  c_sigsuspend :: Ptr CSigset -> IO CInt
595
596#if defined(darwin_HOST_OS) && __GLASGOW_HASKELL__ < 706
597-- see http://ghc.haskell.org/trac/ghc/ticket/7359#comment:3
598-- To be removed when support for GHC 7.4.x is dropped
599foreign import ccall unsafe "__hscore_sigdelset"
600  c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
601
602foreign import ccall unsafe "__hscore_sigfillset"
603  c_sigfillset  :: Ptr CSigset -> IO CInt
604
605foreign import ccall unsafe "__hscore_sigismember"
606  c_sigismember :: Ptr CSigset -> CInt -> IO CInt
607#else
608foreign import capi unsafe "signal.h sigdelset"
609  c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
610
611foreign import capi unsafe "signal.h sigfillset"
612  c_sigfillset  :: Ptr CSigset -> IO CInt
613
614foreign import capi unsafe "signal.h sigismember"
615  c_sigismember :: Ptr CSigset -> CInt -> IO CInt
616#endif
617
618foreign import ccall unsafe "sigpending"
619  c_sigpending :: Ptr CSigset -> IO CInt
620