System/Posix/Signals.hs

   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 "HsBaseConfig.h"
  16
  17 module System.Posix.Signals (
  18 #ifndef mingw32_HOST_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 CONST_SIGPOLL != -1
  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_HOST_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 import Prelude -- necessary to get dependencies right
  98
  99 #ifdef __GLASGOW_HASKELL__
 100 #include "Signals.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_HOST_OS
 110 -- WHOLE FILE...
 111
 112 -- -----------------------------------------------------------------------------
 113 -- Specific signals
 114
 115 type Signal = CInt
 116
 117 nullSignal :: Signal
 118 nullSignal = 0
 119
 120 sigABRT   = CONST_SIGABRT   :: CInt
 121 sigALRM   = CONST_SIGALRM   :: CInt
 122 sigBUS    = CONST_SIGBUS    :: CInt
 123 sigCHLD   = CONST_SIGCHLD   :: CInt
 124 sigCONT   = CONST_SIGCONT   :: CInt
 125 sigFPE    = CONST_SIGFPE    :: CInt
 126 sigHUP    = CONST_SIGHUP    :: CInt
 127 sigILL    = CONST_SIGILL    :: CInt
 128 sigINT    = CONST_SIGINT    :: CInt
 129 sigKILL   = CONST_SIGKILL   :: CInt
 130 sigPIPE   = CONST_SIGPIPE   :: CInt
 131 sigQUIT   = CONST_SIGQUIT   :: CInt
 132 sigSEGV   = CONST_SIGSEGV   :: CInt
 133 sigSTOP   = CONST_SIGSTOP   :: CInt
 134 sigTERM   = CONST_SIGTERM   :: CInt
 135 sigTSTP   = CONST_SIGTSTP   :: CInt
 136 sigTTIN   = CONST_SIGTTIN   :: CInt
 137 sigTTOU   = CONST_SIGTTOU   :: CInt
 138 sigUSR1   = CONST_SIGUSR1   :: CInt
 139 sigUSR2   = CONST_SIGUSR2   :: CInt
 140 sigPOLL   = CONST_SIGPOLL   :: CInt
 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
 149 internalAbort ::Signal
 150 internalAbort = sigABRT
 151
 152 realTimeAlarm :: Signal
 153 realTimeAlarm = sigALRM
 154
 155 busError :: Signal
 156 busError = sigBUS
 157
 158 processStatusChanged :: Signal
 159 processStatusChanged = sigCHLD
 160
 161 continueProcess :: Signal
 162 continueProcess = sigCONT
 163
 164 floatingPointException :: Signal
 165 floatingPointException = sigFPE
 166
 167 lostConnection :: Signal
 168 lostConnection = sigHUP
 169
 170 illegalInstruction :: Signal
 171 illegalInstruction = sigILL
 172
 173 keyboardSignal :: Signal
 174 keyboardSignal = sigINT
 175
 176 killProcess :: Signal
 177 killProcess = sigKILL
 178
 179 openEndedPipe :: Signal
 180 openEndedPipe = sigPIPE
 181
 182 keyboardTermination :: Signal
 183 keyboardTermination = sigQUIT
 184
 185 segmentationViolation :: Signal
 186 segmentationViolation = sigSEGV
 187
 188 softwareStop :: Signal
 189 softwareStop = sigSTOP
 190
 191 softwareTermination :: Signal
 192 softwareTermination = sigTERM
 193
 194 keyboardStop :: Signal
 195 keyboardStop = sigTSTP
 196
 197 backgroundRead :: Signal
 198 backgroundRead = sigTTIN
 199
 200 backgroundWrite :: Signal
 201 backgroundWrite = sigTTOU
 202
 203 userDefinedSignal1 :: Signal
 204 userDefinedSignal1 = sigUSR1
 205
 206 userDefinedSignal2 :: Signal
 207 userDefinedSignal2 = sigUSR2
 208
 209 #if CONST_SIGPOLL != -1
 210 pollableEvent :: Signal
 211 pollableEvent = sigPOLL
 212 #endif
 213
 214 profilingTimerExpired :: Signal
 215 profilingTimerExpired = sigPROF
 216
 217 badSystemCall :: Signal
 218 badSystemCall = sigSYS
 219
 220 breakpointTrap :: Signal
 221 breakpointTrap = sigTRAP
 222
 223 urgentDataAvailable :: Signal
 224 urgentDataAvailable = sigURG
 225
 226 virtualTimerExpired :: Signal
 227 virtualTimerExpired = sigVTALRM
 228
 229 cpuTimeLimitExceeded :: Signal
 230 cpuTimeLimitExceeded = sigXCPU
 231
 232 fileSizeLimitExceeded :: Signal
 233 fileSizeLimitExceeded = sigXFSZ
 234
 235 -- -----------------------------------------------------------------------------
 236 -- Signal-related functions
 237
 238 signalProcess :: Signal -> ProcessID -> IO ()
 239 signalProcess sig pid
 240  = throwErrnoIfMinus1_ "signalProcess" (c_kill (fromIntegral pid) sig)
 241
 242 foreign import ccall unsafe "kill"
 243   c_kill :: CPid -> CInt -> IO CInt
 244
 245 signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
 246 signalProcessGroup sig pgid
 247   = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg (fromIntegral pgid) sig)
 248
 249 foreign import ccall unsafe "killpg"
 250   c_killpg :: CPid -> CInt -> IO CInt
 251
 252 raiseSignal :: Signal -> IO ()
 253 raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig)
 254
 255 #if defined(__GLASGOW_HASKELL__) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS))
 256 foreign import ccall unsafe "genericRaise"
 257   c_raise :: CInt -> IO CInt
 258 #else
 259 foreign import ccall unsafe "raise"
 260   c_raise :: CInt -> IO CInt
 261 #endif
 262
 263 #ifdef __GLASGOW_HASKELL__
 264 data Handler = Default
 265              | Ignore
 266              -- not yet: | Hold
 267              | Catch (IO ())
 268              | CatchOnce (IO ())
 269
 270 installHandler :: Signal
 271                -> Handler
 272                -> Maybe SignalSet       -- other signals to block
 273                -> IO Handler            -- old handler
 274
 275 #ifdef __PARALLEL_HASKELL__
 276 installHandler =
 277   error "installHandler: not available for Parallel Haskell"
 278 #else
 279
 280 installHandler int handler maybe_mask = do
 281     case maybe_mask of
 282         Nothing -> install' nullPtr
 283         Just (SignalSet x) -> withForeignPtr x $ install'
 284   where
 285     install' mask =
 286       alloca $ \p_sp -> do
 287
 288       rc <- case handler of
 289               Default      -> stg_sig_install int STG_SIG_DFL p_sp mask
 290               Ignore       -> stg_sig_install int STG_SIG_IGN p_sp mask
 291               Catch m      -> hinstall m p_sp mask int STG_SIG_HAN
 292               CatchOnce m  -> hinstall m p_sp mask int STG_SIG_RST
 293
 294       case rc of
 295         STG_SIG_DFL -> return Default
 296         STG_SIG_IGN -> return Ignore
 297         STG_SIG_ERR -> throwErrno "installHandler"
 298         STG_SIG_HAN -> do
 299                 m <- peekHandler p_sp
 300                 return (Catch m)
 301         STG_SIG_RST -> do
 302                 m <- peekHandler p_sp
 303                 return (CatchOnce m)
 304         _other ->
 305            error "internal error: System.Posix.Signals.installHandler"
 306
 307     hinstall m p_sp mask int reset = do
 308       sptr <- newStablePtr m
 309       poke p_sp sptr
 310       stg_sig_install int reset p_sp mask
 311
 312     peekHandler p_sp = do
 313       osptr <- peek p_sp
 314       deRefStablePtr osptr
 315
 316 foreign import ccall unsafe
 317   stg_sig_install
 318         :: CInt                         -- sig no.
 319         -> CInt                         -- action code (STG_SIG_HAN etc.)
 320         -> Ptr (StablePtr (IO ()))      -- (in, out) Haskell handler
 321         -> Ptr CSigset                  -- (in, out) blocked
 322         -> IO CInt                      -- (ret) action code
 323
 324 #endif /* !__PARALLEL_HASKELL__ */
 325 #endif /* __GLASGOW_HASKELL__ */
 326
 327 -- -----------------------------------------------------------------------------
 328 -- Alarms
 329
 330 scheduleAlarm :: Int -> IO Int
 331 scheduleAlarm secs = do
 332    r <- c_alarm (fromIntegral secs)
 333    return (fromIntegral r)
 334
 335 foreign import ccall unsafe "alarm"
 336   c_alarm :: CUInt -> IO CUInt
 337
 338 #ifdef __GLASGOW_HASKELL__
 339 -- -----------------------------------------------------------------------------
 340 -- The NOCLDSTOP flag
 341
 342 foreign import ccall "&nocldstop" nocldstop :: Ptr Int
 343
 344 -- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when
 345 -- installing new signal handlers.
 346 setStoppedChildFlag :: Bool -> IO Bool
 347 setStoppedChildFlag b = do
 348     rc <- peek nocldstop
 349     poke nocldstop $ fromEnum (not b)
 350     return (rc == (0::Int))
 351
 352 -- | Queries the current state of the stopped child flag.
 353 queryStoppedChildFlag :: IO Bool
 354 queryStoppedChildFlag = do
 355     rc <- peek nocldstop
 356     return (rc == (0::Int))
 357 #endif /* __GLASGOW_HASKELL__ */
 358
 359 -- -----------------------------------------------------------------------------
 360 -- Manipulating signal sets
 361
 362 newtype SignalSet = SignalSet (ForeignPtr CSigset)
 363
 364 emptySignalSet :: SignalSet
 365 emptySignalSet = unsafePerformIO $ do
 366   fp <- mallocForeignPtrBytes sizeof_sigset_t
 367   throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
 368   return (SignalSet fp)
 369
 370 fullSignalSet :: SignalSet
 371 fullSignalSet = unsafePerformIO $ do
 372   fp <- mallocForeignPtrBytes sizeof_sigset_t
 373   throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
 374   return (SignalSet fp)
 375
 376 infixr `addSignal`, `deleteSignal`
 377 addSignal :: Signal -> SignalSet -> SignalSet
 378 addSignal sig (SignalSet fp1) = unsafePerformIO $ do
 379   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 380   withForeignPtr fp1 $ \p1 ->
 381     withForeignPtr fp2 $ \p2 -> do
 382       copyBytes p2 p1 sizeof_sigset_t
 383       throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
 384   return (SignalSet fp2)
 385
 386 deleteSignal :: Signal -> SignalSet -> SignalSet
 387 deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
 388   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 389   withForeignPtr fp1 $ \p1 ->
 390     withForeignPtr fp2 $ \p2 -> do
 391       copyBytes p2 p1 sizeof_sigset_t
 392       throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
 393   return (SignalSet fp2)
 394
 395 inSignalSet :: Signal -> SignalSet -> Bool
 396 inSignalSet sig (SignalSet fp) = unsafePerformIO $
 397   withForeignPtr fp $ \p -> do
 398     r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
 399     return (r /= 0)
 400
 401 getSignalMask :: IO SignalSet
 402 getSignalMask = do
 403   fp <- mallocForeignPtrBytes sizeof_sigset_t
 404   withForeignPtr fp $ \p ->
 405     throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p)
 406   return (SignalSet fp)
 407
 408 sigProcMask :: String -> CInt -> SignalSet -> IO ()
 409 sigProcMask fn how (SignalSet set) =
 410   withForeignPtr set $ \p_set ->
 411     throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)
 412
 413 setSignalMask :: SignalSet -> IO ()
 414 setSignalMask set = sigProcMask "setSignalMask" (CONST_SIG_SETMASK :: CInt) set
 415
 416 blockSignals :: SignalSet -> IO ()
 417 blockSignals set = sigProcMask "blockSignals" (CONST_SIG_BLOCK :: CInt) set
 418
 419 unblockSignals :: SignalSet -> IO ()
 420 unblockSignals set = sigProcMask "unblockSignals" (CONST_SIG_UNBLOCK :: CInt) set
 421
 422 getPendingSignals :: IO SignalSet
 423 getPendingSignals = do
 424   fp <- mallocForeignPtrBytes sizeof_sigset_t
 425   withForeignPtr fp $ \p ->
 426    throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
 427   return (SignalSet fp)
 428
 429 #ifndef cygwin32_HOST_OS
 430 awaitSignal :: Maybe SignalSet -> IO ()
 431 awaitSignal maybe_sigset = do
 432   fp <- case maybe_sigset of
 433           Nothing -> do SignalSet fp <- getSignalMask; return fp
 434           Just (SignalSet fp) -> return fp
 435   withForeignPtr fp $ \p -> do
 436   c_sigsuspend p
 437   return ()
 438   -- ignore the return value; according to the docs it can only ever be
 439   -- (-1) with errno set to EINTR.
 440
 441 foreign import ccall unsafe "sigsuspend"
 442   c_sigsuspend :: Ptr CSigset -> IO CInt
 443 #endif
 444
 445 #ifdef __HUGS__
 446 foreign import ccall unsafe "sigdelset"
 447   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 448
 449 foreign import ccall unsafe "sigfillset"
 450   c_sigfillset  :: Ptr CSigset -> IO CInt
 451
 452 foreign import ccall unsafe "sigismember"
 453   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 454 #else
 455 foreign import ccall unsafe "__hscore_sigdelset"
 456   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 457
 458 foreign import ccall unsafe "__hscore_sigfillset"
 459   c_sigfillset  :: Ptr CSigset -> IO CInt
 460
 461 foreign import ccall unsafe "__hscore_sigismember"
 462   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 463 #endif /* __HUGS__ */
 464
 465 foreign import ccall unsafe "sigpending"
 466   c_sigpending :: Ptr CSigset -> IO CInt
 467
 468 #endif /* mingw32_HOST_OS */
 469