Declare EXPLICIT-CHECK on CONCATENATE, MAKE-STRING, SET-PPRINT-DISPATCH.
[sbcl.git] / src / code / target-signal.lisp
blob50077420fab338e1007abd374dafad0cd0577296
1 ;;;; code for handling UNIX signals
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.
12 (in-package "SB!UNIX")
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))
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))))))
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)))))))))
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)))
70 ;;;; system calls that deal with signals
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 unix-kill))
75 (define-alien-routine ("kill" unix-kill) int
76 (pid int)
77 (signal int))
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 unix-killpg))
82 (define-alien-routine ("killpg" unix-killpg) int
83 (pgrp int)
84 (signal int))
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.)
96 (declaim (inline %unblock-deferrable-signals %unblock-gc-signals))
97 (define-alien-routine ("unblock_deferrable_signals"
98 %unblock-deferrable-signals)
99 void
100 (where unsigned-long)
101 (old unsigned-long))
102 #!-sb-safepoint
103 (define-alien-routine ("unblock_gc_signals" %unblock-gc-signals)
104 void
105 (where unsigned-long)
106 (old unsigned-long))
108 (defun unblock-deferrable-signals ()
109 (%unblock-deferrable-signals 0 0))
111 #!-sb-safepoint
112 (defun unblock-gc-signals ()
113 (%unblock-gc-signals 0 0))
116 ;;;; C routines that actually do all the work of establishing signal handlers
117 (define-alien-routine ("install_handler" install-handler)
118 unsigned-long
119 (signal int)
120 (handler unsigned-long)
121 (synchronous boolean))
123 ;;;; interface to enabling and disabling signal handlers
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.
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)
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))))))))
159 (defun default-interrupt (signal)
160 (enable-interrupt signal :default))
162 (defun ignore-interrupt (signal)
163 (enable-interrupt signal :ignore))
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:
173 #!+(and sb-safepoint-strictly (not win32))
174 (defun signal-handler-callback (run-handler signal args)
175 ;; SAPs are dx allocated, close over the values, not the SAPs.
176 (let ((info (sap-ref-sap args 0))
177 (context (sap-ref-sap args sb!vm:n-word-bytes)))
178 (sb!thread::initial-thread-function-trampoline
179 (sb!thread::make-signal-handling-thread :name "signal handler"
180 :signal-number signal)
181 nil (lambda ()
182 (funcall run-handler signal info context))
184 nil nil nil nil)))
187 ;;;; default LISP signal handlers
188 ;;;;
189 ;;;; Most of these just call ERROR to report the presence of the signal.
191 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
192 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
193 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
194 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
195 (eval-when (:compile-toplevel :execute)
196 (sb!xc:defmacro define-signal-handler (name what &optional (function 'error))
197 `(defun ,name (signal info context)
198 (declare (ignore signal info))
199 (declare (type system-area-pointer context))
200 (/show "in Lisp-level signal handler" ,(symbol-name name)
201 (sap-int context))
202 (with-interrupts
203 (,function ,(concatenate 'simple-string what " at #X~X")
204 (with-alien ((context (* os-context-t) context))
205 (sap-int (sb!vm:context-pc context))))))))
207 (define-signal-handler sigill-handler "illegal instruction")
208 #!-(or linux android)
209 (define-signal-handler sigemt-handler "SIGEMT")
210 (define-signal-handler sigbus-handler "bus error")
211 #!-(or linux android)
212 (define-signal-handler sigsys-handler "bad argument to a system call")
214 (defun sigint-handler (signal info context)
215 (declare (ignore signal info))
216 (declare (type system-area-pointer context))
217 (/show "in Lisp-level SIGINT handler" (sap-int context))
218 ;; Copy CONTEXT, since the SAP is stack allocated and it's going
219 ;; to be passed to another thread. See the below comment on the
220 ;; general idea whether it's a good thing to do at all.
221 (let ((context (int-sap (sap-int context))))
222 (flet ((interrupt-it ()
223 ;; This seems wrong to me on multi-threaded builds. The
224 ;; closed-over signal context belongs to a SIGINT handler.
225 ;; But this function gets run through INTERRUPT-THREAD,
226 ;; i.e. in in a SIGPIPE handler, at a different point in time
227 ;; or even a different thread. How do we know that the
228 ;; SIGINT's context structure from the other thread is still
229 ;; alive and meaningful? Why do we care? If we even need
230 ;; the context and PC, shouldn't they come from the SIGPIPE's
231 ;; context? --DFL
232 (with-alien ((context (* os-context-t) context))
233 (with-interrupts
234 (let ((int (make-condition 'interactive-interrupt
235 :context context
236 :address (sap-int (sb!vm:context-pc context)))))
237 ;; First SIGNAL, so that handlers can run.
238 (signal int)
239 ;; Then enter the debugger like BREAK.
240 (%break 'sigint int))))))
241 #!+sb-safepoint
242 (let ((target (sb!thread::foreground-thread)))
243 ;; Note that INTERRUPT-THREAD on *CURRENT-THREAD* doesn't actually
244 ;; interrupt right away, because deferrables are blocked. Rather,
245 ;; the kernel would arrange for the SIGPIPE to hit when the SIGINT
246 ;; handler is done. However, on safepoint builds, we don't use
247 ;; SIGPIPE and lack an appropriate mechanism to handle pending
248 ;; thruptions upon exit from signal handlers (and this situation is
249 ;; unlike WITHOUT-INTERRUPTS, which handles pending interrupts
250 ;; explicitly at the end). Only as long as safepoint builds pretend
251 ;; to cooperate with signals -- that is, as long as SIGINT-HANDLER
252 ;; is used at all -- detect this situation and work around it.
253 (if (eq target sb!thread:*current-thread*)
254 (interrupt-it)
255 (sb!thread:interrupt-thread target #'interrupt-it)))
256 #!-sb-safepoint
257 (sb!thread:interrupt-thread (sb!thread::foreground-thread)
258 #'interrupt-it))))
260 #!-sb-wtimer
261 (defun sigalrm-handler (signal info context)
262 (declare (ignore signal info context))
263 (declare (type system-area-pointer context))
264 (sb!impl::run-expired-timers))
266 (defun sigterm-handler (signal code context)
267 (declare (ignore signal code context))
268 (exit))
270 #!-sb-thruption
271 ;;; SIGPIPE is not used in SBCL for its original purpose, instead it's
272 ;;; for signalling a thread that it should look at its interruption
273 ;;; queue. The handler (RUN_INTERRUPTION) just returns if there is
274 ;;; nothing to do so it's safe to receive spurious SIGPIPEs coming
275 ;;; from the kernel.
276 (defun sigpipe-handler (signal code context)
277 (declare (ignore signal code context))
278 (sb!thread::run-interruption))
280 ;;; the handler for SIGCHLD signals for RUN-PROGRAM
281 (defun sigchld-handler (signal code context)
282 (declare (ignore signal code context))
283 (sb!impl::get-processes-status-changes))
285 (defun sb!kernel:signal-cold-init-or-reinit ()
286 #!+sb-doc
287 "Enable all the default signals that Lisp knows how to deal with."
288 (enable-interrupt sigint #'sigint-handler)
289 (enable-interrupt sigterm #'sigterm-handler)
290 (enable-interrupt sigill #'sigill-handler :synchronous t)
291 #!-(or linux android)
292 (enable-interrupt sigemt #'sigemt-handler)
293 (enable-interrupt sigfpe #'sb!vm:sigfpe-handler :synchronous t)
294 (enable-interrupt sigbus #'sigbus-handler :synchronous t)
295 #!-(or linux android)
296 (enable-interrupt sigsys #'sigsys-handler :synchronous t)
297 #!-sb-wtimer
298 (enable-interrupt sigalrm #'sigalrm-handler)
299 #!-sb-thruption
300 (enable-interrupt sigpipe #'sigpipe-handler)
301 (enable-interrupt sigchld #'sigchld-handler)
302 #!+hpux (ignore-interrupt sigxcpu)
303 #!-sb-safepoint (unblock-gc-signals)
304 (unblock-deferrable-signals)
305 (values))
307 ;;;; etc.
309 ;;; extract si_code from siginfo_t
310 (define-alien-routine ("siginfo_code" siginfo-code) int
311 (info system-area-pointer))
313 ;;; CMU CL comment:
314 ;;; Magically converted by the compiler into a break instruction.
315 (defun receive-pending-interrupt ()
316 (receive-pending-interrupt))