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