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              | CatchOnce (IO ())
 253
 254 installHandler :: Signal
 255                -> Handler
 256                -> Maybe SignalSet       -- other signals to block
 257                -> IO Handler            -- old handler
 258
 259 #ifdef __PARALLEL_HASKELL__
 260 installHandler =
 261   error "installHandler: not available for Parallel Haskell"
 262 #else
 263
 264 installHandler int handler maybe_mask = do
 265     case maybe_mask of
 266         Nothing -> install' nullPtr
 267         Just (SignalSet x) -> withForeignPtr x $ install'
 268   where
 269     install' mask =
 270       alloca $ \p_sp -> do
 271
 272       rc <- case handler of
 273               Default -> stg_sig_install int (#const STG_SIG_DFL) p_sp mask
 274               Ignore  -> stg_sig_install int (#const STG_SIG_IGN) p_sp mask
 275               Catch m -> install'' m p_sp mask int (#const STG_SIG_HAN)
 276               CatchOnce m -> install'' m p_sp mask int (#const STG_SIG_RST)
 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                 m <- peekHandler p_sp
 284                 return (Catch m)
 285         (#const STG_SIG_RST) -> do
 286                 m <- peekHandler p_sp
 287                 return (CatchOnce m)
 288
 289     install'' m p_sp mask int reset = do
 290       sptr <- newStablePtr m
 291       poke p_sp sptr
 292       stg_sig_install int reset p_sp mask
 293
 294     peekHandler p_sp = do
 295       osptr <- peek p_sp
 296       deRefStablePtr osptr
 297
 298 foreign import ccall unsafe
 299   stg_sig_install :: CInt -> CInt -> Ptr (StablePtr (IO ())) -> Ptr CSigset
 300          -> IO CInt
 301
 302 #endif // !__PARALLEL_HASKELL__
 303
 304 -- -----------------------------------------------------------------------------
 305 -- Alarms
 306
 307 scheduleAlarm :: Int -> IO Int
 308 scheduleAlarm secs = do
 309    r <- c_alarm (fromIntegral secs)
 310    return (fromIntegral r)
 311
 312 foreign import ccall unsafe "alarm"
 313   c_alarm :: CUInt -> IO CUInt
 314
 315 -- -----------------------------------------------------------------------------
 316 -- Manipulating signal sets
 317
 318 newtype SignalSet = SignalSet (ForeignPtr CSigset)
 319
 320 emptySignalSet :: SignalSet
 321 emptySignalSet = unsafePerformIO $ do
 322   fp <- mallocForeignPtrBytes sizeof_sigset_t
 323   throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
 324   return (SignalSet fp)
 325
 326 fullSignalSet :: SignalSet
 327 fullSignalSet = unsafePerformIO $ do
 328   fp <- mallocForeignPtrBytes sizeof_sigset_t
 329   throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
 330   return (SignalSet fp)
 331
 332 infixr `addSignal`, `deleteSignal`
 333 addSignal :: Signal -> SignalSet -> SignalSet
 334 addSignal sig (SignalSet fp1) = unsafePerformIO $ do
 335   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 336   withForeignPtr fp1 $ \p1 ->
 337     withForeignPtr fp2 $ \p2 -> do
 338       copyBytes p2 p1 sizeof_sigset_t
 339       throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
 340   return (SignalSet fp2)
 341
 342 deleteSignal :: Signal -> SignalSet -> SignalSet
 343 deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
 344   fp2 <- mallocForeignPtrBytes sizeof_sigset_t
 345   withForeignPtr fp1 $ \p1 ->
 346     withForeignPtr fp2 $ \p2 -> do
 347       copyBytes p2 p1 sizeof_sigset_t
 348       throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
 349   return (SignalSet fp2)
 350
 351 inSignalSet :: Signal -> SignalSet -> Bool
 352 inSignalSet sig (SignalSet fp) = unsafePerformIO $
 353   withForeignPtr fp $ \p -> do
 354     r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
 355     return (r /= 0)
 356
 357 getSignalMask :: IO SignalSet
 358 getSignalMask = do
 359   fp <- mallocForeignPtrBytes sizeof_sigset_t
 360   withForeignPtr fp $ \p ->
 361     throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 p nullPtr)
 362   return (SignalSet fp)
 363
 364 sigProcMask :: String -> CInt -> SignalSet -> IO ()
 365 sigProcMask fn how (SignalSet set) =
 366   withForeignPtr set $ \p_set ->
 367     throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)
 368
 369 setSignalMask :: SignalSet -> IO ()
 370 setSignalMask set = sigProcMask "setSignalMask" c_SIG_SETMASK set
 371
 372 blockSignals :: SignalSet -> IO ()
 373 blockSignals set = sigProcMask "blockSignals" c_SIG_BLOCK set
 374
 375 unblockSignals :: SignalSet -> IO ()
 376 unblockSignals set = sigProcMask "unblockSignals" c_SIG_UNBLOCK set
 377
 378 getPendingSignals :: IO SignalSet
 379 getPendingSignals = do
 380   fp <- mallocForeignPtrBytes sizeof_sigset_t
 381   withForeignPtr fp $ \p ->
 382    throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
 383   return (SignalSet fp)
 384
 385 #ifndef cygwin32_TARGET_OS
 386 awaitSignal :: Maybe SignalSet -> IO ()
 387 awaitSignal maybe_sigset = do
 388   fp <- case maybe_sigset of
 389           Nothing -> do SignalSet fp <- getSignalMask; return fp
 390           Just (SignalSet fp) -> return fp
 391   withForeignPtr fp $ \p -> do
 392   c_sigsuspend p
 393   return ()
 394   -- ignore the return value; according to the docs it can only ever be
 395   -- (-1) with errno set to EINTR.
 396
 397 foreign import ccall unsafe "sigsuspend"
 398   c_sigsuspend :: Ptr CSigset -> IO CInt
 399 #endif
 400
 401 foreign import ccall unsafe "__hscore_sigdelset"
 402   c_sigdelset   :: Ptr CSigset -> CInt -> IO CInt
 403
 404 foreign import ccall unsafe "__hscore_sigfillset"
 405   c_sigfillset  :: Ptr CSigset -> IO CInt
 406
 407 foreign import ccall unsafe "__hscore_sigismember"
 408   c_sigismember :: Ptr CSigset -> CInt -> IO CInt
 409
 410 foreign import ccall unsafe "sigpending"
 411   c_sigpending :: Ptr CSigset -> IO CInt
 412
 413 foreign import ccall unsafe "__hsposix_SIG_BLOCK"   c_SIG_BLOCK   :: CInt
 414 foreign import ccall unsafe "__hsposix_SIG_SETMASK" c_SIG_SETMASK :: CInt
 415 foreign import ccall unsafe "__hsposix_SIG_UNBLOCK" c_SIG_UNBLOCK :: CInt
 416
 417 #endif /* mingw32_TARGET_OS */
 418