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 #if defined(__GLASGOW_HASKELL__) && defined(openbsd_TARGET_OS)
 291 foreign import ccall unsafe "genericRaise"
 292   c_raise :: CInt -> IO CInt
 293 #else
 294 foreign import ccall unsafe "raise"
 295   c_raise :: CInt -> IO CInt
 296 #endif
 297
 298 #ifdef __GLASGOW_HASKELL__
 299 data Handler = Default
 300              | Ignore
 301              -- not yet: | Hold
 302              | Catch (IO ())
 303              | CatchOnce (IO ())
 304
 305 installHandler :: Signal
 306                -> Handler
 307                -> Maybe SignalSet       -- other signals to block
 308                -> IO Handler            -- old handler
 309
 310 #ifdef __PARALLEL_HASKELL__
 311 installHandler =
 312   error "installHandler: not available for Parallel Haskell"
 313 #else
 314
 315 installHandler int handler maybe_mask = do
 316     case maybe_mask of
 317         Nothing -> install' nullPtr
 318         Just (SignalSet x) -> withForeignPtr x $ install'
 319   where
 320     install' mask =
 321       alloca $ \p_sp -> do
 322
 323       rc <- case handler of
 324               Default -> stg_sig_install int (#const STG_SIG_DFL) p_sp mask
 325               Ignore  -> stg_sig_install int (#const STG_SIG_IGN) p_sp mask
 326               Catch m -> install'' m p_sp mask int (#const STG_SIG_HAN)
 327               CatchOnce m -> install'' m p_sp mask int (#const STG_SIG_RST)
 328
 329       case rc of
 330         (#const STG_SIG_DFL) -> return Default
 331         (#const STG_SIG_IGN) -> return Ignore
 332         (#const STG_SIG_ERR) -> throwErrno "installHandler"
 333         (#const STG_SIG_HAN) -> do
 334                 m <- peekHandler p_sp
 335                 return (Catch m)
 336         (#const STG_SIG_RST) -> do
 337                 m <- peekHandler p_sp
 338                 return (CatchOnce m)
 339
 340     install'' m p_sp mask int reset = do
 341       sptr <- newStablePtr m
 342       poke p_sp sptr
 343       stg_sig_install int reset p_sp mask
 344
 345     peekHandler p_sp = do
 346       osptr <- peek p_sp
 347       deRefStablePtr osptr
 348
 349 foreign import ccall unsafe
 350   stg_sig_install :: CInt -> CInt -> Ptr (StablePtr (IO ())) -> Ptr CSigset
 351          -> IO CInt
 352
 353 #endif /* !__PARALLEL_HASKELL__ */
 354 #endif /* __GLASGOW_HASKELL__ */
 355
 356 -- -----------------------------------------------------------------------------
 357 -- Alarms
 358
 359 scheduleAlarm :: Int -> IO Int
 360 scheduleAlarm secs = do
 361    r <- c_alarm (fromIntegral secs)
 362    return (fromIntegral r)
 363
 364 foreign import ccall unsafe "alarm"
 365   c_alarm :: CUInt -> IO CUInt
 366
 367 #ifdef __GLASGOW_HASKELL__
 368 -- -----------------------------------------------------------------------------
 369 -- The NOCLDSTOP flag
 370
 371 foreign import ccall "&nocldstop" nocldstop :: Ptr Int
 372
 373 -- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when
 374 -- installing new signal handlers.
 375 setStoppedChildFlag :: Bool -> IO Bool
 376 setStoppedChildFlag b = do
 377     rc <- peek nocldstop
 378     poke nocldstop $ fromEnum (not b)
 379     return (rc == (0::Int))
 380
 381 -- | Queries the current state of the stopped child flag.
 382 queryStoppedChildFlag :: IO Bool
 383 queryStoppedChildFlag = do
 384     rc <- peek nocldstop
 385     return (rc == (0::Int))
 386 #endif /* __GLASGOW_HASKELL__ */
 387
 388 -- -----------------------------------------------------------------------------
 389 -- Manipulating signal sets
 390
 391 newtype SignalSet = SignalSet (ForeignPtr CSigset)
 392
 393 emptySignalSet :: SignalSet
 394 emptySignalSet = unsafePerformIO $ do
 395   fp <- mallocForeignPtrBytes sizeof_sigset_t
 396   throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
 397   return (SignalSet fp)
 398
 399 fullSignalSet :: SignalSet
 400 fullSignalSet = unsafePerformIO $ do
 401   fp <- mallocForeignPtrBytes sizeof_sigset_t
 402   throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
 403   return (SignalSet fp)
 404
 405 infixr `addSignal`, `deleteSignal`
 406 addSignal :: Signal -> SignalSet -> SignalSet
 407 addSignal sig (SignalSet fp1) = unsafePerformIO $ do
 408   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 409   withForeignPtr fp1 $ \p1 ->
 410     withForeignPtr fp2 $ \p2 -> do
 411       copyBytes p2 p1 sizeof_sigset_t
 412       throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
 413   return (SignalSet fp2)
 414
 415 deleteSignal :: Signal -> SignalSet -> SignalSet
 416 deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
 417   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 418   withForeignPtr fp1 $ \p1 ->
 419     withForeignPtr fp2 $ \p2 -> do
 420       copyBytes p2 p1 sizeof_sigset_t
 421       throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
 422   return (SignalSet fp2)
 423
 424 inSignalSet :: Signal -> SignalSet -> Bool
 425 inSignalSet sig (SignalSet fp) = unsafePerformIO $
 426   withForeignPtr fp $ \p -> do
 427     r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
 428     return (r /= 0)
 429
 430 getSignalMask :: IO SignalSet
 431 getSignalMask = do
 432   fp <- mallocForeignPtrBytes sizeof_sigset_t
 433   withForeignPtr fp $ \p ->
 434     throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p)
 435   return (SignalSet fp)
 436
 437 sigProcMask :: String -> CInt -> SignalSet -> IO ()
 438 sigProcMask fn how (SignalSet set) =
 439   withForeignPtr set $ \p_set ->
 440     throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)
 441
 442 setSignalMask :: SignalSet -> IO ()
 443 setSignalMask set = sigProcMask "setSignalMask" c_SIG_SETMASK set
 444
 445 blockSignals :: SignalSet -> IO ()
 446 blockSignals set = sigProcMask "blockSignals" c_SIG_BLOCK set
 447
 448 unblockSignals :: SignalSet -> IO ()
 449 unblockSignals set = sigProcMask "unblockSignals" c_SIG_UNBLOCK set
 450
 451 getPendingSignals :: IO SignalSet
 452 getPendingSignals = do
 453   fp <- mallocForeignPtrBytes sizeof_sigset_t
 454   withForeignPtr fp $ \p ->
 455    throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
 456   return (SignalSet fp)
 457
 458 #ifndef cygwin32_TARGET_OS
 459 awaitSignal :: Maybe SignalSet -> IO ()
 460 awaitSignal maybe_sigset = do
 461   fp <- case maybe_sigset of
 462           Nothing -> do SignalSet fp <- getSignalMask; return fp
 463           Just (SignalSet fp) -> return fp
 464   withForeignPtr fp $ \p -> do
 465   c_sigsuspend p
 466   return ()
 467   -- ignore the return value; according to the docs it can only ever be
 468   -- (-1) with errno set to EINTR.
 469
 470 foreign import ccall unsafe "sigsuspend"
 471   c_sigsuspend :: Ptr CSigset -> IO CInt
 472 #endif
 473
 474 #ifdef __HUGS__
 475 foreign import ccall unsafe "sigdelset"
 476   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 477
 478 foreign import ccall unsafe "sigfillset"
 479   c_sigfillset  :: Ptr CSigset -> IO CInt
 480
 481 foreign import ccall unsafe "sigismember"
 482   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 483 #else
 484 foreign import ccall unsafe "__hscore_sigdelset"
 485   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 486
 487 foreign import ccall unsafe "__hscore_sigfillset"
 488   c_sigfillset  :: Ptr CSigset -> IO CInt
 489
 490 foreign import ccall unsafe "__hscore_sigismember"
 491   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 492 #endif /* __HUGS__ */
 493
 494 foreign import ccall unsafe "sigpending"
 495   c_sigpending :: Ptr CSigset -> IO CInt
 496
 497 #ifdef __HUGS__
 498 c_SIG_BLOCK   = (#const SIG_BLOCK)   :: CInt
 499 c_SIG_SETMASK = (#const SIG_SETMASK) :: CInt
 500 c_SIG_UNBLOCK = (#const SIG_UNBLOCK) :: CInt
 501 #else
 502 foreign import ccall unsafe "__hsposix_SIG_BLOCK"   c_SIG_BLOCK   :: CInt
 503 foreign import ccall unsafe "__hsposix_SIG_SETMASK" c_SIG_SETMASK :: CInt
 504 foreign import ccall unsafe "__hsposix_SIG_UNBLOCK" c_SIG_UNBLOCK :: CInt
 505 #endif /* __HUGS__ */
 506
 507 #endif /* mingw32_TARGET_OS */
 508