1 ;;;; code for handling UNIX signals
3 ;;;; This software is part of the SBCL system. See the README file for
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)
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
22 ((sb!pcl::*cache-miss-values-stack* nil)
23 (sb!pcl::*dfun-miss-gfs-on-stack* nil))
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))
33 (allow-with-interrupts
39 (defun invoke-interruption (function)
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)
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 real-unix-kill))
75 (sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
77 (signal sb!alien: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 real-unix-killpg))
82 (sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
84 (signal sb!alien:int))
86 ;;; Reset the current set of masked signals (those being blocked from
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 (sb!alien:define-alien-routine ("unblock_deferrable_signals"
98 %unblock-deferrable-signals)
100 (where sb!alien:unsigned-long)
101 (old sb!alien:unsigned-long))
103 (sb!alien:define-alien-routine ("unblock_gc_signals" %unblock-gc-signals)
105 (where sb!alien:unsigned-long)
106 (old sb!alien:unsigned-long))
108 (defun unblock-deferrable-signals ()
109 (%unblock-deferrable-signals 0 0))
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 (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))
122 ;;;; interface to enabling and disabling signal handlers
124 (defun enable-interrupt (signal handler)
125 (declare (type (or function fixnum (member :default :ignore)) handler))
126 (/show0 "enable-interrupt")
127 (flet ((run-handler (&rest args)
128 (declare (truly-dynamic-extent args))
130 (apply handler args))))
132 (let ((result (install-handler signal
137 (sb!kernel:get-lisp-obj-address
139 (cond ((= result sig-dfl) :default)
140 ((= result sig-ign) :ignore)
141 (t (the (or function fixnum)
142 (sb!kernel:make-lisp-obj result))))))))
144 (defun default-interrupt (signal)
145 (enable-interrupt signal :default))
147 (defun ignore-interrupt (signal)
148 (enable-interrupt signal :ignore))
150 ;;;; default LISP signal handlers
152 ;;;; Most of these just call ERROR to report the presence of the signal.
154 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
155 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
156 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
157 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
158 (eval-when (:compile-toplevel :execute)
159 (sb!xc:defmacro define-signal-handler (name what &optional (function 'error))
160 `(defun ,name (signal info context)
161 (declare (ignore signal info))
162 (declare (type system-area-pointer context))
163 (/show "in Lisp-level signal handler" ,(symbol-name name)
166 (,function ,(concatenate 'simple-string what " at #X~X")
167 (with-alien ((context (* os-context-t) context))
168 (sap-int (sb!vm:context-pc context))))))))
170 (define-signal-handler sigill-handler "illegal instruction")
172 (define-signal-handler sigemt-handler "SIGEMT")
173 (define-signal-handler sigbus-handler "bus error")
175 (define-signal-handler sigsys-handler "bad argument to a system call")
177 (defun sigint-handler (signal info context)
178 (declare (ignore signal info))
179 (declare (type system-area-pointer context))
180 (/show "in Lisp-level SIGINT handler" (sap-int context))
181 (flet ((interrupt-it ()
182 (with-alien ((context (* os-context-t) context))
184 (let ((int (make-condition 'interactive-interrupt
186 :address (sap-int (sb!vm:context-pc context)))))
187 ;; First SIGNAL, so that handlers can run.
189 ;; Then enter the debugger like BREAK.
190 (%break 'sigint int))))))
192 (let ((target (sb!thread::foreground-thread)))
193 ;; Note that INTERRUPT-THREAD on *CURRENT-THREAD* doesn't actually
194 ;; interrupt right away, because deferrables are blocked. Rather,
195 ;; the kernel would arrange for the SIGPIPE to hit when the SIGINT
196 ;; handler is done. However, on safepoint builds, we don't use
197 ;; SIGPIPE and lack an appropriate mechanism to handle pending
198 ;; thruptions upon exit from signal handlers (and this situation is
199 ;; unlike WITHOUT-INTERRUPTS, which handles pending interrupts
200 ;; explicitly at the end). Only as long as safepoint builds pretend
201 ;; to cooperate with signals -- that is, as long as SIGINT-HANDLER
202 ;; is used at all -- detect this situation and work around it.
203 (if (eq target sb!thread:*current-thread*)
205 (sb!thread:interrupt-thread target #'interrupt-it)))
207 (sb!thread:interrupt-thread (sb!thread::foreground-thread)
211 (defun sigalrm-handler (signal info context)
212 (declare (ignore signal info context))
213 (declare (type system-area-pointer context))
214 (sb!impl::run-expired-timers))
216 (defun sigterm-handler (signal code context)
217 (declare (ignore signal code context))
221 ;;; SIGPIPE is not used in SBCL for its original purpose, instead it's
222 ;;; for signalling a thread that it should look at its interruption
223 ;;; queue. The handler (RUN_INTERRUPTION) just returns if there is
224 ;;; nothing to do so it's safe to receive spurious SIGPIPEs coming
226 (defun sigpipe-handler (signal code context)
227 (declare (ignore signal code context))
228 (sb!thread::run-interruption))
230 ;;; the handler for SIGCHLD signals for RUN-PROGRAM
231 (defun sigchld-handler (signal code context)
232 (declare (ignore signal code context))
233 (sb!impl::get-processes-status-changes))
235 (defun sb!kernel:signal-cold-init-or-reinit ()
237 "Enable all the default signals that Lisp knows how to deal with."
238 (enable-interrupt sigint #'sigint-handler)
239 (enable-interrupt sigterm #'sigterm-handler)
240 (enable-interrupt sigill #'sigill-handler)
242 (enable-interrupt sigemt #'sigemt-handler)
243 (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
244 (enable-interrupt sigbus #'sigbus-handler)
246 (enable-interrupt sigsys #'sigsys-handler)
248 (enable-interrupt sigalrm #'sigalrm-handler)
250 (enable-interrupt sigpipe #'sigpipe-handler)
251 (enable-interrupt sigchld #'sigchld-handler)
252 #!+hpux (ignore-interrupt sigxcpu)
253 #!-sb-safepoint (unblock-gc-signals)
254 (unblock-deferrable-signals)
259 ;;; extract si_code from siginfo_t
260 (sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int
261 (info system-area-pointer))
264 ;;; Magically converted by the compiler into a break instruction.
265 (defun receive-pending-interrupt ()
266 (receive-pending-interrupt))