From fe420bb47ea909070ee82c6e48642c9ff41dbcc8 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 28 Jan 2008 15:10:54 +0000 Subject: [PATCH] 1.0.14.1: lisp-side interrupt handling improvements * Stack-top hint for interrupts: clears the uninteresting frames from the top of a SIGINT backtrace. * Revert to a defunless WITHOUT-INTERRUPTS &co: less useless interrupt twiddling frames in backtraces -- now there should only be occasional #:WITHOUT-INTERRUPTS-BODY frames, and those only when there is at least something moderately interesting going on. There is a balance to be struck here, though, and this may be too far in the opposite direction... * Interrupt safe SORT. * ADJUST-ARRAY doesn't need to disable interrupts anymore. * Handle internal errors using WITH-INTERRUPT-BINDINGS as well: with sufficently bad luck one could eg. signal a continuable error (via the internal error code-path) from eg . :KEY to SORT and then corrupt the temporary vector in handler. It seems also possible to construct a similar case that would cause bogus metacircles to be detected -- this is easier to reason about. --- NEWS | 6 ++ src/code/array.lisp | 26 +++++---- src/code/interr.lisp | 75 ++++++++++++------------- src/code/signal.lisp | 129 +++++++++++++++++-------------------------- src/code/sort.lisp | 8 +-- src/code/target-signal.lisp | 30 ++++++---- src/code/target-thread.lisp | 5 +- version.lisp-expr | 2 +- 8 files changed, 135 insertions(+), 146 deletions(-) diff --git a/NEWS b/NEWS index a2c5176..5b68f00 100644 --- a/NEWS +++ b/NEWS @@ -1,4 +1,10 @@ ;;;; -*- coding: utf-8; -*- +changes in sbcl-1.0.15 relative to sbcl-1.0.14: + * enhancement: cleaner backtraces for interactive interrupts, as + well as other cases where the interesting frames used to be + obscured by interrupt handling frames. + * bug fix: SORT was not interrupt safe. + changes in sbcl-1.0.14 relative to sbcl-1.0.13: * new feature: SB-EXT:*EXIT-HOOKS* are called when the process exits (see documentation for details.) diff --git a/src/code/array.lisp b/src/code/array.lisp index 78bf43d..c0f673b 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -1077,6 +1077,12 @@ of specialized arrays is supported." (setf (%array-displaced-p array) displacedp) array) +;;;; used by SORT + +;;; temporary vector for stable sorting vectors, allocated for each new thread +(defvar *merge-sort-temp-vector* (vector)) +(declaim (simple-vector *merge-sort-temp-vector*)) + ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY ;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ. @@ -1125,18 +1131,14 @@ of specialized arrays is supported." (unless (typep initial-element element-type) (error "~S can't be used to initialize an array of type ~S." initial-element element-type))) - (without-interrupts - ;; Need to disable interrupts while using the temp-vector. - ;; An interrupt handler that also happened to call - ;; ADJUST-ARRAY could otherwise stomp on our data here. - (let ((temp (zap-array-data-temp new-length - initial-element initial-element-p))) - (declare (simple-vector temp)) - (zap-array-data-aux old-data old-dims offset temp new-dims) - (dotimes (i new-length) - (setf (aref new-data i) (aref temp i) - ;; zero out any garbage right away - (aref temp i) 0))))) + (let ((temp (zap-array-data-temp new-length + initial-element initial-element-p))) + (declare (simple-vector temp)) + (zap-array-data-aux old-data old-dims offset temp new-dims) + (dotimes (i new-length) + (setf (aref new-data i) (aref temp i) + ;; zero out any garbage right away + (aref temp i) 0)))) (t ;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has ;; already been filled with any diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 8fb4657..a939c85 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -418,43 +418,44 @@ (%primitive print "can't recover from error in cold init, halting") (%primitive sb!c:halt)) - (multiple-value-bind (name sb!debug:*stack-top-hint*) - (find-interrupted-name-and-frame) - (/show0 "back from FIND-INTERRUPTED-NAME") - ;; Unblock trap signal here, we unwound the stack and can't return. - ;; FIXME: Should we not reset the _entire_ mask, but just - ;; restore it to the state before we got the condition? - ;; FIXME 2: Signals are currently unblocked in - ;; interrupt.c:internal_error before we do stack unwinding, can this - ;; introduce a race condition? - #!+(and linux mips) - (sb!unix::reset-signal-mask) - (let ((fp (int-sap (sb!vm:context-register alien-context - sb!vm::cfp-offset))) - (handler (and (< -1 error-number (length *internal-errors*)) - (svref *internal-errors* error-number)))) - (cond ((null handler) - (error 'simple-error - :format-control - "unknown internal error, ~D, args=~S" - :format-arguments - (list error-number - (mapcar (lambda (sc-offset) - (sb!di::sub-access-debug-var-slot - fp sc-offset alien-context)) - arguments)))) - ((not (functionp handler)) - (error 'simple-error - :format-control "internal error ~D: ~A; args=~S" - :format-arguments - (list error-number - handler - (mapcar (lambda (sc-offset) - (sb!di::sub-access-debug-var-slot - fp sc-offset alien-context)) - arguments)))) - (t - (funcall handler name fp alien-context arguments))))))))) + (with-interrupt-bindings + (multiple-value-bind (name sb!debug:*stack-top-hint*) + (find-interrupted-name-and-frame) + (/show0 "back from FIND-INTERRUPTED-NAME") + ;; Unblock trap signal here, we unwound the stack and can't return. + ;; FIXME: Should we not reset the _entire_ mask, but just + ;; restore it to the state before we got the condition? + ;; FIXME 2: Signals are currently unblocked in + ;; interrupt.c:internal_error before we do stack unwinding, can this + ;; introduce a race condition? + #!+(and linux mips) + (sb!unix::reset-signal-mask) + (let ((fp (int-sap (sb!vm:context-register alien-context + sb!vm::cfp-offset))) + (handler (and (< -1 error-number (length *internal-errors*)) + (svref *internal-errors* error-number)))) + (cond ((null handler) + (error 'simple-error + :format-control + "unknown internal error, ~D, args=~S" + :format-arguments + (list error-number + (mapcar (lambda (sc-offset) + (sb!di::sub-access-debug-var-slot + fp sc-offset alien-context)) + arguments)))) + ((not (functionp handler)) + (error 'simple-error + :format-control "internal error ~D: ~A; args=~S" + :format-arguments + (list error-number + handler + (mapcar (lambda (sc-offset) + (sb!di::sub-access-debug-var-slot + fp sc-offset alien-context)) + arguments)))) + (t + (funcall handler name fp alien-context arguments)))))))))) (defun control-stack-exhausted-error () (let ((sb!debug:*stack-top-hint* nil)) diff --git a/src/code/signal.lisp b/src/code/signal.lisp index 02a215a..d6c7eee 100644 --- a/src/code/signal.lisp +++ b/src/code/signal.lisp @@ -89,27 +89,39 @@ WITHOUT-INTERRUPTS in: ;; regardless of the interrupt policy in effect when it is called. (lambda () (with-local-interrupts ...))) " - (with-unique-names (outer-allow-with-interrupts) - `(dx-flet ((without-interrupts-thunk (,outer-allow-with-interrupts) - (declare (disable-package-locks allow-with-interrupts - with-interrupts) - (ignorable ,outer-allow-with-interrupts)) - (macrolet ((allow-with-interrupts (&body allow-forms) - `(dx-flet ((allow-with-interrupts-thunk () - ,@allow-forms)) - (call-allowing-with-interrupts - #'allow-with-interrupts-thunk - ,',outer-allow-with-interrupts))) - (with-local-interrupts (&body with-forms) - `(dx-flet ((with-local-interrupts-thunk () - ,@with-forms)) - (call-with-local-interrupts - #'with-local-interrupts-thunk - ,',outer-allow-with-interrupts)))) - (declare (enable-package-locks allow-with-interrupts - with-interrupts)) - ,@body))) - (call-without-interrupts #'without-interrupts-thunk)))) + (with-unique-names (outer-allow-with-interrupts without-interrupts-body) + `(flet ((,without-interrupts-body () + (declare (disable-package-locks allow-with-interrupts with-local-interrupts)) + (macrolet ((allow-with-interrupts (&body allow-forms) + `(let ((*allow-with-interrupts* ,',outer-allow-with-interrupts)) + ,@allow-forms)) + (with-local-interrupts (&body with-forms) + `(let ((*allow-with-interrupts* ,',outer-allow-with-interrupts) + (*interrupts-enabled* ,',outer-allow-with-interrupts)) + (when (and ,',outer-allow-with-interrupts *interrupt-pending*) + (receive-pending-interrupt)) + (locally ,@with-forms)))) + (let ((*interrupts-enabled* nil) + (,outer-allow-with-interrupts *allow-with-interrupts*) + (*allow-with-interrupts* nil)) + (declare (ignorable ,outer-allow-with-interrupts)) + (declare (enable-package-locks allow-with-interrupts with-local-interrupts)) + ,@body)))) + (if *interrupts-enabled* + (unwind-protect + (,without-interrupts-body) + ;; If we were interrupted in the protected section, + ;; then the interrupts are still blocked and it remains + ;; so until the pending interrupt is handled. + ;; + ;; If we were not interrupted in the protected section, + ;; but here, then even if the interrupt handler enters + ;; another WITHOUT-INTERRUPTS, the pending interrupt will be + ;; handled immediately upon exit from said + ;; WITHOUT-INTERRUPTS, so it is as if nothing has happened. + (when *interrupt-pending* + (receive-pending-interrupt))) + (,without-interrupts-body))))) (sb!xc:defmacro with-interrupts (&body body) #!+sb-doc @@ -120,62 +132,25 @@ As interrupts are normally allowed WITH-INTERRUPTS only makes sense if there is an outer WITHOUT-INTERRUPTS with a corresponding ALLOW-WITH-INTERRUPTS: interrupts are not enabled if any outer WITHOUT-INTERRUPTS is not accompanied by ALLOW-WITH-INTERRUPTS." - `(dx-flet ((with-interrupts-thunk () ,@body)) - (call-with-interrupts - #'with-interrupts-thunk - (and (not *interrupts-enabled*) *allow-with-interrupts*)))) - -(defun call-allowing-with-interrupts (function allowp) - (declare (function function)) - (if allowp - (let ((*allow-with-interrupts* t)) - (funcall function)) - (funcall function))) - -(defun call-with-interrupts (function allowp) - (declare (function function)) - (if allowp - (let ((*interrupts-enabled* t)) - (when *interrupt-pending* - (receive-pending-interrupt)) - (funcall function)) - (funcall function))) - -;; Distinct from CALL-WITH-INTERRUPTS as it needs to bind both *A-W-I* -;; and *I-E*. -(defun call-with-local-interrupts (function allowp) - (declare (function function)) - (if allowp - (let* ((*allow-with-interrupts* t) - (*interrupts-enabled* t)) - (when *interrupt-pending* - (receive-pending-interrupt)) - (funcall function)) - (funcall function))) - -(defun call-without-interrupts (function) - (declare (function function)) - (flet ((run-without-interrupts () - (if *allow-with-interrupts* - (let ((*allow-with-interrupts* nil)) - (funcall function t)) - (funcall function nil)))) - (if *interrupts-enabled* - (unwind-protect - (let ((*interrupts-enabled* nil)) - (run-without-interrupts)) - ;; If we were interrupted in the protected section, then the - ;; interrupts are still blocked and it remains so until the - ;; pending interrupt is handled. - ;; - ;; If we were not interrupted in the protected section, but - ;; here, then even if the interrupt handler enters another - ;; WITHOUT-INTERRUPTS, the pending interrupt will be handled - ;; immediately upon exit from said WITHOUT-INTERRUPTS, so it - ;; is as if nothing has happened. - (when *interrupt-pending* - (receive-pending-interrupt))) - (run-without-interrupts)))) + (with-unique-names (allowp enablep) + ;; We could manage without ENABLEP here, but that would require + ;; taking extra care not to ever have *ALLOW-WITH-INTERRUPTS* NIL + ;; and *INTERRUPTS-ENABLED* T -- instead of risking future breakage + ;; we take the tiny hit here. + `(let* ((,allowp *allow-with-interrupts*) + (,enablep *interrupts-enabled*) + (*interrupts-enabled* (or ,enablep ,allowp))) + (when (and (and ,allowp (not ,enablep)) *interrupt-pending*) + (receive-pending-interrupt)) + (locally ,@body)))) + +(defmacro allow-with-interrupts (&body body) + (declare (ignore body)) + (error "~S is valid only inside ~S." 'allow-with-interrupts 'without-interrupts)) + +(defmacro with-local-interrupts (&body body) + (declare (ignore body)) + (error "~S is valid only inside ~S." 'with-local-interrupts 'without-interrupts)) ;;; A low-level operation that assumes that *INTERRUPTS-ENABLED* is false, ;;; and *ALLOW-WITH-INTERRUPTS* is true. diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 83e9898..1d6949f 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -240,8 +240,8 @@ (simple-vector ,temp)) (when (> ,vector-len ,temp-len) (setf ,temp (make-array (max ,vector-len - (min most-positive-fixnum - (+ ,temp-len ,temp-len)))) + (min (truncate array-dimension-limit 2) + (logand most-positive-fixnum (+ ,temp-len ,temp-len))))) *merge-sort-temp-vector* ,temp)) ;; Rebind, in case PRED or KEY calls STABLE-SORT. This is also ;; interrupt safe: we bind before we put any data of our own in @@ -297,10 +297,6 @@ ) ; EVAL-when -;;; temporary vector for stable sorting vectors, allocated for each new thread -(defvar *merge-sort-temp-vector* (vector)) -(declaim (simple-vector *merge-sort-temp-vector*)) - (defun stable-sort-simple-vector (vector pred key) (declare (type simple-vector vector) (type function pred) diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index c555dd2..073b4c9 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -12,16 +12,22 @@ (in-package "SB!UNIX") (defmacro with-interrupt-bindings (&body body) - `(let - ;; KLUDGE: Whatever is on the PCL stacks before the interrupt - ;; handler runs doesn't really matter, since we're not on the - ;; same call stack, really -- and if we don't bind these (esp. - ;; the cache one) we can get a bogus metacircle if an interrupt - ;; handler calls a GF that was being computed when the interrupt - ;; hit. - ((sb!pcl::*cache-miss-values-stack* nil) - (sb!pcl::*dfun-miss-gfs-on-stack* nil)) - ,@body)) + (with-unique-names (empty) + `(let* + ;; KLUDGE: Whatever is on the PCL stacks before the interrupt + ;; handler runs doesn't really matter, since we're not on the + ;; same call stack, really -- and if we don't bind these (esp. + ;; the cache one) we can get a bogus metacircle if an interrupt + ;; handler calls a GF that was being computed when the interrupt + ;; hit. + ((sb!pcl::*cache-miss-values-stack* nil) + (sb!pcl::*dfun-miss-gfs-on-stack* nil) + ;; Unless we do this, ADJUST-ARRAY and SORT would need to + ;; disable interrupts. + (,empty (vector)) + (sb!impl::*zap-array-data-temp* ,empty) + (sb!impl::*merge-sort-temp-vector* ,empty)) + ,@body))) (defun invoke-interruption (function) (with-interrupt-bindings @@ -34,7 +40,9 @@ ;; 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 (funcall function))))) + (allow-with-interrupts + (let ((sb!debug:*stack-top-hint* (nth-value 1 (sb!kernel:find-interrupted-name-and-frame)))) + (funcall function)))))) (defmacro in-interruption ((&key) &body body) #!+sb-doc diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index b60ce71..218e355 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -688,8 +688,9 @@ around and can be retrieved by JOIN-THREAD." ;; internal printer variables (sb!impl::*previous-case* nil) (sb!impl::*previous-readtable-case* nil) - (sb!impl::*merge-sort-temp-vector* (vector)) ; keep these small! - (sb!impl::*zap-array-data-temp* (vector)) ; + (empty (vector)) + (sb!impl::*merge-sort-temp-vector* empty) + (sb!impl::*zap-array-data-temp* empty) (sb!impl::*internal-symbol-output-fun* nil) (sb!impl::*descriptor-handlers* nil)) ; serve-event (setf (thread-os-thread thread) (current-thread-sap-id)) diff --git a/version.lisp-expr b/version.lisp-expr index cbeccb2..bc33dd9 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.14" +"1.0.14.1" -- 1.7.10.4