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 (with-interrupt-bindings
49 (let ((sb!debug:*stack-top-hint*
50 (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
51 (sb!thread::without-thread-waiting-for (:already-without-interrupts t)
52 (allow-with-interrupts
53 (nlx-protect (funcall function)
54 ;; We've been running with deferrables
55 ;; blocked in Lisp called by a C signal
56 ;; handler. If we return normally the sigmask
57 ;; in the interrupted context is restored.
58 ;; However, if we do an nlx the operating
59 ;; system will not restore it for us.
60 (when *unblock-deferrables-on-enabling-interrupts-p*
61 ;; This means that storms of interrupts
62 ;; doing an nlx can still run out of stack.
63 (unblock-deferrable-signals))))))))))
65 (defmacro in-interruption ((&key) &body body)
67 "Convenience macro on top of INVOKE-INTERRUPTION."
68 `(dx-flet ((interruption () ,@body))
69 (invoke-interruption #'interruption)))
71 ;;;; system calls that deal with signals
73 ;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
74 ;;; should be a valid signal number
75 #!-sb-fluid (declaim (inline real-unix-kill))
76 (sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
78 (signal sb!alien:int))
80 ;;; Send the signal SIGNAL to the all the process in process group
81 ;;; PGRP. SIGNAL should be a valid signal number
82 #!-sb-fluid (declaim (inline real-unix-killpg))
83 (sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
85 (signal sb!alien:int))
87 ;;; Reset the current set of masked signals (those being blocked from
90 ;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
91 ;;; operator to create masks, but since we only ever reset to 0, we no
92 ;;; longer support it. If you need it, you can pull it out of the CMU
93 ;;; CL sources, or the old SBCL sources; but you might also consider
94 ;;; doing things the SBCL way and moving this kind of C-level work
95 ;;; down to C wrapper functions.)
97 (declaim (inline %unblock-deferrable-signals %unblock-gc-signals))
98 (sb!alien:define-alien-routine ("unblock_deferrable_signals"
99 %unblock-deferrable-signals)
101 (where sb!alien:unsigned-long)
102 (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))
111 (defun unblock-gc-signals ()
112 (%unblock-gc-signals 0 0))
115 ;;;; C routines that actually do all the work of establishing signal handlers
116 (sb!alien:define-alien-routine ("install_handler" install-handler)
117 sb!alien:unsigned-long
118 (signal sb!alien:int)
119 (handler sb!alien:unsigned-long))
121 ;;;; interface to enabling and disabling signal handlers
123 (defun enable-interrupt (signal handler)
124 (declare (type (or function fixnum (member :default :ignore)) handler))
125 (/show0 "enable-interrupt")
126 (flet ((run-handler (&rest args)
127 (declare (truly-dynamic-extent args))
129 (apply handler args))))
131 (let ((result (install-handler signal
136 (sb!kernel:get-lisp-obj-address
138 (cond ((= result sig-dfl) :default)
139 ((= result sig-ign) :ignore)
140 (t (the (or function fixnum)
141 (sb!kernel:make-lisp-obj result))))))))
143 (defun default-interrupt (signal)
144 (enable-interrupt signal :default))
146 (defun ignore-interrupt (signal)
147 (enable-interrupt signal :ignore))
149 ;;;; default LISP signal handlers
151 ;;;; Most of these just call ERROR to report the presence of the signal.
153 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
154 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
155 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
156 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
157 (eval-when (:compile-toplevel :execute)
158 (sb!xc:defmacro define-signal-handler (name what &optional (function 'error))
159 `(defun ,name (signal info context)
160 (declare (ignore signal info))
161 (declare (type system-area-pointer context))
162 (/show "in Lisp-level signal handler" ,(symbol-name name)
165 (,function ,(concatenate 'simple-string what " at #X~X")
166 (with-alien ((context (* os-context-t) context))
167 (sap-int (sb!vm:context-pc context))))))))
169 (define-signal-handler sigill-handler "illegal instruction")
171 (define-signal-handler sigemt-handler "SIGEMT")
172 (define-signal-handler sigbus-handler "bus error")
174 (define-signal-handler sigsys-handler "bad argument to a system call")
176 (defun sigint-handler (signal info context)
177 (declare (ignore signal info))
178 (declare (type system-area-pointer context))
179 (/show "in Lisp-level SIGINT handler" (sap-int context))
180 (flet ((interrupt-it ()
181 (with-alien ((context (* os-context-t) context))
183 (let ((int (make-condition 'interactive-interrupt
185 :address (sap-int (sb!vm:context-pc context)))))
186 ;; First SIGNAL, so that handlers can run.
188 ;; Then enter the debugger like BREAK.
189 (%break 'sigint int))))))
190 (sb!thread:interrupt-thread (sb!thread::foreground-thread)
193 (defun sigalrm-handler (signal info context)
194 (declare (ignore signal info context))
195 (declare (type system-area-pointer context))
196 (sb!impl::run-expired-timers))
198 (defun sigterm-handler (signal code context)
199 (declare (ignore signal code context))
200 (sb!thread::terminate-session)
203 ;;; SIGPIPE is not used in SBCL for its original purpose, instead it's
204 ;;; for signalling a thread that it should look at its interruption
205 ;;; queue. The handler (RUN_INTERRUPTION) just returns if there is
206 ;;; nothing to do so it's safe to receive spurious SIGPIPEs coming
208 (defun sigpipe-handler (signal code context)
209 (declare (ignore signal code context))
210 (sb!thread::run-interruption))
212 ;;; the handler for SIGCHLD signals for RUN-PROGRAM
213 (defun sigchld-handler (signal code context)
214 (declare (ignore signal code context))
215 (sb!impl::get-processes-status-changes))
217 (defun sb!kernel:signal-cold-init-or-reinit ()
219 "Enable all the default signals that Lisp knows how to deal with."
220 (enable-interrupt sigint #'sigint-handler)
221 (enable-interrupt sigterm #'sigterm-handler)
222 (enable-interrupt sigill #'sigill-handler)
224 (enable-interrupt sigemt #'sigemt-handler)
225 (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
226 (enable-interrupt sigbus #'sigbus-handler)
228 (enable-interrupt sigsys #'sigsys-handler)
229 (enable-interrupt sigalrm #'sigalrm-handler)
230 (enable-interrupt sigpipe #'sigpipe-handler)
231 (enable-interrupt sigchld #'sigchld-handler)
232 #!+hpux (ignore-interrupt sigxcpu)
234 (unblock-deferrable-signals)
239 ;;; extract si_code from siginfo_t
240 (sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int
241 (info system-area-pointer))
244 ;;; Magically converted by the compiler into a break instruction.
245 (defun receive-pending-interrupt ()
246 (receive-pending-interrupt))