;;;; -*- 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.)
(setf (%array-displaced-p array) displacedp)
array)
\f
+;;;; 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.
(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
(%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))
;; 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
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.
(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
) ; 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)
(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
;; 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
;; 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))
;;; 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"
projects / sbcl.git / commitdiff