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 module System.Posix.Signals (
  16   -- * The Signal type
  17   Signal,
  18
  19   -- * Specific signals
  20   nullSignal,
  21   internalAbort, sigABRT,
  22   realTimeAlarm, sigALRM,
  23   busError, sigBUS,
  24   processStatusChanged, sigCHLD,
  25   continueProcess, sigCONT,
  26   floatingPointException, sigFPE,
  27   lostConnection, sigHUP,
  28   illegalInstruction, sigILL,
  29   keyboardSignal, sigINT,
  30   killProcess, sigKILL,
  31   openEndedPipe, sigPIPE,
  32   keyboardTermination, sigQUIT,
  33   segmentationViolation, sigSEGV,
  34   softwareStop, sigSTOP,
  35   softwareTermination, sigTERM,
  36   keyboardStop, sigTSTP,
  37   backgroundRead, sigTTIN,
  38   backgroundWrite, sigTTOU,
  39   userDefinedSignal1, sigUSR1,
  40   userDefinedSignal2, sigUSR2,
  41   pollableEvent, sigPOLL,
  42   profilingTimerExpired, sigPROF,
  43   badSystemCall, sigSYS,
  44   breakpointTrap, sigTRAP,
  45   urgentDataAvailable, sigURG,
  46   virtualTimerExpired, sigVTALRM,
  47   cpuTimeLimitExceeded, sigXCPU,
  48   fileSizeLimitExceeded, sigXFSZ,
  49
  50   -- * Sending signals
  51   raiseSignal,
  52   signalProcess,
  53   signalProcessGroup,
  54
  55   -- * Handling signals
  56   Handler(..),
  57   installHandler,
  58
  59   -- * Signal sets
  60   SignalSet,
  61   emptySignalSet, fullSignalSet,
  62   addSignal, deleteSignal, inSignalSet,
  63
  64   -- * The process signal mask
  65   getSignalMask, setSignalMask, blockSignals, unblockSignals,
  66
  67   -- * The alarm timer
  68   scheduleAlarm,
  69
  70   -- * Waiting for signals
  71   getPendingSignals, awaitSignal,
  72
  73   -- MISSING FUNCTIONALITY:
  74   -- sigaction(), (inc. the sigaction structure + flags etc.)
  75   -- the siginfo structure
  76   -- sigaltstack()
  77   -- sighold, sigignore, sigpause, sigrelse, sigset
  78   -- siginterrupt
  79
  80   ) where
  81
  82 #include "Signals.h"
  83
  84 import Foreign
  85 import Foreign.C
  86 import System.IO.Unsafe
  87 import System.Posix.Types
  88 import GHC.Posix
  89
  90 -- -----------------------------------------------------------------------------
  91 -- Specific signals
  92
  93 type Signal = CInt
  94
  95 nullSignal :: Signal
  96 nullSignal = 0
  97
  98 foreign import ccall "__hsposix_SIGABRT"   sigABRT   :: CInt
  99 foreign import ccall "__hsposix_SIGALRM"   sigALRM   :: CInt
 100 foreign import ccall "__hsposix_SIGBUS"    sigBUS    :: CInt
 101 foreign import ccall "__hsposix_SIGCHLD"   sigCHLD   :: CInt
 102 foreign import ccall "__hsposix_SIGCONT"   sigCONT   :: CInt
 103 foreign import ccall "__hsposix_SIGFPE"    sigFPE    :: CInt
 104 foreign import ccall "__hsposix_SIGHUP"    sigHUP    :: CInt
 105 foreign import ccall "__hsposix_SIGILL"    sigILL    :: CInt
 106 foreign import ccall "__hsposix_SIGINT"    sigINT    :: CInt
 107 foreign import ccall "__hsposix_SIGKILL"   sigKILL   :: CInt
 108 foreign import ccall "__hsposix_SIGPIPE"   sigPIPE   :: CInt
 109 foreign import ccall "__hsposix_SIGQUIT"   sigQUIT   :: CInt
 110 foreign import ccall "__hsposix_SIGSEGV"   sigSEGV   :: CInt
 111 foreign import ccall "__hsposix_SIGSTOP"   sigSTOP   :: CInt
 112 foreign import ccall "__hsposix_SIGTERM"   sigTERM   :: CInt
 113 foreign import ccall "__hsposix_SIGTSTP"   sigTSTP   :: CInt
 114 foreign import ccall "__hsposix_SIGTTIN"   sigTTIN   :: CInt
 115 foreign import ccall "__hsposix_SIGTTOU"   sigTTOU   :: CInt
 116 foreign import ccall "__hsposix_SIGUSR1"   sigUSR1   :: CInt
 117 foreign import ccall "__hsposix_SIGUSR2"   sigUSR2   :: CInt
 118 foreign import ccall "__hsposix_SIGPOLL"   sigPOLL   :: CInt
 119 foreign import ccall "__hsposix_SIGPROF"   sigPROF   :: CInt
 120 foreign import ccall "__hsposix_SIGSYS"    sigSYS    :: CInt
 121 foreign import ccall "__hsposix_SIGTRAP"   sigTRAP   :: CInt
 122 foreign import ccall "__hsposix_SIGURG"    sigURG    :: CInt
 123 foreign import ccall "__hsposix_SIGVTALRM" sigVTALRM :: CInt
 124 foreign import ccall "__hsposix_SIGXCPU"   sigXCPU   :: CInt
 125 foreign import ccall "__hsposix_SIGXFSZ"   sigXFSZ   :: CInt
 126
 127 internalAbort ::Signal
 128 internalAbort = sigABRT
 129
 130 realTimeAlarm :: Signal
 131 realTimeAlarm = sigALRM
 132
 133 busError :: Signal
 134 busError = sigBUS
 135
 136 processStatusChanged :: Signal
 137 processStatusChanged = sigCHLD
 138
 139 #ifndef cygwin32_TARGET_OS
 140 continueProcess :: Signal
 141 continueProcess = sigCONT
 142 #endif
 143
 144 floatingPointException :: Signal
 145 floatingPointException = sigFPE
 146
 147 lostConnection :: Signal
 148 lostConnection = sigHUP
 149
 150 illegalInstruction :: Signal
 151 illegalInstruction = sigILL
 152
 153 keyboardSignal :: Signal
 154 keyboardSignal = sigINT
 155
 156 killProcess :: Signal
 157 killProcess = sigKILL
 158
 159 openEndedPipe :: Signal
 160 openEndedPipe = sigPIPE
 161
 162 keyboardTermination :: Signal
 163 keyboardTermination = sigQUIT
 164
 165 segmentationViolation :: Signal
 166 segmentationViolation = sigSEGV
 167
 168 softwareStop :: Signal
 169 softwareStop = sigSTOP
 170
 171 softwareTermination :: Signal
 172 softwareTermination = sigTERM
 173
 174 keyboardStop :: Signal
 175 keyboardStop = sigTSTP
 176
 177 backgroundRead :: Signal
 178 backgroundRead = sigTTIN
 179
 180 backgroundWrite :: Signal
 181 backgroundWrite = sigTTOU
 182
 183 userDefinedSignal1 :: Signal
 184 userDefinedSignal1 = sigUSR1
 185
 186 userDefinedSignal2 :: Signal
 187 userDefinedSignal2 = sigUSR2
 188
 189 pollableEvent :: Signal
 190 pollableEvent = sigPOLL
 191
 192 profilingTimerExpired :: Signal
 193 profilingTimerExpired = sigPROF
 194
 195 badSystemCall :: Signal
 196 badSystemCall = sigSYS
 197
 198 breakpointTrap :: Signal
 199 breakpointTrap = sigTRAP
 200
 201 urgentDataAvailable :: Signal
 202 urgentDataAvailable = sigURG
 203
 204 virtualTimerExpired :: Signal
 205 virtualTimerExpired = sigVTALRM
 206
 207 cpuTimeLimitExceeded :: Signal
 208 cpuTimeLimitExceeded = sigXCPU
 209
 210 fileSizeLimitExceeded :: Signal
 211 fileSizeLimitExceeded = sigXFSZ
 212
 213 -- -----------------------------------------------------------------------------
 214 -- Signal-related functions
 215
 216 signalProcess :: Signal -> ProcessID -> IO ()
 217 signalProcess sig pid
 218  = throwErrnoIfMinus1_ "signalProcess" (c_kill (fromIntegral pid) sig)
 219
 220 foreign import ccall unsafe "kill"
 221   c_kill :: CPid -> CInt -> IO CInt
 222
 223 signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
 224 signalProcessGroup sig pgid
 225   = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg (fromIntegral pgid) sig)
 226
 227 foreign import ccall unsafe "killpg"
 228   c_killpg :: CPid -> CInt -> IO CInt
 229
 230 raiseSignal :: Signal -> IO ()
 231 raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig)
 232
 233 foreign import ccall unsafe "raise"
 234   c_raise :: CInt -> IO CInt
 235
 236 data Handler = Default
 237              | Ignore
 238              -- not yet: | Hold
 239              | Catch (IO ())
 240
 241 installHandler :: Signal
 242                -> Handler
 243                -> Maybe SignalSet       -- other signals to block
 244                -> IO Handler            -- old handler
 245
 246 #ifdef __PARALLEL_HASKELL__
 247 installHandler =
 248   error "installHandler: not available for Parallel Haskell"
 249 #else
 250
 251 installHandler int handler maybe_mask = do
 252     case maybe_mask of
 253         Nothing -> install' nullPtr
 254         Just (SignalSet x) -> withForeignPtr x $ install'
 255   where
 256     install' mask =
 257       alloca $ \p_sp -> do
 258
 259       rc <- case handler of
 260               Default -> stg_sig_install int (#const STG_SIG_DFL) p_sp mask
 261               Ignore  -> stg_sig_install int (#const STG_SIG_IGN) p_sp mask
 262               Catch m -> do sptr <- newStablePtr m
 263                             poke p_sp sptr
 264                             stg_sig_install int (#const STG_SIG_HAN) p_sp mask
 265
 266       case rc of
 267         (#const STG_SIG_DFL) -> return Default
 268         (#const STG_SIG_IGN) -> return Ignore
 269         (#const STG_SIG_ERR) -> throwErrno "installHandler"
 270         (#const STG_SIG_HAN) -> do
 271                 osptr <- peek p_sp
 272                 m     <- deRefStablePtr osptr
 273                 return (Catch m)
 274
 275 foreign import ccall unsafe
 276   stg_sig_install :: CInt -> CInt -> Ptr (StablePtr (IO ())) -> Ptr CSigset
 277          -> IO CInt
 278
 279 #endif // !__PARALLEL_HASKELL__
 280
 281 -- -----------------------------------------------------------------------------
 282 -- Alarms
 283
 284 scheduleAlarm :: Int -> IO Int
 285 scheduleAlarm secs = do
 286    r <- c_alarm (fromIntegral secs)
 287    return (fromIntegral r)
 288
 289 foreign import ccall unsafe "alarm"
 290   c_alarm :: CUInt -> IO CUInt
 291
 292 -- -----------------------------------------------------------------------------
 293 -- Manipulating signal sets
 294
 295 newtype SignalSet = SignalSet (ForeignPtr CSigset)
 296
 297 emptySignalSet :: SignalSet
 298 emptySignalSet = unsafePerformIO $ do
 299   fp <- mallocForeignPtrBytes sizeof_sigset_t
 300   throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
 301   return (SignalSet fp)
 302
 303 fullSignalSet :: SignalSet
 304 fullSignalSet = unsafePerformIO $ do
 305   fp <- mallocForeignPtrBytes sizeof_sigset_t
 306   throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
 307   return (SignalSet fp)
 308
 309 infixr `addSignal`, `deleteSignal`
 310 addSignal :: Signal -> SignalSet -> SignalSet
 311 addSignal sig (SignalSet fp1) = unsafePerformIO $ do
 312   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 313   withForeignPtr fp1 $ \p1 ->
 314     withForeignPtr fp2 $ \p2 -> do
 315       copyBytes p2 p1 sizeof_sigset_t
 316       throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
 317   return (SignalSet fp2)
 318
 319 deleteSignal :: Signal -> SignalSet -> SignalSet
 320 deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
 321   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 322   withForeignPtr fp1 $ \p1 ->
 323     withForeignPtr fp2 $ \p2 -> do
 324       copyBytes p2 p1 sizeof_sigset_t
 325       throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
 326   return (SignalSet fp2)
 327
 328 inSignalSet :: Signal -> SignalSet -> Bool
 329 inSignalSet sig (SignalSet fp) = unsafePerformIO $
 330   withForeignPtr fp $ \p -> do
 331     r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
 332     return (r /= 0)
 333
 334 getSignalMask :: IO SignalSet
 335 getSignalMask = do
 336   fp <- mallocForeignPtrBytes sizeof_sigset_t
 337   withForeignPtr fp $ \p ->
 338     throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 p nullPtr)
 339   return (SignalSet fp)
 340
 341 sigProcMask :: String -> CInt -> SignalSet -> IO ()
 342 sigProcMask fn how (SignalSet set) =
 343   withForeignPtr set $ \p_set ->
 344     throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)
 345
 346 setSignalMask :: SignalSet -> IO ()
 347 setSignalMask set = sigProcMask "setSignalMask" c_SIG_SETMASK set
 348
 349 blockSignals :: SignalSet -> IO ()
 350 blockSignals set = sigProcMask "blockSignals" c_SIG_BLOCK set
 351
 352 unblockSignals :: SignalSet -> IO ()
 353 unblockSignals set = sigProcMask "unblockSignals" c_SIG_UNBLOCK set
 354
 355 getPendingSignals :: IO SignalSet
 356 getPendingSignals = do
 357   fp <- mallocForeignPtrBytes sizeof_sigset_t
 358   withForeignPtr fp $ \p ->
 359    throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
 360   return (SignalSet fp)
 361
 362 #ifndef cygwin32_TARGET_OS
 363 awaitSignal :: Maybe SignalSet -> IO ()
 364 awaitSignal maybe_sigset = do
 365   fp <- case maybe_sigset of
 366           Nothing -> do SignalSet fp <- getSignalMask; return fp
 367           Just (SignalSet fp) -> return fp
 368   withForeignPtr fp $ \p -> do
 369   c_sigsuspend p
 370   return ()
 371   -- ignore the return value; according to the docs it can only ever be
 372   -- (-1) with errno set to EINTR.
 373
 374 foreign import ccall unsafe "sigsuspend"
 375   c_sigsuspend :: Ptr CSigset -> IO CInt
 376 #endif
 377
 378 foreign import ccall unsafe "__hscore_sigdelset"
 379   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 380
 381 foreign import ccall unsafe "__hscore_sigfillset"
 382   c_sigfillset  :: Ptr CSigset -> IO CInt
 383
 384 foreign import ccall unsafe "__hscore_sigismember"
 385   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 386
 387 foreign import ccall unsafe "sigpending"
 388   c_sigpending :: Ptr CSigset -> IO CInt
 389
 390 foreign import ccall unsafe "__hsposix_SIG_BLOCK"   c_SIG_BLOCK   :: CInt
 391 foreign import ccall unsafe "__hsposix_SIG_SETMASK" c_SIG_SETMASK :: CInt
 392 foreign import ccall unsafe "__hsposix_SIG_UNBLOCK" c_SIG_UNBLOCK :: CInt