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