8bf189d3ba57a9511f1ff8d0cb6a063267527542
[sbcl.git] / src / code / signal.lisp
1 ;;;; handling UNIX signals
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!UNIX")
13
14 (file-comment
15   "$Header$")
16 \f
17 ;;;; macros for dynamically enabling and disabling signal handling
18
19 ;;; Notes on how the without-interrupts/with-interrupts stuff works:
20 ;;;
21 ;;; Before invoking the supplied handler for any of the signals that
22 ;;; can be blocked, the C interrupt support code checks to see whether
23 ;;; *interrupts-enabled* has been bound to NIL. If so, it saves the
24 ;;; signal number and the value of the signal mask (from the signal
25 ;;; context), sets the signal mask to block all blockable signals,
26 ;;; sets *interrupt-pending* and returns without handling the signal.
27 ;;;
28 ;;; When we drop out the without interrupts, we check to see whether
29 ;;; *interrupt-pending* has been set. If so, we call
30 ;;; do-pending-interrupt, which generates a SIGTRAP. The C code
31 ;;; invokes the handler for the saved signal instead of the SIGTRAP
32 ;;; after replacing the signal mask in the signal context with the
33 ;;; saved value. When that hander returns, the original signal mask is
34 ;;; installed, allowing any other pending signals to be handled.
35 ;;;
36 ;;; This means that the cost of without-interrupts is just a special
37 ;;; binding in the case when no signals are delivered (the normal
38 ;;; case). It's only when a signal is actually delivered that we use
39 ;;; any system calls, and by then the cost of the extra system calls
40 ;;; are lost in the noise when compared with the cost of delivering
41 ;;; the signal in the first place.
42
43 ;;; Magically converted by the compiler into a break instruction.
44 (defun do-pending-interrupt ()
45   (do-pending-interrupt))
46
47 #!-gengc (progn
48
49 (defvar *interrupts-enabled* t)
50 (defvar *interrupt-pending* nil)
51
52 (sb!xc:defmacro without-interrupts (&body body)
53   #!+sb-doc
54   "Execute BODY in a context impervious to interrupts."
55   (let ((name (gensym)))
56     `(flet ((,name () ,@body))
57        (if *interrupts-enabled*
58            (unwind-protect
59                (let ((*interrupts-enabled* nil))
60                  (,name))
61              ;; FIXME: Does it matter that an interrupt coming in here
62              ;; could be executed before any of the pending interrupts?
63              ;; Or do incoming interrupts have the good grace to check
64              ;; whether interrupts are pending before executing themselves
65              ;; immediately?
66              (when *interrupt-pending*
67                (do-pending-interrupt)))
68            (,name)))))
69
70 (sb!xc:defmacro with-interrupts (&body body)
71   #!+sb-doc
72   "Allow interrupts while executing BODY. As interrupts are normally allowed,
73   this is only useful inside a WITHOUT-INTERRUPTS."
74   (let ((name (gensym)))
75     `(flet ((,name () ,@body))
76        (if *interrupts-enabled*
77            (,name)
78            (let ((*interrupts-enabled* t))
79              (when *interrupt-pending*
80                (do-pending-interrupt))
81              (,name))))))
82
83 ) ; PROGN
84
85 ;;; On the GENGC system, we have to do it slightly differently because of the
86 ;;; existence of threads. Each thread has a suspends_disabled_count in its
87 ;;; mutator structure. When this value is other then zero, the low level stuff
88 ;;; will not suspend the thread, but will instead set the suspend_pending flag
89 ;;; (also in the mutator). So when we finish the without-interrupts, we just
90 ;;; check the suspend_pending flag and trigger a do-pending-interrupt if
91 ;;; necessary.
92
93 #!+gengc
94 (defmacro without-interrupts (&body body)
95   `(unwind-protect
96        (progn
97          (locally
98            (declare (optimize (speed 3) (safety 0)))
99            (incf (sb!kernel:mutator-interrupts-disabled-count)))
100          ,@body)
101      (locally
102        (declare (optimize (speed 3) (safety 0)))
103        (when (and (zerop (decf (sb!kernel:mutator-interrupts-disabled-count)))
104                   (not (zerop (sb!kernel:mutator-interrupt-pending))))
105          (do-pending-interrupt)))))
106 \f
107 ;;;; utilities for dealing with signal names and numbers
108
109 (defstruct (unix-signal
110             (:constructor make-unix-signal (%name %number %description)))
111   %name                             ; signal keyword
112   (%number nil :type integer)       ; UNIX signal number
113   (%description nil :type string))  ; documentation
114
115 (defvar *unix-signals* nil
116   #!+sb-doc
117   "A list of Unix signal structures.")
118
119 (defmacro def-unix-signal (name number description)
120   (let ((symbol (intern (symbol-name name))))
121     `(progn
122        ;; KLUDGE: This PUSH should be probably be something like PUSHNEW if we
123        ;; want to be able to cleanly reload this file. (Or perhaps
124        ;; *UNIX-SIGNALS* should be a hash table keyed by signal name, or a
125        ;; vector keyed by signal number?)
126        (push (make-unix-signal ,name ,number ,description) *unix-signals*)
127        ;; This is to make the new signal lookup stuff compatible with
128        ;; old code which expects the symbol with the same print name as
129        ;; our keywords to be a constant with a value equal to the signal
130        ;; number.
131        (defconstant ,symbol ,number ,description)
132        (let ((sb!int::*rogue-export* "DEF-MATH-RTN"))
133          (export ',symbol)))))
134
135 (defun unix-signal-or-lose (arg)
136   (let ((signal (find arg *unix-signals*
137                       :key (etypecase arg
138                              (symbol #'unix-signal-%name)
139                              (number #'unix-signal-%number)))))
140     (unless signal
141       (error "~S is not a valid signal name or number." arg))
142     signal))
143
144 (defun unix-signal-name (signal)
145   #!+sb-doc
146   "Return the name of the signal as a string. Signal should be a valid
147   signal number or a keyword of the standard UNIX signal name."
148   (symbol-name (unix-signal-%name (unix-signal-or-lose signal))))
149
150 (defun unix-signal-description (signal)
151   #!+sb-doc
152   "Return a string describing signal. Signal should be a valid signal
153   number or a keyword of the standard UNIX signal name."
154   (unix-signal-%description (unix-signal-or-lose signal)))
155
156 (defun unix-signal-number (signal)
157   #!+sb-doc
158   "Return the number of the given signal. Signal should be a valid
159   signal number or a keyword of the standard UNIX signal name."
160   (unix-signal-%number (unix-signal-or-lose signal)))
161
162 ;;; Known signals
163 (def-unix-signal :CHECK 0 "Check")
164
165 (def-unix-signal :SIGHUP 1 "Hangup")
166 (def-unix-signal :SIGINT 2 "Interrupt")
167 (def-unix-signal :SIGQUIT 3 "Quit")
168 (def-unix-signal :SIGILL 4 "Illegal instruction")
169 (def-unix-signal :SIGTRAP 5 "Trace trap")
170 (def-unix-signal :SIGIOT 6 "Iot instruction")
171 #!-linux
172 (def-unix-signal :SIGEMT 7 "Emt instruction")
173 (def-unix-signal :SIGFPE 8 "Floating point exception")
174 (def-unix-signal :SIGKILL 9 "Kill")
175 (def-unix-signal :SIGBUS #!-linux 10 #!+linux 7 "Bus error")
176 (def-unix-signal :SIGSEGV 11 "Segmentation violation")
177 #!-linux
178 (def-unix-signal :SIGSYS 12 "Bad argument to system call")
179 (def-unix-signal :SIGPIPE 13 "Write on a pipe with no one to read it")
180 (def-unix-signal :SIGALRM 14 "Alarm clock")
181 (def-unix-signal :SIGTERM 15 "Software termination signal")
182 #!+linux
183 (def-unix-signal :SIGSTKFLT 16 "Stack fault on coprocessor")
184 (def-unix-signal :SIGURG #!+svr4 21 #!-(or hpux svr4 linux) 16 #!+hpux 29
185   #!+linux 23 "Urgent condition present on socket")
186 (def-unix-signal :SIGSTOP #!-(or hpux svr4 linux) 17 #!+hpux 24 #!+svr4 23
187   #!+linux 19 "Stop")
188 (def-unix-signal :SIGTSTP #!-(or hpux svr4 linux) 18 #!+hpux 25 #!+svr4 24
189   #!+linux 20 "Stop signal generated from keyboard")
190 (def-unix-signal :SIGCONT #!-(or hpux svr4 linux) 19 #!+hpux 26 #!+svr4 25
191   #!+linux 18 "Continue after stop")
192 (def-unix-signal :SIGCHLD #!-(or linux hpux) 20
193   #!+hpux 18 #!+linux 17 "Child status has changed")
194 (def-unix-signal :SIGTTIN #!-(or hpux svr4) 21 #!+hpux 27 #!+svr4 26
195   "Background read attempted from control terminal")
196 (def-unix-signal :SIGTTOU #!-(or hpux svr4) 22 #!+hpux 28 #!+svr4 27
197   "Background write attempted to control terminal")
198 (def-unix-signal :SIGIO #!-(or hpux irix linux) 23 #!+(or hpux irix) 22
199   #!+linux 29
200   "I/O is possible on a descriptor")
201 #!-hpux
202 (def-unix-signal :SIGXCPU #!-svr4 24 #!+svr4 30  "Cpu time limit exceeded")
203 #!-hpux
204 (def-unix-signal :SIGXFSZ #!-svr4 25 #!+svr4 31 "File size limit exceeded")
205 (def-unix-signal :SIGVTALRM #!-(or hpux svr4) 26 #!+hpux 20 #!+svr4 28
206     "Virtual time alarm")
207 (def-unix-signal :SIGPROF #!-(or hpux svr4 linux) 27 #!+hpux 21 #!+svr4 29
208   #!+linux 30 "Profiling timer alarm")
209 (def-unix-signal :SIGWINCH #!-(or hpux svr4) 28 #!+hpux 23 #!+svr4 20
210     "Window size change")
211 (def-unix-signal :SIGUSR1 #!-(or hpux svr4 linux) 30 #!+(or hpux svr4) 16
212   #!+linux 10 "User defined signal 1")
213 (def-unix-signal :SIGUSR2 #!-(or hpux svr4 linux) 31 #!+(or hpux svr4) 17
214   #!+linux 12 "User defined signal 2")
215
216 #!+mach
217 (def-unix-signal :SIGEMSG 30 "Mach Emergency message")
218 #!+mach
219 (def-unix-signal :SIGMSG 31 "Mach message")
220
221 ;;; SVR4 (or Solaris?) specific signals
222 #!+svr4
223 (def-unix-signal :SIGWAITING 32 "Process's lwps are blocked")
224
225 (sb!xc:defmacro sigmask (&rest signals)
226   #!+sb-doc
227   "Returns a mask given a set of signals."
228   (apply #'logior
229          (mapcar #'(lambda (signal)
230                      (ash 1 (1- (unix-signal-number signal))))
231                  signals)))