From 165f17e83d068bc971cd41f407518e600c59a905 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Tue, 5 Jul 2005 14:10:36 +0000 Subject: [PATCH] 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 --- NEWS | 1 + src/code/error-error.lisp | 15 +++++++-------- src/code/target-multithread.lisp | 29 +++++++++++++++-------------- tests/debug.impure.lisp | 37 +++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 5 files changed, 61 insertions(+), 23 deletions(-) diff --git a/NEWS b/NEWS index 8a3a2bd..cb7f9e3 100644 --- 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 --- 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 --- 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 "~~@" - *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 "~~@" + *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 --- 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 --- 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" -- 1.7.10.4