0.8.3.7:

	Fix effective method cacheing over method combination changes
	(Andreas Fuchs sbcl-help 2003-08-27) after GM
	... REINITIALIZE-INSTANCE :AROUND to remove affected methods
		from the cache
	Also fix cut'n'pasteo in documentation of methods

diff --git a/doc/internals-notes/threading-specials b/doc/internals-notes/threading-specials
index 3e8c597..8ff8460 100644 (file)
--- a/doc/internals-notes/threading-specials
+++ b/doc/internals-notes/threading-specials
@@ -108,9 +108,13 @@ SB-PCL::*SLOT-NAME-LISTS-OUTER*
 SB-PCL::*THE-WRAPPER-OF-T* 
 SB-PCL::*CREATE-CLASSES-FROM-INTERNAL-STRUCTURE-DEFINITIONS-P* 
 SB-PCL::*WRITERS-FOR-THIS-DEFCLASS*
-SB-PCL::*BOOT-STATE* 
+SB-PCL::*BOOT-STATE* ; pseudoconstant in finished lisp (not in bootstrap)
 SB-PCL::*THE-WRAPPER-OF-BIT-VECTOR* 
-SB-PCL::*EFFECTIVE-METHOD-TABLE* 
+;;; global, frobbed on generic function
+;;; initialization/reinitialization, method precomputation, and
+;;; compute-effective-method.  Potentially unsafe, may be OK because
+;;; of *pcl-lock*, but could easily be liable to races.
+SB-PCL::*EFFECTIVE-METHOD-CACHE* 
 SB-PCL::*THE-WRAPPER-OF-COMPLEX-DOUBLE-FLOAT* 
 SB-PCL::*THE-CLASS-COMPLEX-DOUBLE-FLOAT* 
 SB-PCL::*THE-WRAPPER-OF-SIMPLE-ARRAY-SINGLE-FLOAT* 

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 6245903..cc6d267 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -1617,17 +1617,11 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                    (find-class root)
                    root)))))
 \f
-;;; NOTE: We are assuming a restriction on user code that the method
-;;;       combination must not change once it is connected to the
-;;;       generic function.
-;;;
-;;;       This has to be legal, because otherwise any kind of method
-;;;       lookup caching couldn't work. See this by saying that this
-;;;       cache, is just a backing cache for the fast cache. If that
-;;;       cache is legal, this one must be too.
-;;;
-;;; Don't clear this table!
-(defvar *effective-method-table* (make-hash-table :test 'eq))
+(defvar *effective-method-cache* (make-hash-table :test 'eq))
+
+(defun flush-effective-method-cache (generic-function)
+  (dolist (method (generic-function-methods generic-function))
+    (remhash method *effective-method-cache*)))
 
 (defun get-secondary-dispatch-function (gf methods types &optional
                                                         method-alist wrappers)
@@ -1655,8 +1649,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
            (lambda (&rest args)
              (apply #'no-applicable-method gf args))))
       (let* ((key (car methods))
-            (ht-value (or (gethash key *effective-method-table*)
-                          (setf (gethash key *effective-method-table*)
+            (ht-value (or (gethash key *effective-method-cache*)
+                          (setf (gethash key *effective-method-cache*)
                                 (cons nil nil)))))
        (if (and (null (cdr methods)) all-applicable-p ; the most common case
                 (null method-alist-p) wrappers-p (not function-p))

diff --git a/src/pcl/documentation.lisp b/src/pcl/documentation.lisp
index b728992..df24ea8 100644 (file)
--- a/src/pcl/documentation.lisp
+++ b/src/pcl/documentation.lisp
@@ -101,12 +101,12 @@
   (setf (random-documentation x 'method-combination) new-value))
 \f
 ;;; methods
-(defmethod documentation ((method standard-method) (doc-type (eql 't)))
-  (slot-value slotd 'documentation))
+(defmethod documentation ((x standard-method) (doc-type (eql 't)))
+  (slot-value x 'documentation))
 
 (defmethod (setf documentation)
-    (new-value (method standard-method) (doc-type (eql 't)))
-  (setf (slot-value method 'documentation) new-value))
+    (new-value (x standard-method) (doc-type (eql 't)))
+  (setf (slot-value x 'documentation) new-value))
 \f
 ;;; packages
 

diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index ab5110e..0b12c51 100644 (file)
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -409,8 +409,7 @@
 (defmethod initialize-instance :after ((gf standard-generic-function)
                                       &key (lambda-list nil lambda-list-p)
                                       argument-precedence-order)
-  (with-slots (arg-info)
-    gf
+  (with-slots (arg-info) gf
     (if lambda-list-p
        (set-arg-info gf
                      :lambda-list lambda-list
@@ -419,25 +418,25 @@
     (when (arg-info-valid-p arg-info)
       (update-dfun gf))))
 
-(defmethod reinitialize-instance :after ((gf standard-generic-function)
-                                        &rest args
-                                        &key (lambda-list nil lambda-list-p)
-                                        (argument-precedence-order
-                                         nil argument-precedence-order-p))
-  (with-slots (arg-info)
-    gf
-    (if lambda-list-p
-       (if argument-precedence-order-p
-           (set-arg-info gf
-                         :lambda-list lambda-list
-                         :argument-precedence-order argument-precedence-order)
-           (set-arg-info gf
-                         :lambda-list lambda-list))
-       (set-arg-info gf))
-    (when (and (arg-info-valid-p arg-info)
-              args
-              (or lambda-list-p (cddr args)))
-      (update-dfun gf))))
+(defmethod reinitialize-instance :around
+    ((gf standard-generic-function) &rest args &key
+     (lambda-list nil lambda-list-p) (argument-precedence-order nil apo-p))
+  (let ((old-mc (generic-function-method-combination gf)))
+    (prog1 (call-next-method)
+      ;; KLUDGE: EQ is too strong a test.
+      (unless (eq old-mc (generic-function-method-combination gf))
+       (flush-effective-method-cache gf))
+      (cond
+       ((and lambda-list-p apo-p)
+        (set-arg-info gf
+                      :lambda-list lambda-list
+                      :argument-precedence-order argument-precedence-order))
+       (lambda-list-p (set-arg-info gf :lambda-list lambda-list))
+       (t (set-arg-info gf)))
+      (when (and (arg-info-valid-p (gf-arg-info gf))
+                (not (null args))
+                (or lambda-list-p (cddr args)))
+       (update-dfun gf)))))
 
 (declaim (special *lazy-dfun-compute-p*))
 

diff --git a/version.lisp-expr b/version.lisp-expr
index 189488d..0807e2b 100644 (file)
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -16,4 +16,4 @@
 ;;; with something arbitrary in the fourth field, is used for CVS
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
-"0.8.3.6"
+"0.8.3.7"