Silence notes about being specialised EQ templates on x86oids
[sbcl.git] / src / code / target-signal.lisp
1 ;;;; code for 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 (defmacro with-interrupt-bindings (&body body)
15   `(let*
16        ;; KLUDGE: Whatever is on the PCL stacks before the interrupt
17        ;; handler runs doesn't really matter, since we're not on the
18        ;; same call stack, really -- and if we don't bind these (esp.
19        ;; the cache one) we can get a bogus metacircle if an interrupt
20        ;; handler calls a GF that was being computed when the interrupt
21        ;; hit.
22        ((sb!pcl::*cache-miss-values-stack* nil)
23         (sb!pcl::*dfun-miss-gfs-on-stack* nil))
24      ,@body))
25
26 ;;; Evaluate CLEANUP-FORMS iff PROTECTED-FORM does a non-local exit.
27 (defmacro nlx-protect (protected-form &rest cleanup-froms)
28   (with-unique-names (completep)
29     `(let ((,completep nil))
30        (without-interrupts
31          (unwind-protect
32               (progn
33                 (allow-with-interrupts
34                   ,protected-form)
35                 (setq ,completep t))
36            (unless ,completep
37              ,@cleanup-froms))))))
38
39 (defun invoke-interruption (function)
40   (without-interrupts
41     ;; Reset signal mask: the C-side handler has blocked all
42     ;; deferrable signals before funcalling into lisp. They are to be
43     ;; unblocked the first time interrupts are enabled. With this
44     ;; mechanism there are no extra frames on the stack from a
45     ;; previous signal handler when the next signal is delivered
46     ;; provided there is no WITH-INTERRUPTS.
47     (let ((*unblock-deferrables-on-enabling-interrupts-p* t)
48           (sb!debug:*stack-top-hint* (or sb!debug:*stack-top-hint* 'invoke-interruption)))
49       (with-interrupt-bindings
50         (sb!thread::without-thread-waiting-for (:already-without-interrupts t)
51           (allow-with-interrupts
52             (nlx-protect (funcall function)
53                          ;; We've been running with deferrables
54                          ;; blocked in Lisp called by a C signal
55                          ;; handler. If we return normally the sigmask
56                          ;; in the interrupted context is restored.
57                          ;; However, if we do an nlx the operating
58                          ;; system will not restore it for us.
59                          (when *unblock-deferrables-on-enabling-interrupts-p*
60                            ;; This means that storms of interrupts
61                            ;; doing an nlx can still run out of stack.
62                            (unblock-deferrable-signals)))))))))
63
64 (defmacro in-interruption ((&key) &body body)
65   #!+sb-doc
66   "Convenience macro on top of INVOKE-INTERRUPTION."
67   `(dx-flet ((interruption () ,@body))
68      (invoke-interruption #'interruption)))
69 \f
70 ;;;; system calls that deal with signals
71
72 ;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
73 ;;; should be a valid signal number
74 #!-sb-fluid (declaim (inline real-unix-kill))
75 (sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
76   (pid sb!alien:int)
77   (signal sb!alien:int))
78
79 ;;; Send the signal SIGNAL to the all the process in process group
80 ;;; PGRP. SIGNAL should be a valid signal number
81 #!-sb-fluid (declaim (inline real-unix-killpg))
82 (sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
83   (pgrp sb!alien:int)
84   (signal sb!alien:int))
85
86 ;;; Reset the current set of masked signals (those being blocked from
87 ;;; delivery).
88 ;;;
89 ;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
90 ;;; operator to create masks, but since we only ever reset to 0, we no
91 ;;; longer support it. If you need it, you can pull it out of the CMU
92 ;;; CL sources, or the old SBCL sources; but you might also consider
93 ;;; doing things the SBCL way and moving this kind of C-level work
94 ;;; down to C wrapper functions.)
95
96 (declaim (inline %unblock-deferrable-signals %unblock-gc-signals))
97 (sb!alien:define-alien-routine ("unblock_deferrable_signals"
98                                 %unblock-deferrable-signals)
99     sb!alien:void
100   (where sb!alien:unsigned-long)
101   (old sb!alien:unsigned-long))
102 #!-sb-safepoint
103 (sb!alien:define-alien-routine ("unblock_gc_signals" %unblock-gc-signals)
104     sb!alien:void
105   (where sb!alien:unsigned-long)
106   (old sb!alien:unsigned-long))
107
108 (defun unblock-deferrable-signals ()
109   (%unblock-deferrable-signals 0 0))
110
111 #!-sb-safepoint
112 (defun unblock-gc-signals ()
113   (%unblock-gc-signals 0 0))
114
115 \f
116 ;;;; C routines that actually do all the work of establishing signal handlers
117 (sb!alien:define-alien-routine ("install_handler" install-handler)
118                                sb!alien:unsigned-long
119   (signal sb!alien:int)
120   (handler sb!alien:unsigned-long)
121   (synchronous boolean))
122
123 ;;;; interface to enabling and disabling signal handlers
124
125 ;;; Note on the SYNCHRONOUS argument: On builds without pseudo-atomic,
126 ;;; we have no way of knowing whether interrupted code was in an
127 ;;; allocation sequence, and cannot delay signals until after
128 ;;; allocation.  Any signal that can occur asynchronously must be
129 ;;; considered unsafe for immediate execution, and the invocation of its
130 ;;; lisp handler will get delayed into a newly spawned signal handler
131 ;;; thread.  However, there are signals which we must handle
132 ;;; immediately, because they occur synchonously (hence the boolean flag
133 ;;; SYNCHRONOUS to this function), luckily implying that the signal
134 ;;; happens only in specific places (illegal instructions, floating
135 ;;; point instructions, certain system calls), hopefully ruling out the
136 ;;; possibility that we would trigger it during allocation.
137
138 (defun enable-interrupt (signal handler &key synchronous)
139   (declare (type (or function fixnum (member :default :ignore)) handler))
140   (/show0 "enable-interrupt")
141   (flet ((run-handler (&rest args)
142            (declare (truly-dynamic-extent args))
143            (in-interruption ()
144              (apply handler args))))
145     (without-gcing
146       (let ((result (install-handler signal
147                                      (case handler
148                                        (:default sig-dfl)
149                                        (:ignore sig-ign)
150                                        (t
151                                         (sb!kernel:get-lisp-obj-address
152                                          #'run-handler)))
153                                      synchronous)))
154         (cond ((= result sig-dfl) :default)
155               ((= result sig-ign) :ignore)
156               (t (the (or function fixnum)
157                    (sb!kernel:make-lisp-obj result))))))))
158
159 (defun default-interrupt (signal)
160   (enable-interrupt signal :default))
161
162 (defun ignore-interrupt (signal)
163   (enable-interrupt signal :ignore))
164 \f
165 ;;;; Support for signal handlers which aren't.
166 ;;;;
167 ;;;; On safepoint builds, user-defined Lisp signal handlers do not run
168 ;;;; in the handler for their signal, because we have no pseudo atomic
169 ;;;; mechanism to prevent handlers from hitting during allocation.
170 ;;;; Rather, the signal spawns off a fresh native thread, which calls
171 ;;;; into lisp with a fake context through this callback:
172
173 #!+(and sb-safepoint-strictly (not win32))
174 (defun signal-handler-callback (run-handler signal args)
175   (sb!thread::initial-thread-function-trampoline
176    (sb!thread::make-signal-handling-thread :name "signal handler"
177                                            :signal-number signal)
178    nil (lambda ()
179          (let* ((info (sb!sys:sap-ref-sap args 0))
180                 (context (sb!sys:sap-ref-sap args sb!vm:n-word-bytes)))
181            (funcall run-handler signal info context)))
182    nil nil nil nil))
183
184 \f
185 ;;;; default LISP signal handlers
186 ;;;;
187 ;;;; Most of these just call ERROR to report the presence of the signal.
188
189 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
190 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
191 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
192 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
193 (eval-when (:compile-toplevel :execute)
194   (sb!xc:defmacro define-signal-handler (name what &optional (function 'error))
195     `(defun ,name (signal info context)
196        (declare (ignore signal info))
197        (declare (type system-area-pointer context))
198        (/show "in Lisp-level signal handler" ,(symbol-name name)
199               (sap-int context))
200        (with-interrupts
201          (,function ,(concatenate 'simple-string what " at #X~X")
202                     (with-alien ((context (* os-context-t) context))
203                       (sap-int (sb!vm:context-pc context))))))))
204
205 (define-signal-handler sigill-handler "illegal instruction")
206 #!-linux
207 (define-signal-handler sigemt-handler "SIGEMT")
208 (define-signal-handler sigbus-handler "bus error")
209 #!-linux
210 (define-signal-handler sigsys-handler "bad argument to a system call")
211
212 (defun sigint-handler (signal info context)
213   (declare (ignore signal info))
214   (declare (type system-area-pointer context))
215   (/show "in Lisp-level SIGINT handler" (sap-int context))
216   (flet ((interrupt-it ()
217            ;; This seems wrong to me on multi-threaded builds.  The
218            ;; closed-over signal context belongs to a SIGINT handler.
219            ;; But this function gets run through INTERRUPT-THREAD,
220            ;; i.e. in in a SIGPIPE handler, at a different point in time
221            ;; or even a different thread.  How do we know that the
222            ;; SIGINT's context structure from the other thread is still
223            ;; alive and meaningful?  Why do we care?  If we even need
224            ;; the context and PC, shouldn't they come from the SIGPIPE's
225            ;; context? --DFL
226            (with-alien ((context (* os-context-t) context))
227              (with-interrupts
228                (let ((int (make-condition 'interactive-interrupt
229                                           :context context
230                                           :address (sap-int (sb!vm:context-pc context)))))
231                  ;; First SIGNAL, so that handlers can run.
232                  (signal int)
233                  ;; Then enter the debugger like BREAK.
234                  (%break 'sigint int))))))
235     #!+sb-safepoint
236     (let ((target (sb!thread::foreground-thread)))
237       ;; Note that INTERRUPT-THREAD on *CURRENT-THREAD* doesn't actually
238       ;; interrupt right away, because deferrables are blocked.  Rather,
239       ;; the kernel would arrange for the SIGPIPE to hit when the SIGINT
240       ;; handler is done.  However, on safepoint builds, we don't use
241       ;; SIGPIPE and lack an appropriate mechanism to handle pending
242       ;; thruptions upon exit from signal handlers (and this situation is
243       ;; unlike WITHOUT-INTERRUPTS, which handles pending interrupts
244       ;; explicitly at the end).  Only as long as safepoint builds pretend
245       ;; to cooperate with signals -- that is, as long as SIGINT-HANDLER
246       ;; is used at all -- detect this situation and work around it.
247       (if (eq target sb!thread:*current-thread*)
248           (interrupt-it)
249           (sb!thread:interrupt-thread target #'interrupt-it)))
250     #!-sb-safepoint
251     (sb!thread:interrupt-thread (sb!thread::foreground-thread)
252                                 #'interrupt-it)))
253
254 #!-sb-wtimer
255 (defun sigalrm-handler (signal info context)
256   (declare (ignore signal info context))
257   (declare (type system-area-pointer context))
258   (sb!impl::run-expired-timers))
259
260 (defun sigterm-handler (signal code context)
261   (declare (ignore signal code context))
262   (sb!ext:exit))
263
264 #!-sb-thruption
265 ;;; SIGPIPE is not used in SBCL for its original purpose, instead it's
266 ;;; for signalling a thread that it should look at its interruption
267 ;;; queue. The handler (RUN_INTERRUPTION) just returns if there is
268 ;;; nothing to do so it's safe to receive spurious SIGPIPEs coming
269 ;;; from the kernel.
270 (defun sigpipe-handler (signal code context)
271   (declare (ignore signal code context))
272   (sb!thread::run-interruption))
273
274 ;;; the handler for SIGCHLD signals for RUN-PROGRAM
275 (defun sigchld-handler  (signal code context)
276   (declare (ignore signal code context))
277   (sb!impl::get-processes-status-changes))
278
279 (defun sb!kernel:signal-cold-init-or-reinit ()
280   #!+sb-doc
281   "Enable all the default signals that Lisp knows how to deal with."
282   (enable-interrupt sigint #'sigint-handler)
283   (enable-interrupt sigterm #'sigterm-handler)
284   (enable-interrupt sigill #'sigill-handler :synchronous t)
285   #!-linux
286   (enable-interrupt sigemt #'sigemt-handler)
287   (enable-interrupt sigfpe #'sb!vm:sigfpe-handler :synchronous t)
288   (enable-interrupt sigbus #'sigbus-handler :synchronous t)
289   #!-linux
290   (enable-interrupt sigsys #'sigsys-handler :synchronous t)
291   #!-sb-wtimer
292   (enable-interrupt sigalrm #'sigalrm-handler)
293   #!-sb-thruption
294   (enable-interrupt sigpipe #'sigpipe-handler)
295   (enable-interrupt sigchld #'sigchld-handler)
296   #!+hpux (ignore-interrupt sigxcpu)
297   #!-sb-safepoint (unblock-gc-signals)
298   (unblock-deferrable-signals)
299   (values))
300 \f
301 ;;;; etc.
302
303 ;;; extract si_code from siginfo_t
304 (sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int
305   (info system-area-pointer))
306
307 ;;; CMU CL comment:
308 ;;;   Magically converted by the compiler into a break instruction.
309 (defun receive-pending-interrupt ()
310   (receive-pending-interrupt))