From: Christophe R. <cr...@us...> - 2003-08-28 09:08:02
|
Update of /cvsroot/sbcl/sbcl/src/pcl In directory sc8-pr-cvs1:/tmp/cvs-serv23651/src/pcl Modified Files: dfun.lisp documentation.lisp methods.lisp Log Message: 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 Index: dfun.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/dfun.lisp,v retrieving revision 1.28 retrieving revision 1.29 diff -u -d -r1.28 -r1.29 --- dfun.lisp 26 Aug 2003 16:15:58 -0000 1.28 +++ dfun.lisp 28 Aug 2003 09:07:58 -0000 1.29 @@ -1617,17 +1617,11 @@ (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 @@ (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)) Index: documentation.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/documentation.lisp,v retrieving revision 1.9 retrieving revision 1.10 diff -u -d -r1.9 -r1.10 --- documentation.lisp 26 Aug 2003 17:46:57 -0000 1.9 +++ documentation.lisp 28 Aug 2003 09:07:58 -0000 1.10 @@ -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 Index: methods.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/pcl/methods.lisp,v retrieving revision 1.30 retrieving revision 1.31 diff -u -d -r1.30 -r1.31 --- methods.lisp 21 Aug 2003 11:38:42 -0000 1.30 +++ methods.lisp 28 Aug 2003 09:07:58 -0000 1.31 @@ -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*)) |