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