1.0.27.39: SIGCHLD related fixes
[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 ;;; Evaluate CLEANUP-FORMS iff PROTECTED-FORM does a non-local exit.
33 (defmacro nlx-protect (protected-form &rest cleanup-froms)
34   (with-unique-names (completep)
35     `(let ((,completep nil))
36        (without-interrupts
37          (unwind-protect
38               (progn
39                 (allow-with-interrupts
40                   ,protected-form)
41                 (setq ,completep t))
42            (unless ,completep
43              ,@cleanup-froms))))))
44
45 (defun invoke-interruption (function)
46   (without-interrupts
47     ;; Reset signal mask: the C-side handler has blocked all
48     ;; deferrable signals before funcalling into lisp. They are to be
49     ;; unblocked the first time interrupts are enabled. With this
50     ;; mechanism there are no extra frames on the stack from a
51     ;; previous signal handler when the next signal is delivered
52     ;; provided there is no WITH-INTERRUPTS.
53     (let ((*unblock-deferrables-on-enabling-interrupts-p* t))
54       (with-interrupt-bindings
55         (let ((sb!debug:*stack-top-hint*
56                (nth-value 1 (sb!kernel:find-interrupted-name-and-frame))))
57           (allow-with-interrupts
58             (nlx-protect (funcall function)
59                          ;; We've been running with deferrables
60                          ;; blocked in Lisp called by a C signal
61                          ;; handler. If we return normally the sigmask
62                          ;; in the interrupted context is restored.
63                          ;; However, if we do an nlx the operating
64                          ;; system will not restore it for us.
65                          (when *unblock-deferrables-on-enabling-interrupts-p*
66                            ;; This means that storms of interrupts
67                            ;; doing an nlx can still run out of stack.
68                            (unblock-deferrable-signals)))))))))
69
70 (defmacro in-interruption ((&key) &body body)
71   #!+sb-doc
72   "Convenience macro on top of INVOKE-INTERRUPTION."
73   `(dx-flet ((interruption () ,@body))
74      (invoke-interruption #'interruption)))
75 \f
76 ;;;; system calls that deal with signals
77
78 ;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
79 ;;; should be a valid signal number
80 #!-sb-fluid (declaim (inline real-unix-kill))
81 (sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
82   (pid sb!alien:int)
83   (signal sb!alien:int))
84
85 ;;; Send the signal SIGNAL to the all the process in process group
86 ;;; PGRP. SIGNAL should be a valid signal number
87 #!-sb-fluid (declaim (inline real-unix-killpg))
88 (sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
89   (pgrp sb!alien:int)
90   (signal sb!alien:int))
91
92 ;;; Reset the current set of masked signals (those being blocked from
93 ;;; delivery).
94 ;;;
95 ;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
96 ;;; operator to create masks, but since we only ever reset to 0, we no
97 ;;; longer support it. If you need it, you can pull it out of the CMU
98 ;;; CL sources, or the old SBCL sources; but you might also consider
99 ;;; doing things the SBCL way and moving this kind of C-level work
100 ;;; down to C wrapper functions.)
101
102 (declaim (inline %unblock-deferrable-signals %unblock-gc-signals))
103 (sb!alien:define-alien-routine ("unblock_deferrable_signals"
104                                 %unblock-deferrable-signals)
105     sb!alien:void
106   (where sb!alien:unsigned-long)
107   (old sb!alien:unsigned-long))
108 (sb!alien:define-alien-routine ("unblock_gc_signals" %unblock-gc-signals)
109     sb!alien:void
110   (where sb!alien:unsigned-long)
111   (old sb!alien:unsigned-long))
112
113 (defun unblock-deferrable-signals ()
114   (%unblock-deferrable-signals 0 0))
115
116 (defun unblock-gc-signals ()
117   (%unblock-gc-signals 0 0))
118
119 \f
120 ;;;; C routines that actually do all the work of establishing signal handlers
121 (sb!alien:define-alien-routine ("install_handler" install-handler)
122                                sb!alien:unsigned-long
123   (signal sb!alien:int)
124   (handler sb!alien:unsigned-long))
125
126 ;;;; interface to enabling and disabling signal handlers
127
128 (defun enable-interrupt (signal handler)
129   (declare (type (or function fixnum (member :default :ignore)) handler))
130   (/show0 "enable-interrupt")
131   (flet ((run-handler (&rest args)
132            (declare (truly-dynamic-extent args))
133            (in-interruption ()
134              (apply handler args))))
135     (without-gcing
136       (let ((result (install-handler signal
137                                      (case handler
138                                        (:default sig-dfl)
139                                        (:ignore sig-ign)
140                                        (t
141                                         (sb!kernel:get-lisp-obj-address
142                                          #'run-handler))))))
143         (cond ((= result sig-dfl) :default)
144               ((= result sig-ign) :ignore)
145               (t (the (or function fixnum)
146                    (sb!kernel:make-lisp-obj result))))))))
147
148 (defun default-interrupt (signal)
149   (enable-interrupt signal :default))
150
151 (defun ignore-interrupt (signal)
152   (enable-interrupt signal :ignore))
153 \f
154 ;;;; default LISP signal handlers
155 ;;;;
156 ;;;; Most of these just call ERROR to report the presence of the signal.
157
158 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
159 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
160 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
161 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
162 (eval-when (:compile-toplevel :execute)
163   (sb!xc:defmacro define-signal-handler (name what &optional (function 'error))
164     `(defun ,name (signal info context)
165        (declare (ignore signal info))
166        (declare (type system-area-pointer context))
167        (/show "in Lisp-level signal handler" ,(symbol-name name)
168               (sap-int context))
169        (with-interrupts
170          (,function ,(concatenate 'simple-string what " at #X~X")
171                     (with-alien ((context (* os-context-t) context))
172                       (sap-int (sb!vm:context-pc context))))))))
173
174 (define-signal-handler sigill-handler "illegal instruction")
175 #!-linux
176 (define-signal-handler sigemt-handler "SIGEMT")
177 (define-signal-handler sigbus-handler "bus error")
178 #!-linux
179 (define-signal-handler sigsys-handler "bad argument to a system call")
180
181 (defun sigint-handler (signal info context)
182   (declare (ignore signal info))
183   (declare (type system-area-pointer context))
184   (/show "in Lisp-level SIGINT handler" (sap-int context))
185   (flet ((interrupt-it ()
186            (with-alien ((context (* os-context-t) context))
187              (with-interrupts
188                (%break 'sigint 'interactive-interrupt
189                        :context context
190                        :address (sap-int (sb!vm:context-pc context)))))))
191     (sb!thread:interrupt-thread (sb!thread::foreground-thread)
192                                 #'interrupt-it)))
193
194 (defun sigalrm-handler (signal info context)
195   (declare (ignore signal info context))
196   (declare (type system-area-pointer context))
197   (sb!impl::run-expired-timers))
198
199 (defun sigterm-handler (signal code context)
200   (declare (ignore signal code context))
201   (sb!thread::terminate-session)
202   (sb!ext:quit))
203
204 ;;; SIGPIPE is not used in SBCL for its original purpose, instead it's
205 ;;; for signalling a thread that it should look at its interruption
206 ;;; queue. The handler (RUN_INTERRUPTION) just returns if there is
207 ;;; nothing to do so it's safe to receive spurious SIGPIPEs coming
208 ;;; from the kernel.
209 (defun sigpipe-handler (signal code context)
210   (declare (ignore signal code context))
211   (sb!thread::run-interruption))
212
213 ;;; the handler for SIGCHLD signals for RUN-PROGRAM
214 (defun sigchld-handler  (signal code context)
215   (declare (ignore signal code context))
216   (sb!impl::get-processes-status-changes))
217
218 (defun sb!kernel:signal-cold-init-or-reinit ()
219   #!+sb-doc
220   "Enable all the default signals that Lisp knows how to deal with."
221   (enable-interrupt sigint #'sigint-handler)
222   (enable-interrupt sigterm #'sigterm-handler)
223   (enable-interrupt sigill #'sigill-handler)
224   #!-linux
225   (enable-interrupt sigemt #'sigemt-handler)
226   (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
227   (enable-interrupt sigbus #'sigbus-handler)
228   #!-linux
229   (enable-interrupt sigsys #'sigsys-handler)
230   (enable-interrupt sigalrm #'sigalrm-handler)
231   (enable-interrupt sigpipe #'sigpipe-handler)
232   (enable-interrupt sigchld #'sigchld-handler)
233   #!+hpux (ignore-interrupt sigxcpu)
234   (unblock-gc-signals)
235   (unblock-deferrable-signals)
236   (values))
237 \f
238 ;;;; etc.
239
240 ;;; extract si_code from siginfo_t
241 (sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int
242   (info system-area-pointer))
243
244 ;;; CMU CL comment:
245 ;;;   Magically converted by the compiler into a break instruction.
246 (defun receive-pending-interrupt ()
247   (receive-pending-interrupt))