Email Archive: sbcl-commits (read-only)
|
[Sbcl-commits] CVS: sbcl/src/code array.lisp, 1.73, 1.74 interr.lisp,
1.47, 1.48 signal.lisp, 1.22, 1.23 sort.lisp, 1.23,
1.24 target-signal.lisp, 1.41, 1.42 target-thread.lisp, 1.85, 1.86
From: Nikodemus Siivola <demoss@us...> - 2008-01-28 15:11
|
Update of /cvsroot/sbcl/sbcl/src/code
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv18390/src/code
Modified Files:
array.lisp interr.lisp signal.lisp sort.lisp
target-signal.lisp target-thread.lisp
Log Message:
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.
Index: array.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/array.lisp,v
retrieving revision 1.73
retrieving revision 1.74
diff -u -d -r1.73 -r1.74
--- array.lisp 4 Jan 2008 01:52:28 -0000 1.73
+++ array.lisp 28 Jan 2008 15:11:00 -0000 1.74
@@ -1077,6 +1077,12 @@
(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 @@
(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
Index: interr.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/interr.lisp,v
retrieving revision 1.47
retrieving revision 1.48
diff -u -d -r1.47 -r1.48
--- interr.lisp 20 Aug 2007 07:08:10 -0000 1.47
+++ interr.lisp 28 Jan 2008 15:11:00 -0000 1.48
@@ -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))
Index: signal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/signal.lisp,v
retrieving revision 1.22
retrieving revision 1.23
diff -u -d -r1.22 -r1.23
--- signal.lisp 19 Jun 2007 21:00:05 -0000 1.22
+++ signal.lisp 28 Jan 2008 15:11:00 -0000 1.23
@@ -89,27 +89,39 @@
;; 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 @@
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)))
+ (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))))
-;; 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)))
+(defmacro allow-with-interrupts (&body body)
+ (declare (ignore body))
+ (error "~S is valid only inside ~S." 'allow-with-interrupts 'without-interrupts))
-(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))))
+(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.
Index: sort.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/sort.lisp,v
retrieving revision 1.23
retrieving revision 1.24
diff -u -d -r1.23 -r1.24
--- sort.lisp 29 Nov 2007 17:30:19 -0000 1.23
+++ sort.lisp 28 Jan 2008 15:11:00 -0000 1.24
@@ -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)
Index: target-signal.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-signal.lisp,v
retrieving revision 1.41
retrieving revision 1.42
diff -u -d -r1.41 -r1.42
--- target-signal.lisp 20 Jun 2007 19:05:54 -0000 1.41
+++ target-signal.lisp 28 Jan 2008 15:11:00 -0000 1.42
@@ -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
Index: target-thread.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/code/target-thread.lisp,v
retrieving revision 1.85
retrieving revision 1.86
diff -u -d -r1.85 -r1.86
--- target-thread.lisp 20 Oct 2007 06:27:20 -0000 1.85
+++ target-thread.lisp 28 Jan 2008 15:11:00 -0000 1.86
@@ -688,8 +688,9 @@
;; 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))
|
Thread View
| Thread | Author | Date |
|---|---|---|
| [Sbcl-commits] CVS: sbcl/src/code array.lisp, 1.73, 1.74 interr.lisp, 1.47, 1.48 signal.lisp, 1.22, 1.23 sort.lisp, 1.23, 1.24 target-signal.lisp, 1.41, 1.42 target-thread.lisp, 1.85, 1.86 | Nikodemus Siivola <demoss@us...> |