From: Christophe Rhodes <csr21@cantab.net>
Date: Mon, 13 Apr 2009 21:24:31 +0000 (+0000)
Subject: 1.0.27.9: fix print-object cache handling
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=c47a1dd98bc2d0be7910782c46cf29349ce973c1;p=sbcl.git

1.0.27.9: fix print-object cache handling
	1.0.25.50 exposed a bug in the print-object discriminating
	function: we need to have the methods for critical printing at
	all times, but the implementation allowed other methods into
	that initial cache, which was wrong if those methods
	were subsequently invalidated.  The fix is to keep the initial
	cache pristine and to use only copies in the print-object
	generic function itself.
---

diff --git a/NEWS b/NEWS
index fed0849..fe81cbb 100644
--- a/NEWS
+++ b/NEWS
@@ -3,6 +3,8 @@ changes in sbcl-1.0.28 relative to 1.0.27:
   * bug fix: timers could go off in the wrong order, be delayed indefinitely
     (thanks to Ole Arndt for the patch)
   * bug fix: RESTART-FRAME and RETURN-FROM-FRAME stack corruption
+  * bug fix: the discriminating function for PRINT-OBJECT no longer preserves
+    potentially-invalid effective methods in its cache.
 
 changes in sbcl-1.0.27 relative to 1.0.26:
   * new port: support added for x86-64 OpenBSD. (thanks to Josh Elsasser)
diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index d7d40b0..4bc4f1e 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -1585,7 +1585,7 @@
       (eq gf #'(setf slot-value-using-class))
       (eq gf #'slot-boundp-using-class)))
 
-(let (po-cache)
+(let (initial-print-object-cache)
   (defmethod compute-discriminating-function ((gf standard-generic-function))
     (let ((dfun-state (slot-value gf 'dfun-state)))
       (when (special-case-for-compute-discriminating-function-p gf)
@@ -1623,11 +1623,11 @@
               (cond ((/= nkeys 1)
                      ;; KLUDGE: someone has defined a method
                      ;; specialized on the second argument: punt.
-                     (setf po-cache nil)
+                     (setf initial-print-object-cache nil)
                      (make-initial-dfun gf))
-                    (po-cache
+                    (initial-print-object-cache
                      (multiple-value-bind (dfun cache info)
-                         (make-caching-dfun gf po-cache)
+                         (make-caching-dfun gf (copy-cache initial-print-object-cache))
                        (set-dfun gf dfun cache info)))
                     ;; the relevant PRINT-OBJECT methods get defined
                     ;; late, by delayed DEF!METHOD.  We mustn't cache
@@ -1639,17 +1639,14 @@
                     (t (multiple-value-bind (dfun cache info)
                            (make-final-dfun-internal
                             gf
-                            (list (list (find-class
-                                         'sb-kernel::control-stack-exhausted))
-                                  (list (find-class
-                                         'sb-kernel::binding-stack-exhausted))
-                                  (list (find-class
-                                         'sb-kernel::alien-stack-exhausted))
-                                  (list (find-class
-                                         'sb-kernel::heap-exhausted-error))
-                                  (list (find-class 'restart))))
-                         (setq po-cache cache)
-                         (set-dfun gf dfun cache info))))))
+                            (mapcar (lambda (x) (list (find-class x)))
+                                    '(sb-kernel::control-stack-exhausted
+                                      sb-kernel::binding-stack-exhausted
+                                      sb-kernel::alien-stack-exhausted
+                                      sb-kernel::heap-exhausted-error
+                                      restart)))
+                         (setq initial-print-object-cache cache)
+                         (set-dfun gf dfun (copy-cache cache) info))))))
            ((gf-precompute-dfun-and-emf-p (slot-value gf 'arg-info))
             (make-final-dfun gf))
            (t
diff --git a/version.lisp-expr b/version.lisp-expr
index ee218e0..3ae4382 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.27.8"
+"1.0.27.9"