X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-signal.lisp;h=a59e7309625f5654d8956582f4c52138682a393e;hb=c548f73e8dd676d6ec4576eba6ab661a5061bdfe;hp=04ba6746562bf1e8da5946c2af52c64dfb0d21ac;hpb=53e7a02c819090af8e6db7e47d29cdbb5296814f;p=sbcl.git diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index 04ba674..a59e730 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -11,80 +11,80 @@ (in-package "SB!UNIX") -;;; These should probably be somewhere, but I don't know where. -(defconstant sig_dfl 0) -(defconstant sig_ign 1) +(defun invoke-interruption (function) + (without-interrupts + ;; Reset signal mask: the C-side handler has blocked all + ;; deferrable interrupts before arranging return to lisp. This is + ;; safe because we can't get a pending interrupt before we unblock + ;; signals. + ;; + ;; FIXME: Should we not reset the _entire_ mask, just restore it + ;; to the state before we got the interrupt? + (reset-signal-mask) + (allow-with-interrupts (funcall function)))) + +(defmacro in-interruption ((&rest args) &body body) + #!+sb-doc + "Convenience macro on top of INVOKE-INTERRUPTION." + `(invoke-interruption (lambda () ,@body) ,@args)) ;;;; system calls that deal with signals +;;; Send the signal SIGNAL to the process with process id PID. SIGNAL +;;; should be a valid signal number #!-sb-fluid (declaim (inline real-unix-kill)) -(sb!alien:def-alien-routine ("kill" real-unix-kill) sb!c-call:int - (pid sb!c-call:int) - (signal sb!c-call:int)) - -(defun unix-kill (pid signal) - #!+sb-doc - "Unix-kill sends the signal signal to the process with process - id pid. Signal should be a valid signal number or a keyword of the - standard UNIX signal name." - (real-unix-kill pid (unix-signal-number signal))) +(sb!alien:define-alien-routine ("kill" unix-kill) sb!alien:int + (pid sb!alien:int) + (signal sb!alien:int)) +;;; Send the signal SIGNAL to the all the process in process group +;;; PGRP. SIGNAL should be a valid signal number #!-sb-fluid (declaim (inline real-unix-killpg)) -(sb!alien:def-alien-routine ("killpg" real-unix-killpg) sb!c-call:int - (pgrp sb!c-call:int) - (signal sb!c-call:int)) - -(defun unix-killpg (pgrp signal) - #!+sb-doc - "Unix-killpg sends the signal signal to the all the process in process - group PGRP. Signal should be a valid signal number or a keyword of - the standard UNIX signal name." - (real-unix-killpg pgrp (unix-signal-number signal))) - -(sb!alien:def-alien-routine ("sigblock" unix-sigblock) sb!c-call:unsigned-long - #!+sb-doc - "Unix-sigblock cause the signals specified in mask to be - added to the set of signals currently being blocked from - delivery. The macro sigmask is provided to create masks." - (mask sb!c-call:unsigned-long)) - -(sb!alien:def-alien-routine ("sigpause" unix-sigpause) sb!c-call:void - #!+sb-doc - "Unix-sigpause sets the set of masked signals to its argument - and then waits for a signal to arrive, restoring the previous - mask upon its return." - (mask sb!c-call:unsigned-long)) +(sb!alien:define-alien-routine ("killpg" unix-killpg) sb!alien:int + (pgrp sb!alien:int) + (signal sb!alien:int)) + +;;; Reset the current set of masked signals (those being blocked from +;;; delivery). +;;; +;;; (Note: CMU CL had a more general SIGSETMASK call and a SIGMASK +;;; operator to create masks, but since we only ever reset to 0, we no +;;; longer support it. If you need it, you can pull it out of the CMU +;;; CL sources, or the old SBCL sources; but you might also consider +;;; doing things the SBCL way and moving this kind of C-level work +;;; down to C wrapper functions.) + +;;; When inappropriate build options are used, this also prints messages +;;; listing the signals that were masked +(sb!alien:define-alien-routine "reset_signal_mask" sb!alien:void) -(sb!alien:def-alien-routine ("sigsetmask" unix-sigsetmask) - sb!c-call:unsigned-long - #!+sb-doc - "Unix-sigsetmask sets the current set of masked signals (those - begin blocked from delivery) to the argument. The macro sigmask - can be used to create the mask. The previous value of the signal - mask is returned." - (mask sb!c-call:unsigned-long)) ;;;; C routines that actually do all the work of establishing signal handlers -(sb!alien:def-alien-routine ("install_handler" install-handler) - sb!c-call:unsigned-long - (signal sb!c-call:int) - (handler sb!c-call:unsigned-long)) - +(sb!alien:define-alien-routine ("install_handler" install-handler) + sb!alien:unsigned-long + (signal sb!alien:int) + (handler sb!alien:unsigned-long)) + ;;;; interface to enabling and disabling signal handlers -(defun enable-interrupt (signal-designator handler) - (declare (type (or function (member :default :ignore)) handler)) - (without-gcing - (let ((result (install-handler (unix-signal-number signal-designator) - (case handler - (:default sig_dfl) - (:ignore sig_ign) - (t - (sb!kernel:get-lisp-obj-address - handler)))))) - (cond ((= result sig_dfl) :default) - ((= result sig_ign) :ignore) - (t (the function (sb!kernel:make-lisp-obj result))))))) +(defun enable-interrupt (signal handler) + (declare (type (or function fixnum (member :default :ignore)) handler)) + (/show0 "enable-interrupt") + (flet ((run-handler (&rest args) + (in-interruption () + (apply handler args)))) + (without-gcing + (let ((result (install-handler signal + (case handler + (:default sig-dfl) + (:ignore sig-ign) + (t + (sb!kernel:get-lisp-obj-address + #'run-handler)))))) + (cond ((= result sig-dfl) :default) + ((= result sig-ign) :ignore) + (t (the (or function fixnum) + (sb!kernel:make-lisp-obj result)))))))) (defun default-interrupt (signal) (enable-interrupt signal :default)) @@ -96,78 +96,83 @@ ;;;; ;;;; Most of these just call ERROR to report the presence of the signal. +;;; SIGINT is handled like BREAK, except that ANSI BREAK ignores +;;; *DEBUGGER-HOOK*, but we want SIGINT's BREAK to respect it, so that +;;; SIGINT in --disable-debugger mode will cleanly terminate the system +;;; (by respecting the *DEBUGGER-HOOK* established in that mode). (eval-when (:compile-toplevel :execute) - (sb!xc:defmacro define-signal-handler (name - what - &optional (function 'error)) + (sb!xc:defmacro define-signal-handler (name what &optional (function 'error)) `(defun ,name (signal info context) (declare (ignore signal info)) (declare (type system-area-pointer context)) - (/show "in Lisp-level signal handler" (sap-int context)) - (,function ,(concatenate 'simple-string what " at #X~X") - (with-alien ((context (* os-context-t) context)) - (sap-int (sb!vm:context-pc context))))))) + (/show "in Lisp-level signal handler" ,(symbol-name name) + (sap-int context)) + (with-interrupts + (,function ,(concatenate 'simple-string what " at #X~X") + (with-alien ((context (* os-context-t) context)) + (sap-int (sb!vm:context-pc context)))))))) -(define-signal-handler sigint-handler "interrupted" break) (define-signal-handler sigill-handler "illegal instruction") -(define-signal-handler sigtrap-handler "breakpoint/trap") -(define-signal-handler sigiot-handler "SIGIOT") #!-linux (define-signal-handler sigemt-handler "SIGEMT") (define-signal-handler sigbus-handler "bus error") (define-signal-handler sigsegv-handler "segmentation violation") #!-linux (define-signal-handler sigsys-handler "bad argument to a system call") -(define-signal-handler sigpipe-handler "SIGPIPE") -(define-signal-handler sigalrm-handler "SIGALRM") -(defun sigquit-handler (signal code context) +(defun sigint-handler (signal info context) + (declare (ignore signal info)) + (declare (type system-area-pointer context)) + (/show "in Lisp-level SIGINT handler" (sap-int context)) + (flet ((interrupt-it () + (with-alien ((context (* os-context-t) context)) + (%break 'sigint 'interactive-interrupt + :context context + :address (sap-int (sb!vm:context-pc context)))))) + (sb!thread:interrupt-thread (sb!thread::foreground-thread) + #'interrupt-it))) + +(defun sigalrm-handler (signal info context) + (declare (ignore signal info context)) + (declare (type system-area-pointer context)) + (sb!impl::run-expired-timers)) + +(defun sigterm-handler (signal code context) (declare (ignore signal code context)) - (throw 'sb!impl::top-level-catcher nil)) + (sb!thread::terminate-session) + (sb!ext:quit)) + +;; Also known as SIGABRT. +(defun sigiot-handler (signal code context) + (declare (ignore signal code context)) + (sb!impl::%halt)) (defun sb!kernel:signal-cold-init-or-reinit () #!+sb-doc "Enable all the default signals that Lisp knows how to deal with." - (enable-interrupt :sigint #'sigint-handler) - (enable-interrupt :sigquit #'sigquit-handler) - (enable-interrupt :sigill #'sigill-handler) - (enable-interrupt :sigtrap #'sigtrap-handler) - (enable-interrupt :sigiot #'sigiot-handler) + (enable-interrupt sigint #'sigint-handler) + (enable-interrupt sigterm #'sigterm-handler) + (enable-interrupt sigill #'sigill-handler) + (enable-interrupt sigiot #'sigiot-handler) #!-linux - (enable-interrupt :sigemt #'sigemt-handler) - (enable-interrupt :sigfpe #'sb!vm:sigfpe-handler) - (enable-interrupt :sigbus #'sigbus-handler) - (enable-interrupt :sigsegv #'sigsegv-handler) + (enable-interrupt sigemt #'sigemt-handler) + (enable-interrupt sigfpe #'sb!vm:sigfpe-handler) + (enable-interrupt sigbus #'sigbus-handler) + (enable-interrupt sigsegv #'sigsegv-handler) #!-linux - (enable-interrupt :sigsys #'sigsys-handler) - (enable-interrupt :sigpipe #'sigpipe-handler) - (enable-interrupt :sigalrm #'sigalrm-handler) - nil) + (enable-interrupt sigsys #'sigsys-handler) + (ignore-interrupt sigpipe) + (enable-interrupt sigalrm #'sigalrm-handler) + (sb!unix::reset-signal-mask) + (values)) -;;; stale code which I'm insufficiently motivated to test -- WHN 19990714 -#| -;;;; WITH-ENABLED-INTERRUPTS +;;;; etc. -(defmacro with-enabled-interrupts (interrupt-list &body body) - #!+sb-doc - "With-enabled-interrupts ({(interrupt function)}*) {form}* - Establish function as a handler for the Unix signal interrupt which - should be a number between 1 and 31 inclusive." - (let ((il (gensym)) - (it (gensym))) - `(let ((,il NIL)) - (unwind-protect - (progn - ,@(do* ((item interrupt-list (cdr item)) - (intr (caar item) (caar item)) - (ifcn (cadar item) (cadar item)) - (forms NIL)) - ((null item) (nreverse forms)) - (when (symbolp intr) - (setq intr (symbol-value intr))) - (push `(push `(,,intr ,(enable-interrupt ,intr ,ifcn)) ,il) - forms)) - ,@body) - (dolist (,it (nreverse ,il)) - (enable-interrupt (car ,it) (cadr ,it))))))) -|# +;;; extract si_code from siginfo_t +(sb!alien:define-alien-routine ("siginfo_code" siginfo-code) sb!alien:int + (info system-area-pointer)) + +;;; CMU CL comment: +;;; Magically converted by the compiler into a break instruction. +(defun receive-pending-interrupt () + (receive-pending-interrupt))