X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Ftarget-signal.lisp;h=b660735a499c83a7222b099f554194b5e498f817;hb=a160917364f85b38dc0826a5e3dcef87e3c4c62c;hp=073b4c94a5b56d2cdea0d981e121b019b3b6f310;hpb=fe420bb47ea909070ee82c6e48642c9ff41dbcc8;p=sbcl.git diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index 073b4c9..b660735 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -29,20 +29,43 @@ (sb!impl::*merge-sort-temp-vector* ,empty)) ,@body))) +;;; Evaluate CLEANUP-FORMS iff PROTECTED-FORM does a non-local exit. +(defmacro nlx-protect (protected-form &rest cleanup-froms) + (with-unique-names (completep) + `(let ((,completep nil)) + (without-interrupts + (unwind-protect + (progn + (allow-with-interrupts + ,protected-form) + (setq ,completep t)) + (unless ,completep + ,@cleanup-froms)))))) + (defun invoke-interruption (function) - (with-interrupt-bindings - (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, but just - ;; restore it to the state before we got the interrupt? - (reset-signal-mask) - (allow-with-interrupts - (let ((sb!debug:*stack-top-hint* (nth-value 1 (sb!kernel:find-interrupted-name-and-frame)))) - (funcall function)))))) + (without-interrupts + ;; Reset signal mask: the C-side handler has blocked all + ;; deferrable signals before funcalling into lisp. They are to be + ;; unblocked the first time interrupts are enabled. With this + ;; mechanism there are no extra frames on the stack from a + ;; previous signal handler when the next signal is delivered + ;; provided there is no WITH-INTERRUPTS. + (let ((*unblock-deferrables-on-enabling-interrupts-p* t)) + (with-interrupt-bindings + (let ((sb!debug:*stack-top-hint* + (nth-value 1 (sb!kernel:find-interrupted-name-and-frame)))) + (allow-with-interrupts + (nlx-protect (funcall function) + ;; We've been running with deferrables + ;; blocked in Lisp called by a C signal + ;; handler. If we return normally the sigmask + ;; in the interrupted context is restored. + ;; However, if we do an nlx the operating + ;; system will not restore it for us. + (when *unblock-deferrables-on-enabling-interrupts-p* + ;; This means that storms of interrupts + ;; doing an nlx can still run out of stack. + (unblock-deferrable-signals))))))))) (defmacro in-interruption ((&key) &body body) #!+sb-doc @@ -76,9 +99,22 @@ ;;; 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) +(declaim (inline %unblock-deferrable-signals %unblock-gc-signals)) +(sb!alien:define-alien-routine ("unblock_deferrable_signals" + %unblock-deferrable-signals) + sb!alien:void + (where sb!alien:unsigned-long) + (old sb!alien:unsigned-long)) +(sb!alien:define-alien-routine ("unblock_gc_signals" %unblock-gc-signals) + sb!alien:void + (where sb!alien:unsigned-long) + (old sb!alien:unsigned-long)) + +(defun unblock-deferrable-signals () + (%unblock-deferrable-signals 0 0)) + +(defun unblock-gc-signals () + (%unblock-gc-signals 0 0)) ;;;; C routines that actually do all the work of establishing signal handlers @@ -93,6 +129,7 @@ (declare (type (or function fixnum (member :default :ignore)) handler)) (/show0 "enable-interrupt") (flet ((run-handler (&rest args) + (declare (truly-dynamic-extent args)) (in-interruption () (apply handler args)))) (without-gcing @@ -138,7 +175,6 @@ #!-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") @@ -148,9 +184,10 @@ (/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)))))) + (with-interrupts + (%break 'sigint 'interactive-interrupt + :context context + :address (sap-int (sb!vm:context-pc context))))))) (sb!thread:interrupt-thread (sb!thread::foreground-thread) #'interrupt-it))) @@ -164,10 +201,14 @@ (sb!thread::terminate-session) (sb!ext:quit)) -;; Also known as SIGABRT. -(defun sigiot-handler (signal code context) +;;; SIGPIPE is not used in SBCL for its original purpose, instead it's +;;; for signalling a thread that it should look at its interruption +;;; queue. The handler (RUN_INTERRUPTION) just returns if there is +;;; nothing to do so it's safe to receive spurious SIGPIPEs coming +;;; from the kernel. +(defun sigpipe-handler (signal code context) (declare (ignore signal code context)) - (sb!impl::%halt)) + (sb!thread::run-interruption)) (defun sb!kernel:signal-cold-init-or-reinit () #!+sb-doc @@ -175,17 +216,17 @@ (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) #!-linux (enable-interrupt sigsys #'sigsys-handler) - (ignore-interrupt sigpipe) (enable-interrupt sigalrm #'sigalrm-handler) - (sb!unix::reset-signal-mask) + (enable-interrupt sigpipe #'sigpipe-handler) + #!+hpux (ignore-interrupt sigxcpu) + (unblock-gc-signals) + (unblock-deferrable-signals) (values)) ;;;; etc.