[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 S. <de...@us...>]

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))