From 10b242aeb4e031f02a1f32ec0aea79bbe92fa1d0 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 11 Jun 2008 20:04:23 +0000 Subject: [PATCH] 1.0.17.33: fix PRINT-OBJECT cache We mustn't compute the cached cache too early, otherwise we'll cache effective methods before the actual methods (on RESTART and the two storage-condition classes) are defined. --- src/code/error.lisp | 19 ++++++++++++++++--- src/code/interr.lisp | 7 ++++--- src/pcl/methods.lisp | 8 ++++++++ tests/print.impure.lisp | 13 +++++++++++++ version.lisp-expr | 2 +- 5 files changed, 42 insertions(+), 7 deletions(-) diff --git a/src/code/error.lisp b/src/code/error.lisp index 0e663cf..9078873 100644 --- a/src/code/error.lisp +++ b/src/code/error.lisp @@ -148,22 +148,35 @@ (lambda (condition stream) (declare (ignore condition)) (format stream - "Control stack exhausted (no more space for function call frames). This is probably due to heavily nested or infinitely recursive function calls, or a tail call that SBCL cannot or has not optimized away.")))) + ;; no pretty-printing, because that would use a lot of stack. + "Control stack exhausted (no more space for function call frames). +This is probably due to heavily nested or infinitely recursive function +calls, or a tail call that SBCL cannot or has not optimized away. + +PROCEED WITH CAUTION.")))) (define-condition heap-exhausted-error (storage-condition) () (:report (lambda (condition stream) + (declare (ignore condition)) (declare (special *heap-exhausted-error-available-bytes* *heap-exhausted-error-requested-bytes*)) ;; See comments in interr.lisp -- there is a method to this madness. (if (and (boundp '*heap-exhausted-error-available-bytes*) (boundp '*heap-exhausted-error-requested-bytes*)) (format stream - "Heap exhausted: ~D bytes available, ~D requested. PROCEED WITH CAUTION!" + ;; no pretty-printing, because that will use a lot of heap. + "Heap exhausted (no more space for allocation). +There are still ~D bytes available; the request was for ~D bytes. + +PROCEED WITH CAUTION." *heap-exhausted-error-available-bytes* *heap-exhausted-error-requested-bytes*) - (print-unreadable-object (condition stream)))))) + (format stream + "A ~S condition without bindings for heap statistics. (If +you did not expect to see this message, please report it." + 'heap-exhausted-error))))) (define-condition system-condition (condition) ((address :initarg :address :reader system-condition-address :initform nil) diff --git a/src/code/interr.lisp b/src/code/interr.lisp index 3f2a45d..7a48c43 100644 --- a/src/code/interr.lisp +++ b/src/code/interr.lisp @@ -474,9 +474,10 @@ (error 'control-stack-exhausted)))) ;;; KLUDGE: we keep a single HEAP-EXHAUSTED-ERROR object around, so -;;; that we don't need to allocate it when running out of memory. Similarly -;;; we pass the amounts in special variables as there may be multiple threads -;;; running into trouble at the same time. The condition is created by GC-REINIT. +;;; that we don't need to allocate it when running out of +;;; memory. Similarly we pass the amounts in special variables as +;;; there may be multiple threads running into trouble at the same +;;; time. The condition is created by GC-REINIT. (defvar *heap-exhausted-error-condition*) (defvar *heap-exhausted-error-available-bytes*) (defvar *heap-exhausted-error-requested-bytes*) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index b9515ed..3dc38cc 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -1567,11 +1567,19 @@ (cond ((/= nkeys 1) ;; KLUDGE: someone has defined a method ;; specialized on the second argument: punt. + (setf po-cache nil) (make-initial-dfun gf)) (po-cache (multiple-value-bind (dfun cache info) (make-caching-dfun gf po-cache) (set-dfun gf dfun cache info))) + ;; the relevant PRINT-OBJECT methods get defined + ;; late, by delayed DEF!METHOD. We mustn't cache + ;; the effective method for our classes earlier + ;; than the relevant PRINT-OBJECT methods are + ;; defined... + ((boundp 'sb-impl::*delayed-def!method-args*) + (make-initial-dfun gf)) (t (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf diff --git a/tests/print.impure.lisp b/tests/print.impure.lisp index 4f1b3f5..d1ccc01 100644 --- a/tests/print.impure.lisp +++ b/tests/print.impure.lisp @@ -433,4 +433,17 @@ (assert (string= (format nil "~R" (expt 10 63)) "one vigintillion")) (assert (string= (format nil "~:R" (expt 10 63)) "one vigintillionth")) +;;; too-clever cacheing for PRINT-OBJECT resulted in a bogus method +;;; for printing RESTART objects. Check also CONTROL-STACK-EXHAUSTED +;;; and HEAP-EXHAUSTED-ERROR. +(let ((result (with-output-to-string (*standard-output*) + (princ (find-restart 'abort))))) + (assert (string/= result "#<" :end1 2))) +(let ((result (with-output-to-string (*standard-output*) + (princ (make-condition 'sb-kernel::control-stack-exhausted))))) + (assert (string/= result "#<" :end1 2))) +(let ((result (with-output-to-string (*standard-output*) + (princ (make-condition 'sb-kernel::heap-exhausted-error))))) + (assert (string/= result "#<" :end1 2))) + ;;; success diff --git a/version.lisp-expr b/version.lisp-expr index 5ae4f8e..ce46f54 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".) -"1.0.17.32" +"1.0.17.33" -- 1.7.10.4