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
)
65 "Convenience macro on top of INVOKE-INTERRUPTION."
66 `(dx-flet ((interruption () ,@body
))
67 (invoke-interruption #'interruption
)))
69 ;;;; system calls that deal with signals
71 ;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
72 ;;; should be a valid signal number
73 #!-sb-fluid
(declaim (inline unix-kill
))
74 (define-alien-routine ("kill" unix-kill
) int
78 ;;; Send the signal SIGNAL to the all the process in process group
79 ;;; PGRP. SIGNAL should be a valid signal number
80 #!-sb-fluid
(declaim (inline unix-killpg
))
81 (define-alien-routine ("killpg" unix-killpg
) int
85 ;;; Reset the current set of masked signals (those being blocked from
88 ;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
89 ;;; operator to create masks, but since we only ever reset to 0, we no
90 ;;; longer support it. If you need it, you can pull it out of the CMU
91 ;;; CL sources, or the old SBCL sources; but you might also consider
92 ;;; doing things the SBCL way and moving this kind of C-level work
93 ;;; down to C wrapper functions.)
95 (declaim (inline %unblock-deferrable-signals %unblock-gc-signals
))
96 (define-alien-routine ("unblock_deferrable_signals"
97 %unblock-deferrable-signals
)
102 (define-alien-routine ("unblock_gc_signals" %unblock-gc-signals
)
104 (where unsigned-long
)
107 (defun unblock-deferrable-signals ()
108 (%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 (define-alien-routine ("install_handler" install-handler
)
119 (handler unsigned-long
)
120 (synchronous boolean
))
122 ;;;; interface to enabling and disabling signal handlers
124 ;;; Note on the SYNCHRONOUS argument: On builds without pseudo-atomic,
125 ;;; we have no way of knowing whether interrupted code was in an
126 ;;; allocation sequence, and cannot delay signals until after
127 ;;; allocation. Any signal that can occur asynchronously must be
128 ;;; considered unsafe for immediate execution, and the invocation of its
129 ;;; lisp handler will get delayed into a newly spawned signal handler
130 ;;; thread. However, there are signals which we must handle
131 ;;; immediately, because they occur synchonously (hence the boolean flag
132 ;;; SYNCHRONOUS to this function), luckily implying that the signal
133 ;;; happens only in specific places (illegal instructions, floating
134 ;;; point instructions, certain system calls), hopefully ruling out the
135 ;;; possibility that we would trigger it during allocation.
137 (defun enable-interrupt (signal handler
&key synchronous
)
138 (declare (type (or function fixnum
(member :default
:ignore
)) handler
))
139 (/show0
"enable-interrupt")
140 (flet ((run-handler (&rest args
)
141 (declare (truly-dynamic-extent args
))
143 (apply handler args
))))
145 (let ((result (install-handler signal
150 (sb!kernel
:get-lisp-obj-address
153 (cond ((= result sig-dfl
) :default
)
154 ((= result sig-ign
) :ignore
)
155 (t ;; MAKE-LISP-OBJ returns 2 values, which gets
156 ;; "too complex to check". We don't want the second value.
157 (values (the (or function fixnum
)
158 (sb!kernel
:make-lisp-obj result
)))))))))
160 (defun default-interrupt (signal)
161 (enable-interrupt signal
:default
))
163 (defun ignore-interrupt (signal)
164 (enable-interrupt signal
:ignore
))
166 ;;;; Support for signal handlers which aren't.
168 ;;;; On safepoint builds, user-defined Lisp signal handlers do not run
169 ;;;; in the handler for their signal, because we have no pseudo atomic
170 ;;;; mechanism to prevent handlers from hitting during allocation.
171 ;;;; Rather, the signal spawns off a fresh native thread, which calls
172 ;;;; into lisp with a fake context through this callback:
174 #!+(and sb-safepoint-strictly
(not win32
))
175 (defun signal-handler-callback (run-handler signal args
)
176 ;; SAPs are dx allocated, close over the values, not the SAPs.
177 (let ((info (sap-ref-sap args
0))
178 (context (sap-ref-sap args sb
!vm
:n-word-bytes
)))
179 (sb!thread
::initial-thread-function-trampoline
180 (sb!thread
::make-signal-handling-thread
:name
"signal handler"
181 :signal-number signal
)
183 (funcall run-handler signal info context
))
188 ;;;; default LISP signal handlers
190 ;;;; Most of these just call ERROR to report the presence of the signal.
192 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
193 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
194 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
195 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
196 (eval-when (:compile-toplevel
:execute
)
197 (sb!xc
:defmacro define-signal-handler
(name what
&optional
(function 'error
))
198 `(defun ,name
(signal info context
)
199 (declare (ignore signal info
))
200 (declare (type system-area-pointer context
))
201 (/show
"in Lisp-level signal handler" ,(symbol-name name
)
204 (,function
,(concatenate 'simple-string what
" at #X~X")
205 (with-alien ((context (* os-context-t
) context
))
206 (sap-int (sb!vm
:context-pc context
))))))))
208 (define-signal-handler sigill-handler
"illegal instruction")
209 #!-
(or linux android
)
210 (define-signal-handler sigemt-handler
"SIGEMT")
211 (define-signal-handler sigbus-handler
"bus error")
212 #!-
(or linux android
)
213 (define-signal-handler sigsys-handler
"bad argument to a system call")
215 (defun sigint-handler (signal info
216 sb
!kernel
:*current-internal-error-context
*)
217 (declare (ignore signal info
))
218 (flet ((interrupt-it ()
219 ;; SB!KERNEL:*CURRENT-INTERNAL-ERROR-CONTEXT* will
220 ;; either be bound in this thread by SIGINT-HANDLER or
221 ;; in the target thread by SIGPIPE-HANDLER.
222 (with-alien ((context (* os-context-t
)
223 sb
!kernel
:*current-internal-error-context
*))
225 (let ((int (make-condition 'interactive-interrupt
227 :address
(sap-int (sb!vm
:context-pc context
)))))
228 ;; First SIGNAL, so that handlers can run.
230 ;; Then enter the debugger like BREAK.
231 (%break
'sigint int
))))))
233 (let ((target (sb!thread
::foreground-thread
)))
234 ;; Note that INTERRUPT-THREAD on *CURRENT-THREAD* doesn't actually
235 ;; interrupt right away, because deferrables are blocked. Rather,
236 ;; the kernel would arrange for the SIGPIPE to hit when the SIGINT
237 ;; handler is done. However, on safepoint builds, we don't use
238 ;; SIGPIPE and lack an appropriate mechanism to handle pending
239 ;; thruptions upon exit from signal handlers (and this situation is
240 ;; unlike WITHOUT-INTERRUPTS, which handles pending interrupts
241 ;; explicitly at the end). Only as long as safepoint builds pretend
242 ;; to cooperate with signals -- that is, as long as SIGINT-HANDLER
243 ;; is used at all -- detect this situation and work around it.
244 (if (eq target sb
!thread
:*current-thread
*)
246 (sb!thread
:interrupt-thread target
#'interrupt-it
)))
248 (sb!thread
:interrupt-thread
(sb!thread
::foreground-thread
)
252 (defun sigalrm-handler (signal info context
)
253 (declare (ignore signal info context
))
254 (declare (type system-area-pointer context
))
255 (sb!impl
::run-expired-timers
))
257 (defun sigterm-handler (signal code context
)
258 (declare (ignore signal code context
))
262 ;;; SIGPIPE is not used in SBCL for its original purpose, instead it's
263 ;;; for signalling a thread that it should look at its interruption
264 ;;; queue. The handler (RUN_INTERRUPTION) just returns if there is
265 ;;; nothing to do so it's safe to receive spurious SIGPIPEs coming
267 (defun sigpipe-handler (signal code sb
!kernel
:*current-internal-error-context
*)
268 (declare (ignore signal code
))
269 (sb!thread
::run-interruption
))
271 ;;; the handler for SIGCHLD signals for RUN-PROGRAM
272 (defun sigchld-handler (signal code context
)
273 (declare (ignore signal code context
))
274 (sb!impl
::get-processes-status-changes
))
276 (defun sb!kernel
:signal-cold-init-or-reinit
()
277 "Enable all the default signals that Lisp knows how to deal with."
278 (enable-interrupt sigint
#'sigint-handler
)
279 (enable-interrupt sigterm
#'sigterm-handler
)
280 (enable-interrupt sigill
#'sigill-handler
:synchronous t
)
281 #!-
(or linux android
)
282 (enable-interrupt sigemt
#'sigemt-handler
)
283 (enable-interrupt sigfpe
#'sb
!vm
:sigfpe-handler
:synchronous t
)
284 (if (/= (extern-alien "install_sig_memory_fault_handler" int
) 0)
285 (enable-interrupt sigbus
#'sigbus-handler
:synchronous t
)
286 (write-string ";;;; SIGBUS handler not installed
288 #!-
(or linux android
)
289 (enable-interrupt sigsys
#'sigsys-handler
:synchronous t
)
291 (enable-interrupt sigalrm
#'sigalrm-handler
)
293 (enable-interrupt sigpipe
#'sigpipe-handler
)
294 (enable-interrupt sigchld
#'sigchld-handler
)
295 #!+hpux
(ignore-interrupt sigxcpu
)
296 #!-sb-safepoint
(unblock-gc-signals)
297 (unblock-deferrable-signals)
302 ;;; extract si_code from siginfo_t
303 (define-alien-routine ("siginfo_code" siginfo-code
) int
304 (info system-area-pointer
))
307 ;;; Magically converted by the compiler into a break instruction.
308 (defun receive-pending-interrupt ()
309 (receive-pending-interrupt))