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,
  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 #if HAVE_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 #if HAVE_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 #if HAVE_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 x
 374     return (rc == (0::Int))
 375   where
 376     x = case b of {True -> 0; False -> 1}
 377
 378 -- | Queries the current state of the stopped child flag.
 379 queryStoppedChildFlag :: IO Bool
 380 queryStoppedChildFlag = do
 381     rc <- peek nocldstop
 382     return (rc == (0::Int))
 383 #endif /* __GLASGOW_HASKELL__ */
 384
 385 -- -----------------------------------------------------------------------------
 386 -- Manipulating signal sets
 387
 388 newtype SignalSet = SignalSet (ForeignPtr CSigset)
 389
 390 emptySignalSet :: SignalSet
 391 emptySignalSet = unsafePerformIO $ do
 392   fp <- mallocForeignPtrBytes sizeof_sigset_t
 393   throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
 394   return (SignalSet fp)
 395
 396 fullSignalSet :: SignalSet
 397 fullSignalSet = unsafePerformIO $ do
 398   fp <- mallocForeignPtrBytes sizeof_sigset_t
 399   throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
 400   return (SignalSet fp)
 401
 402 infixr `addSignal`, `deleteSignal`
 403 addSignal :: Signal -> SignalSet -> SignalSet
 404 addSignal sig (SignalSet fp1) = unsafePerformIO $ do
 405   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 406   withForeignPtr fp1 $ \p1 ->
 407     withForeignPtr fp2 $ \p2 -> do
 408       copyBytes p2 p1 sizeof_sigset_t
 409       throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
 410   return (SignalSet fp2)
 411
 412 deleteSignal :: Signal -> SignalSet -> SignalSet
 413 deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
 414   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 415   withForeignPtr fp1 $ \p1 ->
 416     withForeignPtr fp2 $ \p2 -> do
 417       copyBytes p2 p1 sizeof_sigset_t
 418       throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
 419   return (SignalSet fp2)
 420
 421 inSignalSet :: Signal -> SignalSet -> Bool
 422 inSignalSet sig (SignalSet fp) = unsafePerformIO $
 423   withForeignPtr fp $ \p -> do
 424     r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
 425     return (r /= 0)
 426
 427 getSignalMask :: IO SignalSet
 428 getSignalMask = do
 429   fp <- mallocForeignPtrBytes sizeof_sigset_t
 430   withForeignPtr fp $ \p ->
 431     throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p)
 432   return (SignalSet fp)
 433
 434 sigProcMask :: String -> CInt -> SignalSet -> IO ()
 435 sigProcMask fn how (SignalSet set) =
 436   withForeignPtr set $ \p_set ->
 437     throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)
 438
 439 setSignalMask :: SignalSet -> IO ()
 440 setSignalMask set = sigProcMask "setSignalMask" c_SIG_SETMASK set
 441
 442 blockSignals :: SignalSet -> IO ()
 443 blockSignals set = sigProcMask "blockSignals" c_SIG_BLOCK set
 444
 445 unblockSignals :: SignalSet -> IO ()
 446 unblockSignals set = sigProcMask "unblockSignals" c_SIG_UNBLOCK set
 447
 448 getPendingSignals :: IO SignalSet
 449 getPendingSignals = do
 450   fp <- mallocForeignPtrBytes sizeof_sigset_t
 451   withForeignPtr fp $ \p ->
 452    throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
 453   return (SignalSet fp)
 454
 455 #ifndef cygwin32_TARGET_OS
 456 awaitSignal :: Maybe SignalSet -> IO ()
 457 awaitSignal maybe_sigset = do
 458   fp <- case maybe_sigset of
 459           Nothing -> do SignalSet fp <- getSignalMask; return fp
 460           Just (SignalSet fp) -> return fp
 461   withForeignPtr fp $ \p -> do
 462   c_sigsuspend p
 463   return ()
 464   -- ignore the return value; according to the docs it can only ever be
 465   -- (-1) with errno set to EINTR.
 466
 467 foreign import ccall unsafe "sigsuspend"
 468   c_sigsuspend :: Ptr CSigset -> IO CInt
 469 #endif
 470
 471 #ifdef __HUGS__
 472 foreign import ccall unsafe "sigdelset"
 473   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 474
 475 foreign import ccall unsafe "sigfillset"
 476   c_sigfillset  :: Ptr CSigset -> IO CInt
 477
 478 foreign import ccall unsafe "sigismember"
 479   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 480 #else
 481 foreign import ccall unsafe "__hscore_sigdelset"
 482   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 483
 484 foreign import ccall unsafe "__hscore_sigfillset"
 485   c_sigfillset  :: Ptr CSigset -> IO CInt
 486
 487 foreign import ccall unsafe "__hscore_sigismember"
 488   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 489 #endif /* __HUGS__ */
 490
 491 foreign import ccall unsafe "sigpending"
 492   c_sigpending :: Ptr CSigset -> IO CInt
 493
 494 #ifdef __HUGS__
 495 c_SIG_BLOCK   = (#const SIG_BLOCK)   :: CInt
 496 c_SIG_SETMASK = (#const SIG_SETMASK) :: CInt
 497 c_SIG_UNBLOCK = (#const SIG_UNBLOCK) :: CInt
 498 #else
 499 foreign import ccall unsafe "__hsposix_SIG_BLOCK"   c_SIG_BLOCK   :: CInt
 500 foreign import ccall unsafe "__hsposix_SIG_SETMASK" c_SIG_SETMASK :: CInt
 501 foreign import ccall unsafe "__hsposix_SIG_UNBLOCK" c_SIG_UNBLOCK :: CInt
 502 #endif /* __HUGS__ */
 503
 504 #endif /* mingw32_TARGET_OS */
 505