From a57db6f5ee029a4c9817ae239d7bbefd3fb8374e Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Thu, 28 Aug 2003 09:07:57 +0000 Subject: [PATCH] 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 --- doc/internals-notes/threading-specials | 8 +++++-- src/pcl/dfun.lisp | 20 ++++++---------- src/pcl/documentation.lisp | 8 +++---- src/pcl/methods.lisp | 41 ++++++++++++++++---------------- version.lisp-expr | 2 +- 5 files changed, 38 insertions(+), 41 deletions(-) diff --git a/doc/internals-notes/threading-specials b/doc/internals-notes/threading-specials index 3e8c597..8ff8460 100644 --- 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 --- 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))))) -;;; 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 --- a/src/pcl/documentation.lisp +++ b/src/pcl/documentation.lisp @@ -101,12 +101,12 @@ (setf (random-documentation x 'method-combination) new-value)) ;;; 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)) ;;; packages diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index ab5110e..0b12c51 100644 --- 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 --- 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" -- 1.7.10.4