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