0.9.2.28: infinite error protection

  * bug fix: don't halt on infinite error in threads if possible
  * use invoke-debugger instead of internal-debug on infinite errors
  * don't halt after the 50th successfully handled infinite error

diff --git a/NEWS b/NEWS
index 8a3a2bd..cb7f9e3 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -25,6 +25,7 @@ changes in sbcl-0.9.3 relative to sbcl-0.9.2:
     ** bug fix: threads are protected from signals and interruption when
        starting up or going down
     ** bug fix: a race where an exiting thread could lose its stack to gc
+    ** bug fix: don't halt on infinite error in threads if possible
     ** fixed numerous gc deadlocks introduced in the pthread merge
     ** bug fix: fixed thread safety issues in read and print
   * fixed some bugs revealed by Paul Dietz' test suite:

diff --git a/src/code/error-error.lisp b/src/code/error-error.lisp
index 992b13e..f76b5b8 100644 (file)
--- a/src/code/error-error.lisp
+++ b/src/code/error-error.lisp
@@ -12,24 +12,17 @@
 ;;; These specials are used by ERROR-ERROR to track the success of recovery
 ;;; attempts.
 (defvar *error-error-depth* 0)
-(defvar *error-throw-up-count* 0)
 
 ;;; ERROR-ERROR can be called when the error system is in trouble and needs to
 ;;; punt fast. It prints a message without using FORMAT. If we get into this
 ;;; recursively, then we halt.
 (defun error-error (&rest messages)
   (let ((*error-error-depth* (1+ *error-error-depth*)))
-    (when (> *error-throw-up-count* 50)
-      (/show0 "*ERROR-THROW-UP-COUNT* too big, trying HALT")
-      (%primitive sb!c:halt)
-      (/show0 "*ERROR-THROW-UP-COUNT* too big, trying THROW")
-      (throw 'toplevel-catcher nil))
     (case *error-error-depth*
       (1)
       (2
        (stream-cold-init-or-reset))
       (3
-       (incf *error-throw-up-count*)
        (/show0 "*ERROR-ERROR-DEPTH* too big, trying THROW")
        (throw 'toplevel-catcher nil))
       (t
@@ -42,4 +35,10 @@
       (let ((*print-readably* nil))
        (dolist (item messages)
          (princ item *terminal-io*))
-       (sb!debug:internal-debug)))))
+        (terpri *terminal-io*)
+        (sb!debug:backtrace most-positive-fixnum *terminal-io*)
+        (force-output *terminal-io*)
+       (invoke-debugger
+         (coerce-to-condition "Maximum error nesting depth exceeded" nil
+                              'simple-error
+                              'error))))))

diff --git a/src/code/target-multithread.lisp b/src/code/target-multithread.lisp
index ce284ad..b2d2350 100644 (file)
--- a/src/code/target-multithread.lisp
+++ b/src/code/target-multithread.lisp
@@ -177,20 +177,21 @@ time we reacquire LOCK and return to the caller."
                 ;; output streams, and we don't necessarily have any (or we
                 ;; could be sharing them)
                 (unwind-protect
-                     (catch 'sb!impl::%end-of-the-world
-                       (with-simple-restart
-                           (terminate-thread
-                            (format nil "~~@<Terminate this thread (~A)~~@:>"
-                                    *current-thread*))
-                         ;; now that most things have a chance to work
-                         ;; properly without messing up other threads, it's
-                         ;; time to enable signals
-                         (sb!unix::reset-signal-mask)
-                         (unwind-protect
-                              (funcall real-function)
-                           ;; we're going down, can't handle
-                           ;; interrupts sanely anymore
-                           (sb!unix::block-blockable-signals))))
+                     (catch 'sb!impl::toplevel-catcher
+                       (catch 'sb!impl::%end-of-the-world
+                         (with-simple-restart
+                             (terminate-thread
+                              (format nil "~~@<Terminate this thread (~A)~~@:>"
+                                      *current-thread*))
+                           ;; now that most things have a chance to work
+                           ;; properly without messing up other threads, it's
+                           ;; time to enable signals
+                           (sb!unix::reset-signal-mask)
+                           (unwind-protect
+                                (funcall real-function)
+                             ;; we're going down, can't handle
+                             ;; interrupts sanely anymore
+                             (sb!unix::block-blockable-signals)))))
                   ;; mark the thread dead, so that the gc does not
                   ;; wait for it to handle sig-stop-for-gc
                   (%set-thread-state thread :dead)

diff --git a/tests/debug.impure.lisp b/tests/debug.impure.lisp
index 86a0de6..db05cc3 100644 (file)
--- a/tests/debug.impure.lisp
+++ b/tests/debug.impure.lisp
@@ -345,5 +345,42 @@
   (assert (search "TRACE-THIS" out))
   (assert (search "returned OK" out)))
 
+;;;; test infinite error protection
+
+(defmacro nest-errors (n-levels error-form)
+  (if (< 0 n-levels)
+      `(handler-bind ((error (lambda (condition)
+                               (declare (ignore condition))
+                               ,error-form)))
+        (nest-errors ,(1- n-levels) ,error-form))
+      error-form))
+
+(defun erroring-debugger-hook (condition old-debugger-hook)
+  (let ((*debugger-hook* old-debugger-hook))
+    (format t "recursive condition: ~A~%" condition) (force-output)
+    (error "recursive condition: ~A" condition)))
+
+(defun test-inifinite-error-protection ()
+  ;; after 50 successful throws to SB-IMPL::TOPLEVEL-CATCHER sbcl used
+  ;; to halt, it produces so much garbage that's hard to suppress that
+  ;; it is tested only once
+  (let ((*debugger-hook* #'erroring-debugger-hook))
+    (loop repeat 1 do
+          (let ((error-counter 0)
+                (*terminal-io* (make-broadcast-stream)))
+            (assert
+             (not (eq
+                   :normal-exit
+                   (catch 'sb-impl::toplevel-catcher
+                     (nest-errors 20 (error "infinite error ~s"
+                                            (incf error-counter)))
+                     :normal-exit))))))))
+
+(test-inifinite-error-protection)
+
+#+sb-thread
+(let ((thread (sb-thread:make-thread #'test-inifinite-error-protection)))
+  (loop while (sb-thread:thread-alive-p thread)))
+
 ;;; success
 (quit :unix-status 104)

diff --git a/version.lisp-expr b/version.lisp-expr
index 1d101d1..081fb64 100644 (file)
--- 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".)
-"0.9.2.27"
+"0.9.2.28"