System/Posix/Signals.hsc

   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 "ghcconfig.h"
  16
  17 module System.Posix.Signals (
  18 #ifndef mingw32_TARGET_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 #ifdef SIGPOLL
  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_TARGET_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 #ifdef __GLASGOW_HASKELL__
  98 #include "Signals.h"
  99 #else
 100 #include "HsBase.h"
 101 #endif
 102
 103 import Foreign
 104 import Foreign.C
 105 import System.IO.Unsafe
 106 import System.Posix.Types
 107 import System.Posix.Internals
 108
 109 #ifndef mingw32_TARGET_OS
 110 -- WHOLE FILE...
 111
 112 -- -----------------------------------------------------------------------------
 113 -- Specific signals
 114
 115 type Signal = CInt
 116
 117 nullSignal :: Signal
 118 nullSignal = 0
 119
 120 #ifdef __HUGS__
 121 sigABRT   = (#const SIGABRT)   :: CInt
 122 sigALRM   = (#const SIGALRM)   :: CInt
 123 sigBUS    = (#const SIGBUS)    :: CInt
 124 sigCHLD   = (#const SIGCHLD)   :: CInt
 125 sigCONT   = (#const SIGCONT)   :: CInt
 126 sigFPE    = (#const SIGFPE)    :: CInt
 127 sigHUP    = (#const SIGHUP)    :: CInt
 128 sigILL    = (#const SIGILL)    :: CInt
 129 sigINT    = (#const SIGINT)    :: CInt
 130 sigKILL   = (#const SIGKILL)   :: CInt
 131 sigPIPE   = (#const SIGPIPE)   :: CInt
 132 sigQUIT   = (#const SIGQUIT)   :: CInt
 133 sigSEGV   = (#const SIGSEGV)   :: CInt
 134 sigSTOP   = (#const SIGSTOP)   :: CInt
 135 sigTERM   = (#const SIGTERM)   :: CInt
 136 sigTSTP   = (#const SIGTSTP)   :: CInt
 137 sigTTIN   = (#const SIGTTIN)   :: CInt
 138 sigTTOU   = (#const SIGTTOU)   :: CInt
 139 sigUSR1   = (#const SIGUSR1)   :: CInt
 140 sigUSR2   = (#const SIGUSR2)   :: CInt
 141 #ifdef SIGPOLL
 142 sigPOLL   = (#const SIGPOLL)   :: CInt
 143 #endif
 144 sigPROF   = (#const SIGPROF)   :: CInt
 145 sigSYS    = (#const SIGSYS)    :: CInt
 146 sigTRAP   = (#const SIGTRAP)   :: CInt
 147 sigURG    = (#const SIGURG)    :: CInt
 148 sigVTALRM = (#const SIGVTALRM) :: CInt
 149 sigXCPU   = (#const SIGXCPU)   :: CInt
 150 sigXFSZ   = (#const SIGXFSZ)   :: CInt
 151 #else
 152 foreign import ccall unsafe "__hsposix_SIGABRT"   sigABRT   :: CInt
 153 foreign import ccall unsafe "__hsposix_SIGALRM"   sigALRM   :: CInt
 154 foreign import ccall unsafe "__hsposix_SIGBUS"    sigBUS    :: CInt
 155 foreign import ccall unsafe "__hsposix_SIGCHLD"   sigCHLD   :: CInt
 156 foreign import ccall unsafe "__hsposix_SIGCONT"   sigCONT   :: CInt
 157 foreign import ccall unsafe "__hsposix_SIGFPE"    sigFPE    :: CInt
 158 foreign import ccall unsafe "__hsposix_SIGHUP"    sigHUP    :: CInt
 159 foreign import ccall unsafe "__hsposix_SIGILL"    sigILL    :: CInt
 160 foreign import ccall unsafe "__hsposix_SIGINT"    sigINT    :: CInt
 161 foreign import ccall unsafe "__hsposix_SIGKILL"   sigKILL   :: CInt
 162 foreign import ccall unsafe "__hsposix_SIGPIPE"   sigPIPE   :: CInt
 163 foreign import ccall unsafe "__hsposix_SIGQUIT"   sigQUIT   :: CInt
 164 foreign import ccall unsafe "__hsposix_SIGSEGV"   sigSEGV   :: CInt
 165 foreign import ccall unsafe "__hsposix_SIGSTOP"   sigSTOP   :: CInt
 166 foreign import ccall unsafe "__hsposix_SIGTERM"   sigTERM   :: CInt
 167 foreign import ccall unsafe "__hsposix_SIGTSTP"   sigTSTP   :: CInt
 168 foreign import ccall unsafe "__hsposix_SIGTTIN"   sigTTIN   :: CInt
 169 foreign import ccall unsafe "__hsposix_SIGTTOU"   sigTTOU   :: CInt
 170 foreign import ccall unsafe "__hsposix_SIGUSR1"   sigUSR1   :: CInt
 171 foreign import ccall unsafe "__hsposix_SIGUSR2"   sigUSR2   :: CInt
 172 #ifdef SIGPOLL
 173 foreign import ccall unsafe "__hsposix_SIGPOLL"   sigPOLL   :: CInt
 174 #endif
 175 foreign import ccall unsafe "__hsposix_SIGPROF"   sigPROF   :: CInt
 176 foreign import ccall unsafe "__hsposix_SIGSYS"    sigSYS    :: CInt
 177 foreign import ccall unsafe "__hsposix_SIGTRAP"   sigTRAP   :: CInt
 178 foreign import ccall unsafe "__hsposix_SIGURG"    sigURG    :: CInt
 179 foreign import ccall unsafe "__hsposix_SIGVTALRM" sigVTALRM :: CInt
 180 foreign import ccall unsafe "__hsposix_SIGXCPU"   sigXCPU   :: CInt
 181 foreign import ccall unsafe "__hsposix_SIGXFSZ"   sigXFSZ   :: CInt
 182 #endif /* __HUGS__ */
 183
 184 internalAbort ::Signal
 185 internalAbort = sigABRT
 186
 187 realTimeAlarm :: Signal
 188 realTimeAlarm = sigALRM
 189
 190 busError :: Signal
 191 busError = sigBUS
 192
 193 processStatusChanged :: Signal
 194 processStatusChanged = sigCHLD
 195
 196 continueProcess :: Signal
 197 continueProcess = sigCONT
 198
 199 floatingPointException :: Signal
 200 floatingPointException = sigFPE
 201
 202 lostConnection :: Signal
 203 lostConnection = sigHUP
 204
 205 illegalInstruction :: Signal
 206 illegalInstruction = sigILL
 207
 208 keyboardSignal :: Signal
 209 keyboardSignal = sigINT
 210
 211 killProcess :: Signal
 212 killProcess = sigKILL
 213
 214 openEndedPipe :: Signal
 215 openEndedPipe = sigPIPE
 216
 217 keyboardTermination :: Signal
 218 keyboardTermination = sigQUIT
 219
 220 segmentationViolation :: Signal
 221 segmentationViolation = sigSEGV
 222
 223 softwareStop :: Signal
 224 softwareStop = sigSTOP
 225
 226 softwareTermination :: Signal
 227 softwareTermination = sigTERM
 228
 229 keyboardStop :: Signal
 230 keyboardStop = sigTSTP
 231
 232 backgroundRead :: Signal
 233 backgroundRead = sigTTIN
 234
 235 backgroundWrite :: Signal
 236 backgroundWrite = sigTTOU
 237
 238 userDefinedSignal1 :: Signal
 239 userDefinedSignal1 = sigUSR1
 240
 241 userDefinedSignal2 :: Signal
 242 userDefinedSignal2 = sigUSR2
 243
 244 #ifdef SIGPOLL
 245 pollableEvent :: Signal
 246 pollableEvent = sigPOLL
 247 #endif
 248
 249 profilingTimerExpired :: Signal
 250 profilingTimerExpired = sigPROF
 251
 252 badSystemCall :: Signal
 253 badSystemCall = sigSYS
 254
 255 breakpointTrap :: Signal
 256 breakpointTrap = sigTRAP
 257
 258 urgentDataAvailable :: Signal
 259 urgentDataAvailable = sigURG
 260
 261 virtualTimerExpired :: Signal
 262 virtualTimerExpired = sigVTALRM
 263
 264 cpuTimeLimitExceeded :: Signal
 265 cpuTimeLimitExceeded = sigXCPU
 266
 267 fileSizeLimitExceeded :: Signal
 268 fileSizeLimitExceeded = sigXFSZ
 269
 270 -- -----------------------------------------------------------------------------
 271 -- Signal-related functions
 272
 273 signalProcess :: Signal -> ProcessID -> IO ()
 274 signalProcess sig pid
 275  = throwErrnoIfMinus1_ "signalProcess" (c_kill (fromIntegral pid) sig)
 276
 277 foreign import ccall unsafe "kill"
 278   c_kill :: CPid -> CInt -> IO CInt
 279
 280 signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
 281 signalProcessGroup sig pgid
 282   = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg (fromIntegral pgid) sig)
 283
 284 foreign import ccall unsafe "killpg"
 285   c_killpg :: CPid -> CInt -> IO CInt
 286
 287 raiseSignal :: Signal -> IO ()
 288 raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig)
 289
 290 foreign import ccall unsafe "raise"
 291   c_raise :: CInt -> IO CInt
 292
 293 #ifdef __GLASGOW_HASKELL__
 294 data Handler = Default
 295              | Ignore
 296              -- not yet: | Hold
 297              | Catch (IO ())
 298              | CatchOnce (IO ())
 299
 300 installHandler :: Signal
 301                -> Handler
 302                -> Maybe SignalSet       -- other signals to block
 303                -> IO Handler            -- old handler
 304
 305 #ifdef __PARALLEL_HASKELL__
 306 installHandler =
 307   error "installHandler: not available for Parallel Haskell"
 308 #else
 309
 310 installHandler int handler maybe_mask = do
 311     case maybe_mask of
 312         Nothing -> install' nullPtr
 313         Just (SignalSet x) -> withForeignPtr x $ install'
 314   where
 315     install' mask =
 316       alloca $ \p_sp -> do
 317
 318       rc <- case handler of
 319               Default -> stg_sig_install int (#const STG_SIG_DFL) p_sp mask
 320               Ignore  -> stg_sig_install int (#const STG_SIG_IGN) p_sp mask
 321               Catch m -> install'' m p_sp mask int (#const STG_SIG_HAN)
 322               CatchOnce m -> install'' m p_sp mask int (#const STG_SIG_RST)
 323
 324       case rc of
 325         (#const STG_SIG_DFL) -> return Default
 326         (#const STG_SIG_IGN) -> return Ignore
 327         (#const STG_SIG_ERR) -> throwErrno "installHandler"
 328         (#const STG_SIG_HAN) -> do
 329                 m <- peekHandler p_sp
 330                 return (Catch m)
 331         (#const STG_SIG_RST) -> do
 332                 m <- peekHandler p_sp
 333                 return (CatchOnce m)
 334
 335     install'' m p_sp mask int reset = do
 336       sptr <- newStablePtr m
 337       poke p_sp sptr
 338       stg_sig_install int reset p_sp mask
 339
 340     peekHandler p_sp = do
 341       osptr <- peek p_sp
 342       deRefStablePtr osptr
 343
 344 foreign import ccall unsafe
 345   stg_sig_install :: CInt -> CInt -> Ptr (StablePtr (IO ())) -> Ptr CSigset
 346          -> IO CInt
 347
 348 #endif /* !__PARALLEL_HASKELL__ */
 349 #endif /* __GLASGOW_HASKELL__ */
 350
 351 -- -----------------------------------------------------------------------------
 352 -- Alarms
 353
 354 scheduleAlarm :: Int -> IO Int
 355 scheduleAlarm secs = do
 356    r <- c_alarm (fromIntegral secs)
 357    return (fromIntegral r)
 358
 359 foreign import ccall unsafe "alarm"
 360   c_alarm :: CUInt -> IO CUInt
 361
 362 #ifdef __GLASGOW_HASKELL__
 363 -- -----------------------------------------------------------------------------
 364 -- The NOCLDSTOP flag
 365
 366 foreign import ccall "&nocldstop" nocldstop :: Ptr Int
 367
 368 -- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when
 369 -- installing new signal handlers.
 370 setStoppedChildFlag :: Bool -> IO Bool
 371 setStoppedChildFlag b = do
 372     rc <- peek nocldstop
 373     poke nocldstop $ fromEnum (not b)
 374     return (rc == (0::Int))
 375
 376 -- | Queries the current state of the stopped child flag.
 377 queryStoppedChildFlag :: IO Bool
 378 queryStoppedChildFlag = do
 379     rc <- peek nocldstop
 380     return (rc == (0::Int))
 381 #endif /* __GLASGOW_HASKELL__ */
 382
 383 -- -----------------------------------------------------------------------------
 384 -- Manipulating signal sets
 385
 386 newtype SignalSet = SignalSet (ForeignPtr CSigset)
 387
 388 emptySignalSet :: SignalSet
 389 emptySignalSet = unsafePerformIO $ do
 390   fp <- mallocForeignPtrBytes sizeof_sigset_t
 391   throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
 392   return (SignalSet fp)
 393
 394 fullSignalSet :: SignalSet
 395 fullSignalSet = unsafePerformIO $ do
 396   fp <- mallocForeignPtrBytes sizeof_sigset_t
 397   throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
 398   return (SignalSet fp)
 399
 400 infixr `addSignal`, `deleteSignal`
 401 addSignal :: Signal -> SignalSet -> SignalSet
 402 addSignal sig (SignalSet fp1) = unsafePerformIO $ do
 403   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 404   withForeignPtr fp1 $ \p1 ->
 405     withForeignPtr fp2 $ \p2 -> do
 406       copyBytes p2 p1 sizeof_sigset_t
 407       throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
 408   return (SignalSet fp2)
 409
 410 deleteSignal :: Signal -> SignalSet -> SignalSet
 411 deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
 412   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 413   withForeignPtr fp1 $ \p1 ->
 414     withForeignPtr fp2 $ \p2 -> do
 415       copyBytes p2 p1 sizeof_sigset_t
 416       throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
 417   return (SignalSet fp2)
 418
 419 inSignalSet :: Signal -> SignalSet -> Bool
 420 inSignalSet sig (SignalSet fp) = unsafePerformIO $
 421   withForeignPtr fp $ \p -> do
 422     r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
 423     return (r /= 0)
 424
 425 getSignalMask :: IO SignalSet
 426 getSignalMask = do
 427   fp <- mallocForeignPtrBytes sizeof_sigset_t
 428   withForeignPtr fp $ \p ->
 429     throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p)
 430   return (SignalSet fp)
 431
 432 sigProcMask :: String -> CInt -> SignalSet -> IO ()
 433 sigProcMask fn how (SignalSet set) =
 434   withForeignPtr set $ \p_set ->
 435     throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)
 436
 437 setSignalMask :: SignalSet -> IO ()
 438 setSignalMask set = sigProcMask "setSignalMask" c_SIG_SETMASK set
 439
 440 blockSignals :: SignalSet -> IO ()
 441 blockSignals set = sigProcMask "blockSignals" c_SIG_BLOCK set
 442
 443 unblockSignals :: SignalSet -> IO ()
 444 unblockSignals set = sigProcMask "unblockSignals" c_SIG_UNBLOCK set
 445
 446 getPendingSignals :: IO SignalSet
 447 getPendingSignals = do
 448   fp <- mallocForeignPtrBytes sizeof_sigset_t
 449   withForeignPtr fp $ \p ->
 450    throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
 451   return (SignalSet fp)
 452
 453 #ifndef cygwin32_TARGET_OS
 454 awaitSignal :: Maybe SignalSet -> IO ()
 455 awaitSignal maybe_sigset = do
 456   fp <- case maybe_sigset of
 457           Nothing -> do SignalSet fp <- getSignalMask; return fp
 458           Just (SignalSet fp) -> return fp
 459   withForeignPtr fp $ \p -> do
 460   c_sigsuspend p
 461   return ()
 462   -- ignore the return value; according to the docs it can only ever be
 463   -- (-1) with errno set to EINTR.
 464
 465 foreign import ccall unsafe "sigsuspend"
 466   c_sigsuspend :: Ptr CSigset -> IO CInt
 467 #endif
 468
 469 #ifdef __HUGS__
 470 foreign import ccall unsafe "sigdelset"
 471   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 472
 473 foreign import ccall unsafe "sigfillset"
 474   c_sigfillset  :: Ptr CSigset -> IO CInt
 475
 476 foreign import ccall unsafe "sigismember"
 477   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 478 #else
 479 foreign import ccall unsafe "__hscore_sigdelset"
 480   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 481
 482 foreign import ccall unsafe "__hscore_sigfillset"
 483   c_sigfillset  :: Ptr CSigset -> IO CInt
 484
 485 foreign import ccall unsafe "__hscore_sigismember"
 486   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 487 #endif /* __HUGS__ */
 488
 489 foreign import ccall unsafe "sigpending"
 490   c_sigpending :: Ptr CSigset -> IO CInt
 491
 492 #ifdef __HUGS__
 493 c_SIG_BLOCK   = (#const SIG_BLOCK)   :: CInt
 494 c_SIG_SETMASK = (#const SIG_SETMASK) :: CInt
 495 c_SIG_UNBLOCK = (#const SIG_UNBLOCK) :: CInt
 496 #else
 497 foreign import ccall unsafe "__hsposix_SIG_BLOCK"   c_SIG_BLOCK   :: CInt
 498 foreign import ccall unsafe "__hsposix_SIG_SETMASK" c_SIG_SETMASK :: CInt
 499 foreign import ccall unsafe "__hsposix_SIG_UNBLOCK" c_SIG_UNBLOCK :: CInt
 500 #endif /* __HUGS__ */
 501
 502 #endif /* mingw32_TARGET_OS */
 503