0.9.15.31: RUN-PROGRAM win32 patch
[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 (defun invoke-interruption (function)
15   (without-interrupts
16     (sb!unix::reset-signal-mask)
17     (funcall function)))
18
19 (defmacro in-interruption ((&rest args) &body body)
20   #!+sb-doc
21   "Convenience macro on top of INVOKE-INTERRUPTION."
22   `(invoke-interruption (lambda () ,@body) ,@args))
23
24 ;;; These should probably be somewhere, but I don't know where.
25 (defconstant sig_dfl 0)
26 (defconstant sig_ign 1)
27 \f
28 ;;;; system calls that deal with signals
29
30 ;;; Send the signal SIGNAL to the process with process id PID. SIGNAL
31 ;;; should be a valid signal number
32 #!-sb-fluid (declaim (inline real-unix-kill))
33 (sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int
34   (pid sb!alien:int)
35   (signal sb!alien:int))
36
37 ;;; Send the signal SIGNAL to the all the process in process group
38 ;;; PGRP. SIGNAL should be a valid signal number
39 #!-sb-fluid (declaim (inline real-unix-killpg))
40 (sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int
41   (pgrp sb!alien:int)
42   (signal sb!alien:int))
43
44 ;;; Reset the current set of masked signals (those being blocked from
45 ;;; delivery).
46 ;;;
47 ;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK
48 ;;; operator to create masks, but since we only ever reset to 0, we no
49 ;;; longer support it. If you need it, you can pull it out of the CMU
50 ;;; CL sources, or the old SBCL sources; but you might also consider
51 ;;; doing things the SBCL way and moving this kind of C-level work
52 ;;; down to C wrapper functions.)
53
54 ;;; When inappropriate build options are used, this also prints messages
55 ;;; listing the signals that were masked
56 (sb!alien:define-alien-routine "reset_signal_mask" sb!alien:void)
57
58 \f
59 ;;;; C routines that actually do all the work of establishing signal handlers
60 (sb!alien:define-alien-routine ("install_handler" install-handler)
61                                sb!alien:unsigned-long
62   (signal sb!alien:int)
63   (handler sb!alien:unsigned-long))
64
65 ;;;; interface to enabling and disabling signal handlers
66
67 (defun enable-interrupt (signal handler)
68   (declare (type (or function fixnum (member :default :ignore)) handler))
69   (/show0 "enable-interrupt")
70   (flet ((run-handler (&rest args)
71            (in-interruption ()
72              (apply handler args))))
73     (without-gcing
74       (let ((result (install-handler signal
75                                      (case handler
76                                        (:default sig_dfl)
77                                        (:ignore sig_ign)
78                                        (t
79                                         (sb!kernel:get-lisp-obj-address
80                                          #'run-handler))))))
81         (cond ((= result sig_dfl) :default)
82               ((= result sig_ign) :ignore)
83               (t (the (or function fixnum)
84                    (sb!kernel:make-lisp-obj result))))))))
85
86 (defun default-interrupt (signal)
87   (enable-interrupt signal :default))
88
89 (defun ignore-interrupt (signal)
90   (enable-interrupt signal :ignore))
91 \f
92 ;;;; default LISP signal handlers
93 ;;;;
94 ;;;; Most of these just call ERROR to report the presence of the signal.
95
96 ;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores
97 ;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that
98 ;;; SIGINT in --disable-debugger mode will cleanly terminate the system
99 ;;; (by respecting the *DEBUGGER-HOOK* established in that mode).
100 (defun sigint-%break (format-string &rest format-arguments)
101   (flet ((break-it ()
102            (apply #'%break 'sigint format-string format-arguments)))
103     (sb!thread:interrupt-thread (sb!thread::foreground-thread) #'break-it)))
104
105 (eval-when (:compile-toplevel :execute)
106   (sb!xc:defmacro define-signal-handler (name
107                                          what
108                                          &optional (function 'error))
109     `(defun ,name (signal info context)
110        (declare (ignore signal info))
111        (declare (type system-area-pointer context))
112        (/show "in Lisp-level signal handler" ,(symbol-name name)
113               (sap-int context))
114        (with-interrupts
115          (,function ,(concatenate 'simple-string what " at #X~X")
116                     (with-alien ((context (* os-context-t) context))
117                       (sap-int (sb!vm:context-pc context))))))))
118
119 (define-signal-handler sigint-handler "interrupted" sigint-%break)
120 (define-signal-handler sigill-handler "illegal instruction")
121 (define-signal-handler sigtrap-handler "breakpoint/trap")
122 #!-linux
123 (define-signal-handler sigemt-handler "SIGEMT")
124 (define-signal-handler sigbus-handler "bus error")
125 (define-signal-handler sigsegv-handler "segmentation violation")
126 #!-linux
127 (define-signal-handler sigsys-handler "bad argument to a system call")
128
129 (defun sigalrm-handler (signal info context)
130   (declare (ignore signal info context))
131   (declare (type system-area-pointer context))
132   (sb!impl::run-expired-timers))
133
134 (defun sigterm-handler (signal code context)
135   (declare (ignore signal code context))
136   (sb!thread::terminate-session)
137   (sb!ext:quit))
138
139 ;; Also known as SIGABRT.
140 (defun sigiot-handler (signal code context)
141   (declare (ignore signal code context))
142   (sb!impl::%halt))
143
144 (defun sb!kernel:signal-cold-init-or-reinit ()
145   #!+sb-doc
146   "Enable all the default signals that Lisp knows how to deal with."
147   (enable-interrupt sigint #'sigint-handler)
148   (enable-interrupt sigterm #'sigterm-handler)
149   (enable-interrupt sigill #'sigill-handler)
150   (enable-interrupt sigtrap #'sigtrap-handler)
151   (enable-interrupt sigiot #'sigiot-handler)
152   #!-linux
153   (enable-interrupt sigemt #'sigemt-handler)
154   (enable-interrupt sigfpe #'sb!vm:sigfpe-handler)
155   (enable-interrupt sigbus #'sigbus-handler)
156   (enable-interrupt sigsegv #'sigsegv-handler)
157   #!-linux
158   (enable-interrupt sigsys #'sigsys-handler)
159   (ignore-interrupt sigpipe)
160   (enable-interrupt sigalrm #'sigalrm-handler)
161   (sb!unix::reset-signal-mask)
162   (values))
163 \f
164 ;;;; etc.
165
166 ;;; CMU CL comment:
167 ;;;   Magically converted by the compiler into a break instruction.
168 (defun receive-pending-interrupt ()
169   (receive-pending-interrupt))
170 \f
171 ;;; stale code which I'm insufficiently motivated to test -- WHN 19990714
172 #|
173 ;;;; WITH-ENABLED-INTERRUPTS
174
175 (defmacro with-enabled-interrupts (interrupt-list &body body)
176   #!+sb-doc
177   "With-enabled-interrupts ({(interrupt function)}*) {form}*
178    Establish function as a handler for the Unix signal interrupt which
179    should be a number between 1 and 31 inclusive."
180   (let ((il (gensym))
181         (it (gensym)))
182     `(let ((,il NIL))
183        (unwind-protect
184            (progn
185              ,@(do* ((item interrupt-list (cdr item))
186                      (intr (caar item) (caar item))
187                      (ifcn (cadar item) (cadar item))
188                      (forms NIL))
189                     ((null item) (nreverse forms))
190                  (when (symbolp intr)
191                    (setq intr (symbol-value intr)))
192                  (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il)
193                        forms))
194              ,@body)
195          (dolist (,it (nreverse ,il))
196            (enable-interrupt (car ,it) (cadr ,it)))))))
197 |#