1.0.21.35: fix build / SAVE-LISP-AND-DIE on non-GENCGC platforms
[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   (with-unique-names (empty)
16     `(let*
17          ;; KLUDGE: Whatever is on the PCL stacks before the interrupt
18          ;; handler runs doesn't really matter, since we're not on the
19          ;; same call stack, really -- and if we don't bind these (esp.
20          ;; the cache one) we can get a bogus metacircle if an interrupt
21          ;; handler calls a GF that was being computed when the interrupt
22          ;; hit.
23          ((sb!pcl::*cache-miss-values-stack* nil)
24           (sb!pcl::*dfun-miss-gfs-on-stack* nil)
25           ;; Unless we do this, ADJUST-ARRAY and SORT would need to
26           ;; disable interrupts.
27           (,empty (vector))
28           (sb!impl::*zap-array-data-temp* ,empty)
29           (sb!impl::*merge-sort-temp-vector* ,empty))
30        ,@body)))
31
32 (defun invoke-interruption (function)
33   (without-interrupts
34     (with-interrupt-bindings
35       ;; Reset signal mask: the C-side handler has blocked all
36       ;; deferrable interrupts before arranging return to lisp. This is
37       ;; safe because we can't get a pending interrupt before we unblock
38       ;; signals.
39       ;;
40       ;; FIXME: Should we not reset the _entire_ mask, but just
41       ;; restore it to the state before we got the interrupt?
42       (reset-signal-mask)
43       (let ((sb!debug:*stack-top-hint* (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
44         (allow-with-interrupts (funcall function))))))
45
46 (defmacro in-interruption ((&key) &body body)
47   #!+sb-doc
48   "Convenience macro on top of INVOKE-INTERRUPTION."
49   `(dx-flet ((interruption () ,@body))
50      (invoke-interruption #'interruption)))
51 \f
52 ;;;; system calls that deal with signals
53
54 ;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
55 ;;; should be a valid signal number
56 #!-sb-fluid (declaim (inline real-unix-kill))
57 (sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
58   (pid sb!alien:int)
59   (signal sb!alien:int))
60
61 ;;; Send the signal SIGNAL to the all the process in process group
62 ;;; PGRP. SIGNAL should be a valid signal number
63 #!-sb-fluid (declaim (inline real-unix-killpg))
64 (sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
65   (pgrp sb!alien:int)
66   (signal sb!alien:int))
67
68 ;;; Reset the current set of masked signals (those being blocked from
69 ;;; delivery).
70 ;;;
71 ;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
72 ;;; operator to create masks, but since we only ever reset to 0, we no
73 ;;; longer support it. If you need it, you can pull it out of the CMU
74 ;;; CL sources, or the old SBCL sources; but you might also consider
75 ;;; doing things the SBCL way and moving this kind of C-level work
76 ;;; down to C wrapper functions.)
77
78 ;;; When inappropriate build options are used, this also prints messages
79 ;;; listing the signals that were masked
80 (sb!alien:define-alien-routine "reset_signal_mask" sb!alien:void)
81
82 \f
83 ;;;; C routines that actually do all the work of establishing signal handlers
84 (sb!alien:define-alien-routine ("install_handler" install-handler)
85                                sb!alien:unsigned-long
86   (signal sb!alien:int)
87   (handler sb!alien:unsigned-long))
88
89 ;;;; interface to enabling and disabling signal handlers
90
91 (defun enable-interrupt (signal handler)
92   (declare (type (or function fixnum (member :default :ignore)) handler))
93   (/show0 "enable-interrupt")
94   (flet ((run-handler (&rest args)
95            (declare (truly-dynamic-extent args))
96            (in-interruption ()
97              (apply handler args))))
98     (without-gcing
99       (let ((result (install-handler signal
100                                      (case handler
101                                        (:default sig-dfl)
102                                        (:ignore sig-ign)
103                                        (t
104                                         (sb!kernel:get-lisp-obj-address
105                                          #'run-handler))))))
106         (cond ((= result sig-dfl) :default)
107               ((= result sig-ign) :ignore)
108               (t (the (or function fixnum)
109                    (sb!kernel:make-lisp-obj result))))))))
110
111 (defun default-interrupt (signal)
112   (enable-interrupt signal :default))
113
114 (defun ignore-interrupt (signal)
115   (enable-interrupt signal :ignore))
116 \f
117 ;;;; default LISP signal handlers
118 ;;;;
119 ;;;; Most of these just call ERROR to report the presence of the signal.
120
121 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
122 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
123 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
124 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
125 (eval-when (:compile-toplevel :execute)
126   (sb!xc:defmacro define-signal-handler (name what &optional (function 'error))
127     `(defun ,name (signal info context)
128        (declare (ignore signal info))
129        (declare (type system-area-pointer context))
130        (/show "in Lisp-level signal handler" ,(symbol-name name)
131               (sap-int context))
132        (with-interrupts
133          (,function ,(concatenate 'simple-string what " at #X~X")
134                     (with-alien ((context (* os-context-t) context))
135                       (sap-int (sb!vm:context-pc context))))))))
136
137 (define-signal-handler sigill-handler "illegal instruction")
138 #!-linux
139 (define-signal-handler sigemt-handler "SIGEMT")
140 (define-signal-handler sigbus-handler "bus error")
141 (define-signal-handler sigsegv-handler "segmentation violation")
142 #!-linux
143 (define-signal-handler sigsys-handler "bad argument to a system call")
144
145 (defun sigint-handler (signal info context)
146   (declare (ignore signal info))
147   (declare (type system-area-pointer context))
148   (/show "in Lisp-level SIGINT handler" (sap-int context))
149   (flet ((interrupt-it ()
150            (with-alien ((context (* os-context-t) context))
151              (%break 'sigint 'interactive-interrupt
152                      :context context
153                      :address (sap-int (sb!vm:context-pc context))))))
154     (sb!thread:interrupt-thread (sb!thread::foreground-thread)
155                                 #'interrupt-it)))
156
157 (defun sigalrm-handler (signal info context)
158   (declare (ignore signal info context))
159   (declare (type system-area-pointer context))
160   (sb!impl::run-expired-timers))
161
162 (defun sigterm-handler (signal code context)
163   (declare (ignore signal code context))
164   (sb!thread::terminate-session)
165   (sb!ext:quit))
166
167 ;; Also known as SIGABRT.
168 (defun sigiot-handler (signal code context)
169   (declare (ignore signal code context))
170   (sb!impl::%halt))
171
172 (defun sb!kernel:signal-cold-init-or-reinit ()
173   #!+sb-doc
174   "Enable all the default signals that Lisp knows how to deal with."
175   (enable-interrupt sigint #'sigint-handler)
176   (enable-interrupt sigterm #'sigterm-handler)
177   (enable-interrupt sigill #'sigill-handler)
178   (enable-interrupt sigiot #'sigiot-handler)
179   #!-linux
180   (enable-interrupt sigemt #'sigemt-handler)
181   (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
182   (enable-interrupt sigbus #'sigbus-handler)
183   (enable-interrupt sigsegv #'sigsegv-handler)
184   #!-linux
185   (enable-interrupt sigsys #'sigsys-handler)
186   (ignore-interrupt sigpipe)
187   (enable-interrupt sigalrm #'sigalrm-handler)
188   (sb!unix::reset-signal-mask)
189   (values))
190 \f
191 ;;;; etc.
192
193 ;;; extract si_code from siginfo_t
194 (sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int
195   (info system-area-pointer))
196
197 ;;; CMU CL comment:
198 ;;;   Magically converted by the compiler into a break instruction.
199 (defun receive-pending-interrupt ()
200   (receive-pending-interrupt))