(funcallable-standard-instance-access object location)
(standard-instance-access object location))))
(when (eq +slot-unbound+ value)
- (error "~@<slot ~s of class ~s is unbound in object ~s~@:>"
+ (error "~@<slot ~S of class ~S is unbound in object ~S~@:>"
slot-name class object))
value)
- (error "~@<cannot get standard value of slot ~s of class ~s ~
- in object ~s~@:>"
+ (error "~@<cannot get standard value of slot ~S of class ~S ~
+ in object ~S~@:>"
slot-name class object))))
(defun standard-slot-value/gf (gf slot-name)
(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)
(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
(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))
(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
(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)))))))
\f
;;; Given a generic function and a set of arguments to that generic
;;; function, return a mess of values.
(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
;;; 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))
(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))))
(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)))
(find-class root)
root)))))
\f
-;;; 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
(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))
(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))