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