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