2af259a0879886479209761a1e3242cd89e66061
[packages/random.git] / System / Posix / Signals.hs
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 "HsBaseConfig.h"
16
17 module System.Posix.Signals (
18 #ifndef mingw32_HOST_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 CONST_SIGPOLL != -1
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 #ifdef __GLASGOW_HASKELL__
61 -- * Handling signals
62 Handler(..),
63 installHandler,
64 #endif
65
66 -- * Signal sets
67 SignalSet,
68 emptySignalSet, fullSignalSet,
69 addSignal, deleteSignal, inSignalSet,
70
71 -- * The process signal mask
72 getSignalMask, setSignalMask, blockSignals, unblockSignals,
73
74 -- * The alarm timer
75 scheduleAlarm,
76
77 -- * Waiting for signals
78 getPendingSignals,
79 #ifndef cygwin32_HOST_OS
80 awaitSignal,
81 #endif
82
83 #ifdef __GLASGOW_HASKELL__
84 -- * The @NOCLDSTOP@ flag
85 setStoppedChildFlag, queryStoppedChildFlag,
86 #endif
87
88 -- MISSING FUNCTIONALITY:
89 -- sigaction(), (inc. the sigaction structure + flags etc.)
90 -- the siginfo structure
91 -- sigaltstack()
92 -- sighold, sigignore, sigpause, sigrelse, sigset
93 -- siginterrupt
94 #endif
95 ) where
96
97 import Prelude -- necessary to get dependencies right
98
99 import Foreign
100 import Foreign.C
101 import System.IO.Unsafe
102 import System.Posix.Types
103 import System.Posix.Internals
104
105 #ifndef mingw32_HOST_OS
106 -- WHOLE FILE...
107
108 #ifdef __GLASGOW_HASKELL__
109 #include "Signals.h"
110 import GHC.Conc ( ensureIOManagerIsRunning )
111 #endif
112
113 -- -----------------------------------------------------------------------------
114 -- Specific signals
115
116 type Signal = CInt
117
118 nullSignal :: Signal
119 nullSignal = 0
120
121 sigABRT :: CInt
122 sigABRT = CONST_SIGABRT
123 sigALRM :: CInt
124 sigALRM = CONST_SIGALRM
125 sigBUS :: CInt
126 sigBUS = CONST_SIGBUS
127 sigCHLD :: CInt
128 sigCHLD = CONST_SIGCHLD
129 sigCONT :: CInt
130 sigCONT = CONST_SIGCONT
131 sigFPE :: CInt
132 sigFPE = CONST_SIGFPE
133 sigHUP :: CInt
134 sigHUP = CONST_SIGHUP
135 sigILL :: CInt
136 sigILL = CONST_SIGILL
137 sigINT :: CInt
138 sigINT = CONST_SIGINT
139 sigKILL :: CInt
140 sigKILL = CONST_SIGKILL
141 sigPIPE :: CInt
142 sigPIPE = CONST_SIGPIPE
143 sigQUIT :: CInt
144 sigQUIT = CONST_SIGQUIT
145 sigSEGV :: CInt
146 sigSEGV = CONST_SIGSEGV
147 sigSTOP :: CInt
148 sigSTOP = CONST_SIGSTOP
149 sigTERM :: CInt
150 sigTERM = CONST_SIGTERM
151 sigTSTP :: CInt
152 sigTSTP = CONST_SIGTSTP
153 sigTTIN :: CInt
154 sigTTIN = CONST_SIGTTIN
155 sigTTOU :: CInt
156 sigTTOU = CONST_SIGTTOU
157 sigUSR1 :: CInt
158 sigUSR1 = CONST_SIGUSR1
159 sigUSR2 :: CInt
160 sigUSR2 = CONST_SIGUSR2
161 sigPOLL :: CInt
162 sigPOLL = CONST_SIGPOLL
163 sigPROF :: CInt
164 sigPROF = CONST_SIGPROF
165 sigSYS :: CInt
166 sigSYS = CONST_SIGSYS
167 sigTRAP :: CInt
168 sigTRAP = CONST_SIGTRAP
169 sigURG :: CInt
170 sigURG = CONST_SIGURG
171 sigVTALRM :: CInt
172 sigVTALRM = CONST_SIGVTALRM
173 sigXCPU :: CInt
174 sigXCPU = CONST_SIGXCPU
175 sigXFSZ :: CInt
176 sigXFSZ = CONST_SIGXFSZ
177
178 internalAbort ::Signal
179 internalAbort = sigABRT
180
181 realTimeAlarm :: Signal
182 realTimeAlarm = sigALRM
183
184 busError :: Signal
185 busError = sigBUS
186
187 processStatusChanged :: Signal
188 processStatusChanged = sigCHLD
189
190 continueProcess :: Signal
191 continueProcess = sigCONT
192
193 floatingPointException :: Signal
194 floatingPointException = sigFPE
195
196 lostConnection :: Signal
197 lostConnection = sigHUP
198
199 illegalInstruction :: Signal
200 illegalInstruction = sigILL
201
202 keyboardSignal :: Signal
203 keyboardSignal = sigINT
204
205 killProcess :: Signal
206 killProcess = sigKILL
207
208 openEndedPipe :: Signal
209 openEndedPipe = sigPIPE
210
211 keyboardTermination :: Signal
212 keyboardTermination = sigQUIT
213
214 segmentationViolation :: Signal
215 segmentationViolation = sigSEGV
216
217 softwareStop :: Signal
218 softwareStop = sigSTOP
219
220 softwareTermination :: Signal
221 softwareTermination = sigTERM
222
223 keyboardStop :: Signal
224 keyboardStop = sigTSTP
225
226 backgroundRead :: Signal
227 backgroundRead = sigTTIN
228
229 backgroundWrite :: Signal
230 backgroundWrite = sigTTOU
231
232 userDefinedSignal1 :: Signal
233 userDefinedSignal1 = sigUSR1
234
235 userDefinedSignal2 :: Signal
236 userDefinedSignal2 = sigUSR2
237
238 #if CONST_SIGPOLL != -1
239 pollableEvent :: Signal
240 pollableEvent = sigPOLL
241 #endif
242
243 profilingTimerExpired :: Signal
244 profilingTimerExpired = sigPROF
245
246 badSystemCall :: Signal
247 badSystemCall = sigSYS
248
249 breakpointTrap :: Signal
250 breakpointTrap = sigTRAP
251
252 urgentDataAvailable :: Signal
253 urgentDataAvailable = sigURG
254
255 virtualTimerExpired :: Signal
256 virtualTimerExpired = sigVTALRM
257
258 cpuTimeLimitExceeded :: Signal
259 cpuTimeLimitExceeded = sigXCPU
260
261 fileSizeLimitExceeded :: Signal
262 fileSizeLimitExceeded = sigXFSZ
263
264 -- -----------------------------------------------------------------------------
265 -- Signal-related functions
266
267 -- | @signalProcess int pid@ calls @kill@ to signal process @pid@
268 -- with interrupt signal @int@.
269 signalProcess :: Signal -> ProcessID -> IO ()
270 signalProcess sig pid
271 = throwErrnoIfMinus1_ "signalProcess" (c_kill (fromIntegral pid) sig)
272
273 foreign import ccall unsafe "kill"
274 c_kill :: CPid -> CInt -> IO CInt
275
276
277 -- | @signalProcessGroup int pgid@ calls @kill@ to signal
278 -- all processes in group @pgid@ with interrupt signal @int@.
279 signalProcessGroup :: Signal -> ProcessGroupID -> IO ()
280 signalProcessGroup sig pgid
281 = throwErrnoIfMinus1_ "signalProcessGroup" (c_killpg (fromIntegral pgid) sig)
282
283 foreign import ccall unsafe "killpg"
284 c_killpg :: CPid -> CInt -> IO CInt
285
286 -- | @raiseSignal int@ calls @kill@ to signal the current process
287 -- with interrupt signal @int@.
288 raiseSignal :: Signal -> IO ()
289 raiseSignal sig = throwErrnoIfMinus1_ "raiseSignal" (c_raise sig)
290
291 #if defined(__GLASGOW_HASKELL__) && (defined(openbsd_HOST_OS) || defined(freebsd_HOST_OS))
292 foreign import ccall unsafe "genericRaise"
293 c_raise :: CInt -> IO CInt
294 #else
295 foreign import ccall unsafe "raise"
296 c_raise :: CInt -> IO CInt
297 #endif
298
299 #ifdef __GLASGOW_HASKELL__
300 data Handler = Default
301 | Ignore
302 -- not yet: | Hold
303 | Catch (IO ())
304 | CatchOnce (IO ())
305
306 -- | @installHandler int handler iset@ calls @sigaction@ to install an
307 -- interrupt handler for signal @int@. If @handler@ is @Default@,
308 -- @SIG_DFL@ is installed; if @handler@ is @Ignore@, @SIG_IGN@ is
309 -- installed; if @handler@ is @Catch action@, a handler is installed
310 -- which will invoke @action@ in a new thread when (or shortly after) the
311 -- signal is received.
312 -- If @iset@ is @Just s@, then the @sa_mask@ of the @sigaction@ structure
313 -- is set to @s@; otherwise it is cleared. The previously installed
314 -- signal handler for @int@ is returned
315 installHandler :: Signal
316 -> Handler
317 -> Maybe SignalSet -- ^ other signals to block
318 -> IO Handler -- ^ old handler
319
320 #ifdef __PARALLEL_HASKELL__
321 installHandler =
322 error "installHandler: not available for Parallel Haskell"
323 #else
324
325 installHandler int handler maybe_mask = do
326 ensureIOManagerIsRunning -- for the threaded RTS
327 case maybe_mask of
328 Nothing -> install' nullPtr
329 Just (SignalSet x) -> withForeignPtr x $ install'
330 where
331 install' mask =
332 alloca $ \p_sp -> do
333
334 rc <- case handler of
335 Default -> stg_sig_install int STG_SIG_DFL p_sp mask
336 Ignore -> stg_sig_install int STG_SIG_IGN p_sp mask
337 Catch m -> hinstall m p_sp mask int STG_SIG_HAN
338 CatchOnce m -> hinstall m p_sp mask int STG_SIG_RST
339
340 case rc of
341 STG_SIG_DFL -> return Default
342 STG_SIG_IGN -> return Ignore
343 STG_SIG_ERR -> throwErrno "installHandler"
344 STG_SIG_HAN -> do
345 m <- peekHandler p_sp
346 return (Catch m)
347 STG_SIG_RST -> do
348 m <- peekHandler p_sp
349 return (CatchOnce m)
350 _other ->
351 error "internal error: System.Posix.Signals.installHandler"
352
353 hinstall m p_sp mask int reset = do
354 sptr <- newStablePtr m
355 poke p_sp sptr
356 stg_sig_install int reset p_sp mask
357
358 peekHandler p_sp = do
359 osptr <- peek p_sp
360 deRefStablePtr osptr
361
362 foreign import ccall unsafe
363 stg_sig_install
364 :: CInt -- sig no.
365 -> CInt -- action code (STG_SIG_HAN etc.)
366 -> Ptr (StablePtr (IO ())) -- (in, out) Haskell handler
367 -> Ptr CSigset -- (in, out) blocked
368 -> IO CInt -- (ret) action code
369
370 #endif /* !__PARALLEL_HASKELL__ */
371 #endif /* __GLASGOW_HASKELL__ */
372
373 -- -----------------------------------------------------------------------------
374 -- Alarms
375
376 -- | @scheduleAlarm i@ calls @alarm@ to schedule a real time
377 -- alarm at least @i@ seconds in the future.
378 scheduleAlarm :: Int -> IO Int
379 scheduleAlarm secs = do
380 r <- c_alarm (fromIntegral secs)
381 return (fromIntegral r)
382
383 foreign import ccall unsafe "alarm"
384 c_alarm :: CUInt -> IO CUInt
385
386 #ifdef __GLASGOW_HASKELL__
387 -- -----------------------------------------------------------------------------
388 -- The NOCLDSTOP flag
389
390 foreign import ccall "&nocldstop" nocldstop :: Ptr Int
391
392 -- | Tells the system whether or not to set the @SA_NOCLDSTOP@ flag when
393 -- installing new signal handlers.
394 setStoppedChildFlag :: Bool -> IO Bool
395 setStoppedChildFlag b = do
396 rc <- peek nocldstop
397 poke nocldstop $ fromEnum (not b)
398 return (rc == (0::Int))
399
400 -- | Queries the current state of the stopped child flag.
401 queryStoppedChildFlag :: IO Bool
402 queryStoppedChildFlag = do
403 rc <- peek nocldstop
404 return (rc == (0::Int))
405 #endif /* __GLASGOW_HASKELL__ */
406
407 -- -----------------------------------------------------------------------------
408 -- Manipulating signal sets
409
410 newtype SignalSet = SignalSet (ForeignPtr CSigset)
411
412 emptySignalSet :: SignalSet
413 emptySignalSet = unsafePerformIO $ do
414 fp <- mallocForeignPtrBytes sizeof_sigset_t
415 throwErrnoIfMinus1_ "emptySignalSet" (withForeignPtr fp $ c_sigemptyset)
416 return (SignalSet fp)
417
418 fullSignalSet :: SignalSet
419 fullSignalSet = unsafePerformIO $ do
420 fp <- mallocForeignPtrBytes sizeof_sigset_t
421 throwErrnoIfMinus1_ "fullSignalSet" (withForeignPtr fp $ c_sigfillset)
422 return (SignalSet fp)
423
424 infixr `addSignal`, `deleteSignal`
425 addSignal :: Signal -> SignalSet -> SignalSet
426 addSignal sig (SignalSet fp1) = unsafePerformIO $ do
427 fp2 <- mallocForeignPtrBytes sizeof_sigset_t
428 withForeignPtr fp1 $ \p1 ->
429 withForeignPtr fp2 $ \p2 -> do
430 copyBytes p2 p1 sizeof_sigset_t
431 throwErrnoIfMinus1_ "addSignal" (c_sigaddset p2 sig)
432 return (SignalSet fp2)
433
434 deleteSignal :: Signal -> SignalSet -> SignalSet
435 deleteSignal sig (SignalSet fp1) = unsafePerformIO $ do
436 fp2 <- mallocForeignPtrBytes sizeof_sigset_t
437 withForeignPtr fp1 $ \p1 ->
438 withForeignPtr fp2 $ \p2 -> do
439 copyBytes p2 p1 sizeof_sigset_t
440 throwErrnoIfMinus1_ "deleteSignal" (c_sigdelset p2 sig)
441 return (SignalSet fp2)
442
443 inSignalSet :: Signal -> SignalSet -> Bool
444 inSignalSet sig (SignalSet fp) = unsafePerformIO $
445 withForeignPtr fp $ \p -> do
446 r <- throwErrnoIfMinus1 "inSignalSet" (c_sigismember p sig)
447 return (r /= 0)
448
449 -- | @getSignalMask@ calls @sigprocmask@ to determine the
450 -- set of interrupts which are currently being blocked.
451 getSignalMask :: IO SignalSet
452 getSignalMask = do
453 fp <- mallocForeignPtrBytes sizeof_sigset_t
454 withForeignPtr fp $ \p ->
455 throwErrnoIfMinus1_ "getSignalMask" (c_sigprocmask 0 nullPtr p)
456 return (SignalSet fp)
457
458 sigProcMask :: String -> CInt -> SignalSet -> IO ()
459 sigProcMask fn how (SignalSet set) =
460 withForeignPtr set $ \p_set ->
461 throwErrnoIfMinus1_ fn (c_sigprocmask how p_set nullPtr)
462
463 -- | @setSignalMask mask@ calls @sigprocmask@ with
464 -- @SIG_SETMASK@ to block all interrupts in @mask@.
465 setSignalMask :: SignalSet -> IO ()
466 setSignalMask set = sigProcMask "setSignalMask" (CONST_SIG_SETMASK :: CInt) set
467
468 -- | @blockSignals mask@ calls @sigprocmask@ with
469 -- @SIG_BLOCK@ to add all interrupts in @mask@ to the
470 -- set of blocked interrupts.
471 blockSignals :: SignalSet -> IO ()
472 blockSignals set = sigProcMask "blockSignals" (CONST_SIG_BLOCK :: CInt) set
473
474 -- | @unblockSignals mask@ calls @sigprocmask@ with
475 -- @SIG_UNBLOCK@ to remove all interrupts in @mask@ from the
476 -- set of blocked interrupts.
477 unblockSignals :: SignalSet -> IO ()
478 unblockSignals set = sigProcMask "unblockSignals" (CONST_SIG_UNBLOCK :: CInt) set
479
480 -- | @getPendingSignals@ calls @sigpending@ to obtain
481 -- the set of interrupts which have been received but are currently blocked.
482 getPendingSignals :: IO SignalSet
483 getPendingSignals = do
484 fp <- mallocForeignPtrBytes sizeof_sigset_t
485 withForeignPtr fp $ \p ->
486 throwErrnoIfMinus1_ "getPendingSignals" (c_sigpending p)
487 return (SignalSet fp)
488
489 #ifndef cygwin32_HOST_OS
490
491 -- | @awaitSignal iset@ suspends execution until an interrupt is received.
492 -- If @iset@ is @Just s@, @awaitSignal@ calls @sigsuspend@, installing
493 -- @s@ as the new signal mask before suspending execution; otherwise, it
494 -- calls @pause@. @awaitSignal@ returns on receipt of a signal. If you
495 -- have installed any signal handlers with @installHandler@, it may be
496 -- wise to call @yield@ directly after @awaitSignal@ to ensure that the
497 -- signal handler runs as promptly as possible.
498 awaitSignal :: Maybe SignalSet -> IO ()
499 awaitSignal maybe_sigset = do
500 fp <- case maybe_sigset of
501 Nothing -> do SignalSet fp <- getSignalMask; return fp
502 Just (SignalSet fp) -> return fp
503 withForeignPtr fp $ \p -> do
504 c_sigsuspend p
505 return ()
506 -- ignore the return value; according to the docs it can only ever be
507 -- (-1) with errno set to EINTR.
508
509 foreign import ccall unsafe "sigsuspend"
510 c_sigsuspend :: Ptr CSigset -> IO CInt
511 #endif
512
513 #ifdef __HUGS__
514 foreign import ccall unsafe "sigdelset"
515 c_sigdelset :: Ptr CSigset -> CInt -> IO CInt
516
517 foreign import ccall unsafe "sigfillset"
518 c_sigfillset :: Ptr CSigset -> IO CInt
519
520 foreign import ccall unsafe "sigismember"
521 c_sigismember :: Ptr CSigset -> CInt -> IO CInt
522 #else
523 foreign import ccall unsafe "__hscore_sigdelset"
524 c_sigdelset :: Ptr CSigset -> CInt -> IO CInt
525
526 foreign import ccall unsafe "__hscore_sigfillset"
527 c_sigfillset :: Ptr CSigset -> IO CInt
528
529 foreign import ccall unsafe "__hscore_sigismember"
530 c_sigismember :: Ptr CSigset -> CInt -> IO CInt
531 #endif /* __HUGS__ */
532
533 foreign import ccall unsafe "sigpending"
534 c_sigpending :: Ptr CSigset -> IO CInt
535
536 #endif /* mingw32_HOST_OS */
537