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