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