System/Posix/Signals.hs

   1 -----------------------------------------------------------------------------
   2 -- |
   3 -- Module      :  System.Posix.Signals
   4 -- Copyright   :  (c) The University of Glasgow 2002
   5 -- License     :  BSD-style (see the file libraries/base/LICENSE)
   6 --
   7 -- Maintainer  :  libraries@haskell.org
   8 -- Stability   :  provisional
   9 -- Portability :  non-portable (requires POSIX)
  10 --
  11 -- POSIX signal support
  12 --
  13 -----------------------------------------------------------------------------
  14
  15 #include "HsBaseConfig.h"
  16
  17 module System.Posix.Signals (
  18 #ifndef mingw32_HOST_OS
  19   -- * The Signal type
  20   Signal,
  21
  22   -- * Specific signals
  23   nullSignal,
  24   internalAbort, sigABRT,
  25   realTimeAlarm, sigALRM,
  26   busError, sigBUS,
  27   processStatusChanged, sigCHLD,
  28   continueProcess, sigCONT,
  29   floatingPointException, sigFPE,
  30   lostConnection, sigHUP,
  31   illegalInstruction, sigILL,
  32   keyboardSignal, sigINT,
  33   killProcess, sigKILL,
  34   openEndedPipe, sigPIPE,
  35   keyboardTermination, sigQUIT,
  36   segmentationViolation, sigSEGV,
  37   softwareStop, sigSTOP,
  38   softwareTermination, sigTERM,
  39   keyboardStop, sigTSTP,
  40   backgroundRead, sigTTIN,
  41   backgroundWrite, sigTTOU,
  42   userDefinedSignal1, sigUSR1,
  43   userDefinedSignal2, sigUSR2,
  44 #if CONST_SIGPOLL != -1
  45   pollableEvent, sigPOLL,
  46 #endif
  47   profilingTimerExpired, sigPROF,
  48   badSystemCall, sigSYS,
  49   breakpointTrap, sigTRAP,
  50   urgentDataAvailable, sigURG,
  51   virtualTimerExpired, sigVTALRM,
  52   cpuTimeLimitExceeded, sigXCPU,
  53   fileSizeLimitExceeded, sigXFSZ,
  54
  55   -- * Sending signals
  56   raiseSignal,
  57   signalProcess,
  58   signalProcessGroup,
  59
  60 #ifdef __GLASGOW_HASKELL__
  61   -- * Handling signals
  62   Handler(..),
  63   installHandler,
  64 #endif
  65
  66   -- * Signal sets
  67   SignalSet,
  68   emptySignalSet, fullSignalSet,
  69   addSignal, deleteSignal, inSignalSet,
  70
  71   -- * The process signal mask
  72   getSignalMask, setSignalMask, blockSignals, unblockSignals,
  73
  74   -- * The alarm timer
  75   scheduleAlarm,
  76
  77   -- * Waiting for signals
  78   getPendingSignals,
  79 #ifndef cygwin32_HOST_OS
  80   awaitSignal,
  81 #endif
  82
  83 #ifdef __GLASGOW_HASKELL__
  84   -- * The @NOCLDSTOP@ flag
  85   setStoppedChildFlag, queryStoppedChildFlag,
  86 #endif
  87
  88   -- MISSING FUNCTIONALITY:
  89   -- sigaction(), (inc. the sigaction structure + flags etc.)
  90   -- the siginfo structure
  91   -- sigaltstack()
  92   -- sighold, sigignore, sigpause, sigrelse, sigset
  93   -- siginterrupt
  94 #endif
  95   ) where
  96
  97 import Prelude -- necessary to get dependencies right
  98
  99 import Foreign
 100 import Foreign.C
 101 import System.IO.Unsafe
 102 import System.Posix.Types
 103 import System.Posix.Internals
 104
 105 #ifndef mingw32_HOST_OS
 106 -- WHOLE FILE...
 107
 108 #ifdef __GLASGOW_HASKELL__
 109 #include "Signals.h"
 110 import GHC.Conc ( ensureIOManagerIsRunning )
 111 #endif
 112
 113 -- -----------------------------------------------------------------------------
 114 -- Specific signals
 115
 116 type Signal = CInt
 117
 118 nullSignal :: Signal
 119 nullSignal = 0
 120
 121 sigABRT   :: CInt
 122 sigABRT   = CONST_SIGABRT
 123 sigALRM   :: CInt
 124 sigALRM   = CONST_SIGALRM
 125 sigBUS    :: CInt
 126 sigBUS    = CONST_SIGBUS
 127 sigCHLD   :: CInt
 128 sigCHLD   = CONST_SIGCHLD
 129 sigCONT   :: CInt
 130 sigCONT   = CONST_SIGCONT
 131 sigFPE    :: CInt
 132 sigFPE    = CONST_SIGFPE
 133 sigHUP    :: CInt
 134 sigHUP    = CONST_SIGHUP
 135 sigILL    :: CInt
 136 sigILL    = CONST_SIGILL
 137 sigINT    :: CInt
 138 sigINT    = CONST_SIGINT
 139 sigKILL   :: CInt
 140 sigKILL   = CONST_SIGKILL
 141 sigPIPE   :: CInt
 142 sigPIPE   = CONST_SIGPIPE
 143 sigQUIT   :: CInt
 144 sigQUIT   = CONST_SIGQUIT
 145 sigSEGV   :: CInt
 146 sigSEGV   = CONST_SIGSEGV
 147 sigSTOP   :: CInt
 148 sigSTOP   = CONST_SIGSTOP
 149 sigTERM   :: CInt
 150 sigTERM   = CONST_SIGTERM
 151 sigTSTP   :: CInt
 152 sigTSTP   = CONST_SIGTSTP
 153 sigTTIN   :: CInt
 154 sigTTIN   = CONST_SIGTTIN
 155 sigTTOU   :: CInt
 156 sigTTOU   = CONST_SIGTTOU
 157 sigUSR1   :: CInt
 158 sigUSR1   = CONST_SIGUSR1
 159 sigUSR2   :: CInt
 160 sigUSR2   = CONST_SIGUSR2
 161 sigPOLL   :: CInt
 162 sigPOLL   = CONST_SIGPOLL
 163 sigPROF   :: CInt
 164 sigPROF   = CONST_SIGPROF
 165 sigSYS    :: CInt
 166 sigSYS    = CONST_SIGSYS
 167 sigTRAP   :: CInt
 168 sigTRAP   = CONST_SIGTRAP
 169 sigURG    :: CInt
 170 sigURG    = CONST_SIGURG
 171 sigVTALRM :: CInt
 172 sigVTALRM = CONST_SIGVTALRM
 173 sigXCPU   :: CInt
 174 sigXCPU   = CONST_SIGXCPU
 175 sigXFSZ   :: CInt
 176 sigXFSZ   = CONST_SIGXFSZ
 177
 178 internalAbort ::Signal
 179 internalAbort = sigABRT
 180
 181 realTimeAlarm :: Signal
 182 realTimeAlarm = sigALRM
 183
 184 busError :: Signal
 185 busError = sigBUS
 186
 187 processStatusChanged :: Signal
 188 processStatusChanged = sigCHLD
 189
 190 continueProcess :: Signal
 191 continueProcess = sigCONT
 192
 193 floatingPointException :: Signal
 194 floatingPointException = sigFPE
 195
 196 lostConnection :: Signal
 197 lostConnection = sigHUP
 198
 199 illegalInstruction :: Signal
 200 illegalInstruction = sigILL
 201
 202 keyboardSignal :: Signal
 203 keyboardSignal = sigINT
 204
 205 killProcess :: Signal
 206 killProcess = sigKILL
 207
 208 openEndedPipe :: Signal
 209 openEndedPipe = sigPIPE
 210
 211 keyboardTermination :: Signal
 212 keyboardTermination = sigQUIT
 213
 214 segmentationViolation :: Signal
 215 segmentationViolation = sigSEGV
 216
 217 softwareStop :: Signal
 218 softwareStop = sigSTOP
 219
 220 softwareTermination :: Signal
 221 softwareTermination = sigTERM
 222
 223 keyboardStop :: Signal
 224 keyboardStop = sigTSTP
 225
 226 backgroundRead :: Signal
 227 backgroundRead = sigTTIN
 228
 229 backgroundWrite :: Signal
 230 backgroundWrite = sigTTOU
 231
 232 userDefinedSignal1 :: Signal
 233 userDefinedSignal1 = sigUSR1
 234
 235 userDefinedSignal2 :: Signal
 236 userDefinedSignal2 = sigUSR2
 237
 238 #if CONST_SIGPOLL != -1
 239 pollableEvent :: Signal
 240 pollableEvent = sigPOLL
 241 #endif
 242
 243 profilingTimerExpired :: Signal
 244 profilingTimerExpired = sigPROF
 245
 246 badSystemCall :: Signal
 247 badSystemCall = sigSYS
 248
 249 breakpointTrap :: Signal
 250 breakpointTrap = sigTRAP
 251
 252 urgentDataAvailable :: Signal
 253 urgentDataAvailable = sigURG
 254
 255 virtualTimerExpired :: Signal
 256 virtualTimerExpired = sigVTALRM
 257
 258 cpuTimeLimitExceeded :: Signal
 259 cpuTimeLimitExceeded = sigXCPU
 260
 261 fileSizeLimitExceeded :: Signal
 262 fileSizeLimitExceeded = sigXFSZ
 263
 264 -- -----------------------------------------------------------------------------
 265 -- Signal-related functions
 266
 267 -- | @signalProcess int pid@ calls @kill@ to signal process @pid@
 268 --   with interrupt signal @int@.
 269 signalProcess :: Signal -> ProcessID -> IO ()
 270 signalProcess sig pid
 271  = throwErrnoIfMinus1_ "signalProcess" (c_kill (fromIntegral pid) sig)
 272
 273 foreign import ccall unsafe "kill"
 274   c_kill :: CPid -> CInt -> IO CInt
 275
 276
 277 -- | @signalProcessGroup int pgid@ calls @kill@ to signal
 278 --  all processes in group @pgid@ with interrupt signal @int@.
 279 signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
 280 signalProcessGroup sig pgid
 281   = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg (fromIntegral pgid) sig)
 282
 283 foreign import ccall unsafe "killpg"
 284   c_killpg :: CPid -> CInt -> IO CInt
 285
 286 -- | @raiseSignal int@ calls @kill@ to signal the current process
 287 --   with interrupt signal @int@.
 288 raiseSignal :: Signal -> IO ()
 289 raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig)
 290
 291 #if defined(__GLASGOW_HASKELL__) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS))
 292 foreign import ccall unsafe "genericRaise"
 293   c_raise :: CInt -> IO CInt
 294 #else
 295 foreign import ccall unsafe "raise"
 296   c_raise :: CInt -> IO CInt
 297 #endif
 298
 299 #ifdef __GLASGOW_HASKELL__
 300 data Handler = Default
 301              | Ignore
 302              -- not yet: | Hold
 303              | Catch (IO ())
 304              | CatchOnce (IO ())
 305
 306 -- | @installHandler int handler iset@ calls @sigaction@ to install an
 307 --   interrupt handler for signal @int@.  If @handler@ is @Default@,
 308 --   @SIG_DFL@ is installed; if @handler@ is @Ignore@, @SIG_IGN@ is
 309 --   installed; if @handler@ is @Catch action@, a handler is installed
 310 --   which will invoke @action@ in a new thread when (or shortly after) the
 311 --   signal is received.
 312 --   If @iset@ is @Just s@, then the @sa_mask@ of the @sigaction@ structure
 313 --   is set to @s@; otherwise it is cleared.  The previously installed
 314 --   signal handler for @int@ is returned
 315 installHandler :: Signal
 316                -> Handler
 317                -> Maybe SignalSet       -- ^ other signals to block
 318                -> IO Handler            -- ^ old handler
 319
 320 #ifdef __PARALLEL_HASKELL__
 321 installHandler =
 322   error "installHandler: not available for Parallel Haskell"
 323 #else
 324
 325 installHandler int handler maybe_mask = do
 326     ensureIOManagerIsRunning  -- for the threaded RTS
 327     case maybe_mask of
 328         Nothing -> install' nullPtr
 329         Just (SignalSet x) -> withForeignPtr x $ install'
 330   where
 331     install' mask =
 332       alloca $ \p_sp -> do
 333
 334       rc <- case handler of
 335               Default      -> stg_sig_install int STG_SIG_DFL p_sp mask
 336               Ignore       -> stg_sig_install int STG_SIG_IGN p_sp mask
 337               Catch m      -> hinstall m p_sp mask int STG_SIG_HAN
 338               CatchOnce m  -> hinstall m p_sp mask int STG_SIG_RST
 339
 340       case rc of
 341         STG_SIG_DFL -> return Default
 342         STG_SIG_IGN -> return Ignore
 343         STG_SIG_ERR -> throwErrno "installHandler"
 344         STG_SIG_HAN -> do
 345                 m <- peekHandler p_sp
 346                 return (Catch m)
 347         STG_SIG_RST -> do
 348                 m <- peekHandler p_sp
 349                 return (CatchOnce m)
 350         _other ->
 351            error "internal error: System.Posix.Signals.installHandler"
 352
 353     hinstall m p_sp mask int reset = do
 354       sptr <- newStablePtr m
 355       poke p_sp sptr
 356       stg_sig_install int reset p_sp mask
 357
 358     peekHandler p_sp = do
 359       osptr <- peek p_sp
 360       deRefStablePtr osptr
 361
 362 foreign import ccall unsafe
 363   stg_sig_install
 364         :: CInt                         -- sig no.
 365         -> CInt                         -- action code (STG_SIG_HAN etc.)
 366         -> Ptr (StablePtr (IO ()))      -- (in, out) Haskell handler
 367         -> Ptr CSigset                  -- (in, out) blocked
 368         -> IO CInt                      -- (ret) action code
 369
 370 #endif /* !__PARALLEL_HASKELL__ */
 371 #endif /* __GLASGOW_HASKELL__ */
 372
 373 -- -----------------------------------------------------------------------------
 374 -- Alarms
 375
 376 -- | @scheduleAlarm i@ calls @alarm@ to schedule a real time
 377 --   alarm at least @i@ seconds in the future.
 378 scheduleAlarm :: Int -> IO Int
 379 scheduleAlarm secs = do
 380    r <- c_alarm (fromIntegral secs)
 381    return (fromIntegral r)
 382
 383 foreign import ccall unsafe "alarm"
 384   c_alarm :: CUInt -> IO CUInt
 385
 386 #ifdef __GLASGOW_HASKELL__
 387 -- -----------------------------------------------------------------------------
 388 -- The NOCLDSTOP flag
 389
 390 foreign import ccall "&nocldstop" nocldstop :: Ptr Int
 391
 392 -- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when
 393 -- installing new signal handlers.
 394 setStoppedChildFlag :: Bool -> IO Bool
 395 setStoppedChildFlag b = do
 396     rc <- peek nocldstop
 397     poke nocldstop $ fromEnum (not b)
 398     return (rc == (0::Int))
 399
 400 -- | Queries the current state of the stopped child flag.
 401 queryStoppedChildFlag :: IO Bool
 402 queryStoppedChildFlag = do
 403     rc <- peek nocldstop
 404     return (rc == (0::Int))
 405 #endif /* __GLASGOW_HASKELL__ */
 406
 407 -- -----------------------------------------------------------------------------
 408 -- Manipulating signal sets
 409
 410 newtype SignalSet = SignalSet (ForeignPtr CSigset)
 411
 412 emptySignalSet :: SignalSet
 413 emptySignalSet = unsafePerformIO $ do
 414   fp <- mallocForeignPtrBytes sizeof_sigset_t
 415   throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
 416   return (SignalSet fp)
 417
 418 fullSignalSet :: SignalSet
 419 fullSignalSet = unsafePerformIO $ do
 420   fp <- mallocForeignPtrBytes sizeof_sigset_t
 421   throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
 422   return (SignalSet fp)
 423
 424 infixr `addSignal`, `deleteSignal`
 425 addSignal :: Signal -> SignalSet -> SignalSet
 426 addSignal sig (SignalSet fp1) = unsafePerformIO $ do
 427   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 428   withForeignPtr fp1 $ \p1 ->
 429     withForeignPtr fp2 $ \p2 -> do
 430       copyBytes p2 p1 sizeof_sigset_t
 431       throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
 432   return (SignalSet fp2)
 433
 434 deleteSignal :: Signal -> SignalSet -> SignalSet
 435 deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
 436   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 437   withForeignPtr fp1 $ \p1 ->
 438     withForeignPtr fp2 $ \p2 -> do
 439       copyBytes p2 p1 sizeof_sigset_t
 440       throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
 441   return (SignalSet fp2)
 442
 443 inSignalSet :: Signal -> SignalSet -> Bool
 444 inSignalSet sig (SignalSet fp) = unsafePerformIO $
 445   withForeignPtr fp $ \p -> do
 446     r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
 447     return (r /= 0)
 448
 449 -- | @getSignalMask@ calls @sigprocmask@ to determine the
 450 --   set of interrupts which are currently being blocked.
 451 getSignalMask :: IO SignalSet
 452 getSignalMask = do
 453   fp <- mallocForeignPtrBytes sizeof_sigset_t
 454   withForeignPtr fp $ \p ->
 455     throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p)
 456   return (SignalSet fp)
 457
 458 sigProcMask :: String -> CInt -> SignalSet -> IO ()
 459 sigProcMask fn how (SignalSet set) =
 460   withForeignPtr set $ \p_set ->
 461     throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)
 462
 463 -- | @setSignalMask mask@ calls @sigprocmask@ with
 464 --   @SIG_SETMASK@ to block all interrupts in @mask@.
 465 setSignalMask :: SignalSet -> IO ()
 466 setSignalMask set = sigProcMask "setSignalMask" (CONST_SIG_SETMASK :: CInt) set
 467
 468 -- | @blockSignals mask@ calls @sigprocmask@ with
 469 --   @SIG_BLOCK@ to add all interrupts in @mask@ to the
 470 --  set of blocked interrupts.
 471 blockSignals :: SignalSet -> IO ()
 472 blockSignals set = sigProcMask "blockSignals" (CONST_SIG_BLOCK :: CInt) set
 473
 474 -- | @unblockSignals mask@ calls @sigprocmask@ with
 475 --   @SIG_UNBLOCK@ to remove all interrupts in @mask@ from the
 476 --   set of blocked interrupts.
 477 unblockSignals :: SignalSet -> IO ()
 478 unblockSignals set = sigProcMask "unblockSignals" (CONST_SIG_UNBLOCK :: CInt) set
 479
 480 -- | @getPendingSignals@ calls @sigpending@ to obtain
 481 --   the set of interrupts which have been received but are currently blocked.
 482 getPendingSignals :: IO SignalSet
 483 getPendingSignals = do
 484   fp <- mallocForeignPtrBytes sizeof_sigset_t
 485   withForeignPtr fp $ \p ->
 486    throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
 487   return (SignalSet fp)
 488
 489 #ifndef cygwin32_HOST_OS
 490
 491 -- | @awaitSignal iset@ suspends execution until an interrupt is received.
 492 -- If @iset@ is @Just s@, @awaitSignal@ calls @sigsuspend@, installing
 493 -- @s@ as the new signal mask before suspending execution; otherwise, it
 494 -- calls @pause@.  @awaitSignal@ returns on receipt of a signal.  If you
 495 -- have installed any signal handlers with @installHandler@, it may be
 496 -- wise to call @yield@ directly after @awaitSignal@ to ensure that the
 497 -- signal handler runs as promptly as possible.
 498 awaitSignal :: Maybe SignalSet -> IO ()
 499 awaitSignal maybe_sigset = do
 500   fp <- case maybe_sigset of
 501           Nothing -> do SignalSet fp <- getSignalMask; return fp
 502           Just (SignalSet fp) -> return fp
 503   withForeignPtr fp $ \p -> do
 504   c_sigsuspend p
 505   return ()
 506   -- ignore the return value; according to the docs it can only ever be
 507   -- (-1) with errno set to EINTR.
 508
 509 foreign import ccall unsafe "sigsuspend"
 510   c_sigsuspend :: Ptr CSigset -> IO CInt
 511 #endif
 512
 513 #ifdef __HUGS__
 514 foreign import ccall unsafe "sigdelset"
 515   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 516
 517 foreign import ccall unsafe "sigfillset"
 518   c_sigfillset  :: Ptr CSigset -> IO CInt
 519
 520 foreign import ccall unsafe "sigismember"
 521   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 522 #else
 523 foreign import ccall unsafe "__hscore_sigdelset"
 524   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 525
 526 foreign import ccall unsafe "__hscore_sigfillset"
 527   c_sigfillset  :: Ptr CSigset -> IO CInt
 528
 529 foreign import ccall unsafe "__hscore_sigismember"
 530   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 531 #endif /* __HUGS__ */
 532
 533 foreign import ccall unsafe "sigpending"
 534   c_sigpending :: Ptr CSigset -> IO CInt
 535
 536 #endif /* mingw32_HOST_OS */
 537