X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fdfun.lisp;h=6337b611b68f8bba06b61d99f4b147b962af1ab6;hb=2912f5f6c2acb2da3b9fcc0f5afd1ca89782a9f8;hp=624590376ff1d8d797eafe5b8e802b8de8d2d7c1;hpb=3b2fe8ed844834cfc975d63695fd2cb1b828f375;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 6245903..6337b61 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -615,7 +615,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf))) (when (eq *boot-state* 'complete) - (unless caching-p + (unless (or caching-p (gf-requires-emf-keyword-checks gf)) ;; This should return T when almost all dispatching is by ;; eql specializers or built-in classes. In other words, ;; return NIL if we might ever need to do more than @@ -684,14 +684,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (setq *wrapper-of-cost* 15) (setq *secondary-dfun-call-cost* 30) +(declaim (inline make-callable)) +(defun make-callable (gf methods generator method-alist wrappers) + (let* ((*applicable-methods* methods) + (callable (function-funcall generator method-alist wrappers))) + callable)) + (defun make-dispatch-dfun (gf) (values (get-dispatch-function gf) nil (dispatch-dfun-info))) (defun get-dispatch-function (gf) - (let ((methods (generic-function-methods gf))) - (function-funcall (get-secondary-dispatch-function1 gf methods nil nil nil - nil nil t) - nil nil))) + (let* ((methods (generic-function-methods gf)) + (generator (get-secondary-dispatch-function1 + gf methods nil nil nil nil nil t))) + (make-callable gf methods generator nil nil))) (defun make-final-dispatch-dfun (gf) (make-dispatch-dfun gf)) @@ -1134,11 +1140,12 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let* ((for-accessor-p (eq state 'accessor)) (for-cache-p (or (eq state 'caching) (eq state 'accessor))) (emf (if (or cam-std-p all-applicable-and-sorted-p) - (function-funcall (get-secondary-dispatch-function1 - gf methods types nil (and for-cache-p - wrappers) - all-applicable-and-sorted-p) - nil (and for-cache-p wrappers)) + (let ((generator + (get-secondary-dispatch-function1 + gf methods types nil (and for-cache-p wrappers) + all-applicable-and-sorted-p))) + (make-callable gf methods generator + nil (and for-cache-p wrappers))) (default-secondary-dispatch-function gf)))) (multiple-value-bind (index accessor-type) (and for-accessor-p all-applicable-and-sorted-p methods @@ -1469,9 +1476,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (return (setf (third c) t)))) (return nil)))))) -(defvar *in-precompute-effective-methods-p* nil) - -;used only in map-all-orders +;;; CMUCL comment: used only in map-all-orders (defun class-might-precede-p (class1 class2) (if (not *in-precompute-effective-methods-p*) (not (member class1 (cdr (class-precedence-list class2)))) @@ -1617,26 +1622,19 @@ 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)) - -(defun get-secondary-dispatch-function (gf methods types &optional - method-alist wrappers) - (function-funcall (get-secondary-dispatch-function1 - gf methods types - (not (null method-alist)) - (not (null wrappers)) - (not (methods-contain-eql-specializer-p methods))) - method-alist wrappers)) +(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) + (let ((generator + (get-secondary-dispatch-function1 + gf methods types (not (null method-alist)) (not (null wrappers)) + (not (methods-contain-eql-specializer-p methods))))) + (make-callable gf methods generator method-alist wrappers))) (defun get-secondary-dispatch-function1 (gf methods types method-alist-p wrappers-p @@ -1655,8 +1653,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)) @@ -1693,11 +1691,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun get-effective-method-function (gf methods &optional method-alist wrappers) - (function-funcall (get-secondary-dispatch-function1 gf methods nil - (not (null method-alist)) - (not (null wrappers)) - t) - method-alist wrappers)) + (let ((generator + (get-secondary-dispatch-function1 + gf methods nil (not (null method-alist)) (not (null wrappers)) t))) + (make-callable gf methods generator method-alist wrappers))) (defun get-effective-method-function1 (gf methods &optional (sorted-p t)) (get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))