X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=5723f6c2cde7d84d0babd3552d16d9079f16f820;hb=a6103aace1e40d0948aeb090f7b5d5ca77fc293a;hp=066585cefec30871b0974631d8328c80d893c1b6;hpb=310d5f86d736ecf9525711b087b04797c549879c;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 066585c..5723f6c 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -557,21 +557,41 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (default '(unknown))) (and (null applyp) (or (not (eq *boot-state* 'complete)) - (compute-applicable-methods-emf-std-p gf)) - (notany (lambda (method) - (or (and (eq *boot-state* 'complete) - (some #'eql-specializer-p - (method-specializers method))) - (let ((value (method-function-get - (if early-p - (or (third method) (second method)) - (or (method-fast-function method) - (method-function method))) - :constant-value default))) - (if boolean-values-p - (not (or (eq value t) (eq value nil))) - (eq value default))))) - methods))))) + ;; If COMPUTE-APPLICABLE-METHODS is specialized, we + ;; can't use this, of course, because we can't tell + ;; which methods will be considered applicable. + ;; + ;; Also, don't use this dfun method if the generic + ;; function has a non-standard method combination, + ;; because if it has, it's not sure that method + ;; functions are used directly as effective methods, + ;; which CONSTANT-VALUE-MISS depends on. The + ;; pre-defined method combinations like LIST are + ;; examples of that. + (and (compute-applicable-methods-emf-std-p gf) + (eq (generic-function-method-combination gf) + *standard-method-combination*))) + ;; Check that no method is eql-specialized, and that all + ;; methods return a constant value. If BOOLEAN-VALUES-P, + ;; check that all return T or NIL. Also, check that no + ;; method has qualifiers, to make sure that emfs are really + ;; method functions; see above. + (dolist (method methods t) + (when (eq *boot-state* 'complete) + (when (or (some #'eql-specializer-p + (method-specializers method)) + (method-qualifiers method)) + (return nil))) + (let ((value (method-function-get + (if early-p + (or (third method) (second method)) + (or (method-fast-function method) + (method-function method))) + :constant-value default))) + (when (or (eq value default) + (and boolean-values-p + (not (member value '(t nil))))) + (return nil)))))))) (defun make-constant-value-dfun (generic-function &optional cache) (multiple-value-bind (nreq applyp metatypes nkeys) @@ -595,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 @@ -664,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)) @@ -743,17 +769,19 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; considered as state transitions. (defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) +(defvar *max-emf-precomputation-methods* 10) (defun finalize-specializers (gf) - (let ((all-finalized t)) - (dolist (method (generic-function-methods gf)) - (dolist (specializer (method-specializers method)) - (when (and (classp specializer) - (not (class-finalized-p specializer))) - (if (class-has-a-forward-referenced-superclass-p specializer) - (setq all-finalized nil) - (finalize-inheritance specializer))))) - all-finalized)) + (let ((methods (generic-function-methods gf))) + (when (<= (length methods) *max-emf-precomputation-methods*) + (let ((all-finalized t)) + (dolist (method methods all-finalized) + (dolist (specializer (method-specializers method)) + (when (and (classp specializer) + (not (class-finalized-p specializer))) + (if (class-has-a-forward-referenced-superclass-p specializer) + (setq all-finalized nil) + (finalize-inheritance specializer))))))))) (defun make-initial-dfun (gf) (let ((initial-dfun @@ -1036,17 +1064,19 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun constant-value-miss (generic-function args dfun-info) (let ((ocache (dfun-info-cache dfun-info))) (dfun-miss (generic-function args wrappers invalidp emf nil nil t) - (cond (invalidp) - (t - (let* ((function (typecase emf - (fast-method-call (fast-method-call-function - emf)) - (method-call (method-call-function emf)))) - (value (method-function-get function :constant-value)) - (ncache (fill-cache ocache wrappers value))) - (unless (eq ncache ocache) - (dfun-update generic-function - #'make-constant-value-dfun ncache)))))))) + (unless invalidp + (let* ((function + (typecase emf + (fast-method-call (fast-method-call-function emf)) + (method-call (method-call-function emf)))) + (value (let ((val (method-function-get + function :constant-value '.not-found.))) + (aver (not (eq val '.not-found.))) + val)) + (ncache (fill-cache ocache wrappers value))) + (unless (eq ncache ocache) + (dfun-update generic-function + #'make-constant-value-dfun ncache))))))) ;;; Given a generic function and a set of arguments to that generic ;;; function, return a mess of values. @@ -1110,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 @@ -1593,26 +1624,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 @@ -1631,8 +1655,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)) @@ -1669,11 +1693,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))