X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=2b84a1856bbe75bbc4ea6c197393751ad0617082;hb=f3f677703e37f5a335b3be7fa64f7748ad969517;hp=2acc37e8827b72402f266f917dd7a9a83934d823;hpb=0756ed4c948806fe79460b1da00c2487cb5ad82b;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 2acc37e..2b84a18 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -209,11 +209,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (funcallable-standard-instance-access object location) (standard-instance-access object location)))) (when (eq +slot-unbound+ value) - (error "~@" + (error "~@" slot-name class object)) value) - (error "~@" + (error "~@" slot-name class object)))) (defun standard-slot-value/gf (gf slot-name) @@ -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)) @@ -764,16 +770,21 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defvar *lazy-dfun-compute-p* t) (defvar *early-p* nil) +(declaim (type (or null unsigned-byte) *max-emf-precomputation-methods*)) +(defvar *max-emf-precomputation-methods* nil) + (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 (or (null *max-emf-precomputation-methods*) + (<= (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 @@ -1132,11 +1143,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 @@ -1203,15 +1215,22 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; function GF which reads/writes instances of class CLASS. ;;; TYPE is one of the symbols READER or WRITER. (defun find-standard-class-accessor-method (gf class type) - (dolist (method (standard-slot-value/gf gf 'methods)) - (let ((specializers (standard-slot-value/method method 'specializers)) - (qualifiers (plist-value method 'qualifiers))) - (when (and (null qualifiers) - (eq (ecase type - (reader (car specializers)) - (writer (cadr specializers))) - class)) - (return method))))) + (let ((cpl (standard-slot-value/class class 'class-precedence-list)) + (found-specializer *the-class-t*) + (found-method nil)) + (dolist (method (standard-slot-value/gf gf 'methods) found-method) + (let ((specializers (standard-slot-value/method method 'specializers)) + (qualifiers (plist-value method 'qualifiers))) + (when (and (null qualifiers) + (let ((subcpl (member (ecase type + (reader (car specializers)) + (writer (cadr specializers))) + cpl))) + (and subcpl (member found-specializer subcpl)))) + (setf found-specializer (ecase type + (reader (car specializers)) + (writer (cadr specializers)))) + (setf found-method method)))))) (defun accessor-values (gf arg-info classes methods) (declare (ignore gf)) @@ -1467,9 +1486,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)))) @@ -1484,7 +1501,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun cpl-or-nil (class) (if (eq *boot-state* 'complete) - (when (class-finalized-p class) + ;; KLUDGE: why not use (slot-boundp class + ;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is + ;; used within COMPUTE-APPLICABLE-METHODS, including for + ;; SLOT-BOUNDP-USING-CLASS... and the available mechanism for + ;; breaking such nasty cycles in effective method computation + ;; only works for readers and writers, not boundps. It might + ;; not be too hard to make it work for BOUNDP accessors, but in + ;; the meantime we use an extra slot for exactly the result of + ;; the SLOT-BOUNDP that we want. (We cannot use + ;; CLASS-FINALIZED-P, because in the process of class + ;; finalization we need to use the CPL which has been computed + ;; to cache effective methods for slot accessors.) -- CSR, + ;; 2004-09-19. + (when (cpl-available-p class) (class-precedence-list class)) (early-class-precedence-list class))) @@ -1615,26 +1645,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 @@ -1653,8 +1676,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)) @@ -1691,11 +1714,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))