X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=2b84a1856bbe75bbc4ea6c197393751ad0617082;hb=b86f43bae31f775d834c724e21f0f573b968f695;hp=cc6d267f4f4d591dcdfc3bba19671fcae7960b90;hpb=a57db6f5ee029a4c9817ae239d7bbefd3fb8374e;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index cc6d267..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)) @@ -763,11 +769,14 @@ 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) + +(declaim (type (or null unsigned-byte) *max-emf-precomputation-methods*)) +(defvar *max-emf-precomputation-methods* nil) (defun finalize-specializers (gf) (let ((methods (generic-function-methods gf))) - (when (<= (length methods) *max-emf-precomputation-methods*) + (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)) @@ -1134,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 @@ -1205,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)) @@ -1469,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)))) @@ -1486,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))) @@ -1623,14 +1651,13 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dolist (method (generic-function-methods generic-function)) (remhash method *effective-method-cache*))) -(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)) +(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 @@ -1687,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))