X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-signal.lisp;h=ceffe0b15219858fc45be43e1abcfa64e684be9f;hb=bd4f596b07e3783992e00eae88afdc05ebe7c6a6;hp=5a43e1761afcf93e628669a39f4e25776813fb5d;hpb=75b52379bdc2269961af6a1308eca63610f38ac3;p=sbcl.git diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index 5a43e17..ceffe0b 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -11,6 +11,16 @@ (in-package "SB!UNIX") +(defun invoke-interruption (function) + (without-interrupts + (sb!unix::reset-signal-mask) + (funcall function))) + +(defmacro in-interruption ((&rest args) &body body) + #!+sb-doc + "Convenience macro on top of INVOKE-INTERRUPTION." + `(invoke-interruption (lambda () ,@body) ,@args)) + ;;; These should probably be somewhere, but I don't know where. (defconstant sig_dfl 0) (defconstant sig_ign 1) @@ -44,10 +54,11 @@ ;;; 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) + ;;;; C routines that actually do all the work of establishing signal handlers (sb!alien:define-alien-routine ("install_handler" install-handler) - sb!alien:unsigned-long + sb!alien:unsigned-long (signal sb!alien:int) (handler sb!alien:unsigned-long)) @@ -56,17 +67,21 @@ (defun enable-interrupt (signal handler) (declare (type (or function fixnum (member :default :ignore)) handler)) (/show0 "enable-interrupt") - (without-gcing - (let ((result (install-handler signal - (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 (or function fixnum) (sb!kernel:make-lisp-obj result))))))) + (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)) @@ -83,46 +98,54 @@ ;;; SIGINT in --disable-debugger mode will cleanly terminate the system ;;; (by respecting the *DEBUGGER-HOOK* established in that mode). (defun sigint-%break (format-string &rest format-arguments) - (apply #'%break 'sigint format-string format-arguments)) + (flet ((break-it () + (apply #'%break 'sigint format-string format-arguments))) + (sb!thread:interrupt-thread (sb!thread::foreground-thread) #'break-it))) (eval-when (:compile-toplevel :execute) (sb!xc:defmacro define-signal-handler (name - what - &optional (function 'error)) + 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" ,(symbol-name name) (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" sigint-%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") (defun sigalrm-handler (signal info context) (declare (ignore signal info context)) (declare (type system-area-pointer context)) - (cerror "Continue" 'sb!ext::timeout)) + (sb!impl::run-expired-timers)) -(defun sigquit-handler (signal code context) +(defun sigterm-handler (signal code context) (declare (ignore signal code context)) - (throw 'sb!impl::toplevel-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 sigterm #'sigterm-handler) (enable-interrupt sigill #'sigill-handler) (enable-interrupt sigtrap #'sigtrap-handler) (enable-interrupt sigiot #'sigiot-handler) @@ -133,12 +156,17 @@ (enable-interrupt sigsegv #'sigsegv-handler) #!-linux (enable-interrupt sigsys #'sigsys-handler) - (enable-interrupt sigpipe #'sigpipe-handler) + (ignore-interrupt sigpipe) (enable-interrupt sigalrm #'sigalrm-handler) + (sb!unix::reset-signal-mask) (values)) ;;;; etc. +;;; 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 () @@ -154,20 +182,20 @@ 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))) + (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))))))) + (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))))))) |#