X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=6337b611b68f8bba06b61d99f4b147b962af1ab6;hb=2912f5f6c2acb2da3b9fcc0f5afd1ca89782a9f8;hp=9d59ea8be510569cfa6fb8bb5160e4c5df705e1a;hpb=2217cdb364e8b48c187b085895bb2a5cbdbd9622;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 9d59ea8..6337b61 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -75,6 +75,8 @@ have to do any method lookup to implement itself. And so, we are saved. +Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 + |# ;;; an alist in which each entry is of the form @@ -171,6 +173,62 @@ And so, we are saved. collect)))) (nreverse collect))))) +;;; Standardized class slot access: when trying to break vicious +;;; metacircles, we need a way to get at the values of slots of some +;;; standard classes without going through the whole meta machinery, +;;; because that would likely enter the vicious circle again. The +;;; following are helper functions that short-circuit the generic +;;; lookup machinery. + +(defvar *standard-classes* + '(standard-method standard-generic-function standard-class + standard-effective-slot-definition)) + +(defvar *standard-slot-locations* (make-hash-table :test 'equal)) + +(defun compute-standard-slot-locations () + (clrhash *standard-slot-locations*) + (dolist (class-name *standard-classes*) + (let ((class (find-class class-name))) + (dolist (slot (class-slots class)) + (setf (gethash (cons class (slot-definition-name slot)) + *standard-slot-locations*) + (slot-definition-location slot)))))) + +;;; FIXME: harmonize the names between COMPUTE-STANDARD-SLOT-LOCATIONS +;;; and MAYBE-UPDATE-STANDARD-CLASS-LOCATIONS. +(defun maybe-update-standard-class-locations (class) + (when (and (eq *boot-state* 'complete) + (memq (class-name class) *standard-classes*)) + (compute-standard-slot-locations))) + +(defun standard-slot-value (object slot-name class) + (let ((location (gethash (cons class slot-name) *standard-slot-locations*))) + (if location + (let ((value (if (funcallable-instance-p object) + (funcallable-standard-instance-access object location) + (standard-instance-access object location)))) + (when (eq +slot-unbound+ value) + (error "~@" + slot-name class object)) + value) + (error "~@" + slot-name class object)))) + +(defun standard-slot-value/gf (gf slot-name) + (standard-slot-value gf slot-name *the-class-standard-generic-function*)) + +(defun standard-slot-value/method (method slot-name) + (standard-slot-value method slot-name *the-class-standard-method*)) + +(defun standard-slot-value/eslotd (slotd slot-name) + (standard-slot-value slotd slot-name + *the-class-standard-effective-slot-definition*)) + +(defun standard-slot-value/class (class slot-name) + (standard-slot-value class slot-name *the-class-standard-class*)) + ;;; When all the methods of a generic function are automatically ;;; generated reader or writer methods a number of special ;;; optimizations are possible. These are important because of the @@ -499,21 +557,41 @@ And so, we are saved. (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) @@ -537,7 +615,7 @@ And so, we are saved. (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 @@ -606,14 +684,20 @@ And so, we are saved. (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)) @@ -628,8 +712,7 @@ And so, we are saved. (maphash (lambda (classes value) (setq cache (fill-cache cache (class-wrapper classes) - value - t))) + value))) table) cache)) @@ -686,56 +769,78 @@ And so, we are saved. ;;; 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 ((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 - #'(sb-kernel:instance-lambda (&rest args) + #'(instance-lambda (&rest args) (initial-dfun gf args)))) (multiple-value-bind (dfun cache info) - (if (and (eq *boot-state* 'complete) - (compute-applicable-methods-emf-std-p gf)) - (let* ((caching-p (use-caching-dfun-p gf)) - (classes-list (precompute-effective-methods - gf caching-p - (not *lazy-dfun-compute-p*)))) - (if *lazy-dfun-compute-p* - (cond ((use-dispatch-dfun-p gf caching-p) - (values initial-dfun - nil - (initial-dispatch-dfun-info))) - (caching-p - (insure-caching-dfun gf) - (values initial-dfun nil (initial-dfun-info))) - (t - (values initial-dfun nil (initial-dfun-info)))) - (make-final-dfun-internal gf classes-list))) - (let ((arg-info (if (early-gf-p gf) - (early-gf-arg-info gf) - (gf-arg-info gf))) - (type nil)) - (if (and (gf-precompute-dfun-and-emf-p arg-info) - (setq type (final-accessor-dfun-type gf))) - (if *early-p* - (values (make-early-accessor gf type) nil nil) - (make-final-accessor-dfun gf type)) - (values initial-dfun nil (initial-dfun-info))))) + (cond + ((and (eq *boot-state* 'complete) + (not (finalize-specializers gf))) + (values initial-dfun nil (initial-dfun-info))) + ((and (eq *boot-state* 'complete) + (compute-applicable-methods-emf-std-p gf)) + (let* ((caching-p (use-caching-dfun-p gf)) + ;; KLUDGE: the only effect of this (when + ;; *LAZY-DFUN-COMPUTE-P* is true, as it usually is) + ;; is to signal an error when we try to add methods + ;; with the wrong qualifiers to a generic function. + (classes-list (precompute-effective-methods + gf caching-p + (not *lazy-dfun-compute-p*)))) + (if *lazy-dfun-compute-p* + (cond ((use-dispatch-dfun-p gf caching-p) + (values initial-dfun + nil + (initial-dispatch-dfun-info))) + (caching-p + (insure-caching-dfun gf) + (values initial-dfun nil (initial-dfun-info))) + (t + (values initial-dfun nil (initial-dfun-info)))) + (make-final-dfun-internal gf classes-list)))) + (t + (let ((arg-info (if (early-gf-p gf) + (early-gf-arg-info gf) + (gf-arg-info gf))) + (type nil)) + (if (and (gf-precompute-dfun-and-emf-p arg-info) + (setq type (final-accessor-dfun-type gf))) + (if *early-p* + (values (make-early-accessor gf type) nil nil) + (make-final-accessor-dfun gf type)) + (values initial-dfun nil (initial-dfun-info)))))) (set-dfun gf dfun cache info)))) (defun make-early-accessor (gf type) (let* ((methods (early-gf-methods gf)) (slot-name (early-method-standard-accessor-slot-name (car methods)))) (ecase type - (reader #'(sb-kernel:instance-lambda (instance) + (reader #'(instance-lambda (instance) (let* ((class (class-of instance)) (class-name (!bootstrap-get-slot 'class class 'name))) (!bootstrap-get-slot class-name instance slot-name)))) - (boundp #'(sb-kernel:instance-lambda (instance) + (boundp #'(instance-lambda (instance) (let* ((class (class-of instance)) (class-name (!bootstrap-get-slot 'class class 'name))) (not (eq +slot-unbound+ (!bootstrap-get-slot class-name instance slot-name)))))) - (writer #'(sb-kernel:instance-lambda (new-value instance) + (writer #'(instance-lambda (new-value instance) (let* ((class (class-of instance)) (class-name (!bootstrap-get-slot 'class class 'name))) (!bootstrap-set-slot class-name instance slot-name new-value))))))) @@ -829,7 +934,7 @@ And so, we are saved. specls all-same-p) (cond ((null methods) (values - #'(sb-kernel:instance-lambda (&rest args) + #'(instance-lambda (&rest args) (apply #'no-applicable-method gf args)) nil (no-methods-dfun-info))) @@ -959,17 +1064,19 @@ And so, we are saved. (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. @@ -1001,6 +1108,8 @@ And so, we are saved. ;;; If is READER or WRITER, and the slot accessed is ;;; an :instance slot, this is the index number of that slot ;;; in the object argument. +(defvar *cache-miss-values-stack* ()) + (defun cache-miss-values (gf args state) (multiple-value-bind (nreq applyp metatypes nkeys arg-info) (get-generic-fun-info gf) @@ -1017,26 +1126,101 @@ And so, we are saved. accessor-type index))))) (defun cache-miss-values-internal (gf arg-info wrappers classes types state) + (if (and classes (equal classes (cdr (assq gf *cache-miss-values-stack*)))) + (break-vicious-metacircle gf classes arg-info) + (let ((*cache-miss-values-stack* + (acons gf classes *cache-miss-values-stack*)) + (cam-std-p (or (null arg-info) + (gf-info-c-a-m-emf-std-p arg-info)))) + (multiple-value-bind (methods all-applicable-and-sorted-p) + (if cam-std-p + (compute-applicable-methods-using-types gf types) + (compute-applicable-methods-using-classes gf classes)) + (let* ((for-accessor-p (eq state 'accessor)) (for-cache-p (or (eq state 'caching) (eq state 'accessor))) - (cam-std-p (or (null arg-info) - (gf-info-c-a-m-emf-std-p arg-info)))) - (multiple-value-bind (methods all-applicable-and-sorted-p) - (if cam-std-p - (compute-applicable-methods-using-types gf types) - (compute-applicable-methods-using-classes gf classes)) - (let ((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)) - (default-secondary-dispatch-function gf)))) - (multiple-value-bind (index accessor-type) - (and for-accessor-p all-applicable-and-sorted-p methods - (accessor-values gf arg-info classes methods)) - (values (if (integerp index) index emf) - methods accessor-type index)))))) + (emf (if (or cam-std-p all-applicable-and-sorted-p) + (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 + (accessor-values gf arg-info classes methods)) + (values (if (integerp index) index emf) + methods accessor-type index))))))) + +;;; Try to break a vicious circle while computing a cache miss. +;;; GF is the generic function, CLASSES are the classes of actual +;;; arguments, and ARG-INFO is the generic functions' arg-info. +;;; +;;; A vicious circle can be entered when the computation of the cache +;;; miss values itself depends on the values being computed. For +;;; instance, adding a method which is an instance of a subclass of +;;; STANDARD-METHOD leads to cache misses for slot accessors of +;;; STANDARD-METHOD like METHOD-SPECIALIZERS, and METHOD-SPECIALIZERS +;;; is itself used while we compute cache miss values. +(defun break-vicious-metacircle (gf classes arg-info) + (when (typep gf 'standard-generic-function) + (multiple-value-bind (class slotd accessor-type) + (accesses-standard-class-slot-p gf) + (when class + (let ((method (find-standard-class-accessor-method + gf class accessor-type)) + (index (standard-slot-value/eslotd slotd 'location)) + (type (gf-info-simple-accessor-type arg-info))) + (when (and method + (subtypep (ecase accessor-type + ((reader) (car classes)) + ((writer) (cadr classes))) + class)) + (return-from break-vicious-metacircle + (values index (list method) type index))))))) + (error "~@" + gf classes)) + +;;; Return (CLASS SLOTD ACCESSOR-TYPE) if some method of generic +;;; function GF accesses a slot of some class in *STANDARD-CLASSES*. +;;; CLASS is the class accessed, SLOTD is the effective slot definition +;;; object of the slot accessed, and ACCESSOR-TYPE is one of the symbols +;;; READER or WRITER describing the slot access. +(defun accesses-standard-class-slot-p (gf) + (flet ((standard-class-slot-access (gf class) + (loop with gf-name = (standard-slot-value/gf gf 'name) + for slotd in (standard-slot-value/class class 'slots) + ;; FIXME: where does BOUNDP fit in here? Is it + ;; relevant? + as readers = (standard-slot-value/eslotd slotd 'readers) + as writers = (standard-slot-value/eslotd slotd 'writers) + if (member gf-name readers :test #'equal) + return (values slotd 'reader) + else if (member gf-name writers :test #'equal) + return (values slotd 'writer)))) + (dolist (class-name *standard-classes*) + (let ((class (find-class class-name))) + (multiple-value-bind (slotd accessor-type) + (standard-class-slot-access gf class) + (when slotd + (return (values class slotd accessor-type)))))))) + +;;; Find a slot reader/writer method among the methods of generic +;;; 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))))) (defun accessor-values (gf arg-info classes methods) (declare (ignore gf)) @@ -1292,9 +1476,7 @@ And so, we are saved. (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)))) @@ -1307,6 +1489,12 @@ And so, we are saved. (mapcar (lambda (x) (position x lambda-list)) argument-precedence-order))) +(defun cpl-or-nil (class) + (if (eq *boot-state* 'complete) + (when (class-finalized-p class) + (class-precedence-list class)) + (early-class-precedence-list class))) + (defun saut-and (specl type) (let ((applicable nil) (possibly-applicable t)) @@ -1330,8 +1518,8 @@ And so, we are saved. (defun saut-not-class (specl ntype) (let* ((class (type-class specl)) - (cpl (class-precedence-list class))) - (not (memq (cadr ntype) cpl)))) + (cpl (cpl-or-nil class))) + (not (memq (cadr ntype) cpl)))) (defun saut-not-prototype (specl ntype) (let* ((class (case (car specl) @@ -1339,8 +1527,8 @@ And so, we are saved. (class-eq (cadr specl)) (prototype (cadr specl)) (class (cadr specl)))) - (cpl (class-precedence-list class))) - (not (memq (cadr ntype) cpl)))) + (cpl (cpl-or-nil class))) + (not (memq (cadr ntype) cpl)))) (defun saut-not-class-eq (specl ntype) (let ((class (case (car specl) @@ -1354,9 +1542,7 @@ And so, we are saved. (t t))) (defun class-applicable-using-class-p (specl type) - (let ((pred (memq specl (if (eq *boot-state* 'complete) - (class-precedence-list type) - (early-class-precedence-list type))))) + (let ((pred (memq specl (cpl-or-nil type)))) (values pred (or pred (if (not *in-precompute-effective-methods-p*) @@ -1378,7 +1564,7 @@ And so, we are saved. (class (class-applicable-using-class-p (cadr specl) (cadr type))) (t (values nil (let ((class (type-class specl))) (memq (cadr type) - (class-precedence-list class))))))) + (cpl-or-nil class))))))) (defun saut-class-eq (specl type) (if (eq (car specl) 'eql) @@ -1388,11 +1574,7 @@ And so, we are saved. (eq (cadr specl) (cadr type))) (class (or (eq (cadr specl) (cadr type)) - (memq (cadr specl) - (if (eq *boot-state* 'complete) - (class-precedence-list (cadr type)) - (early-class-precedence-list - (cadr type))))))))) + (memq (cadr specl) (cpl-or-nil (cadr type)))))))) (values pred pred)))) (defun saut-prototype (specl type) @@ -1405,10 +1587,7 @@ And so, we are saved. (class-eq (eq (cadr specl) (class-of (cadr type)))) (class (memq (cadr specl) (let ((class (class-of (cadr type)))) - (if (eq *boot-state* 'complete) - (class-precedence-list class) - (early-class-precedence-list - class)))))))) + (cpl-or-nil class))))))) (values pred pred))) (defun specializer-applicable-using-type-p (specl type) @@ -1443,26 +1622,19 @@ And so, we are saved. (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 @@ -1474,15 +1646,15 @@ And so, we are saved. (if function-p (lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) - #'(sb-kernel:instance-lambda (&rest args) + #'(instance-lambda (&rest args) (apply #'no-applicable-method gf args))) (lambda (method-alist wrappers) (declare (ignore method-alist wrappers)) (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)) @@ -1519,11 +1691,10 @@ And so, we are saved. (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)) @@ -1539,15 +1710,13 @@ And so, we are saved. (let* ((early-p (early-gf-p generic-function)) (gf-name (if early-p (!early-gf-name generic-function) - (generic-function-name generic-function))) - (ocache (gf-dfun-cache generic-function))) + (generic-function-name generic-function)))) (set-dfun generic-function dfun cache info) (let ((dfun (if early-p (or dfun (make-initial-dfun generic-function)) (compute-discriminating-function generic-function)))) - (set-funcallable-instance-fun generic-function dfun) + (set-funcallable-instance-function generic-function dfun) (set-fun-name generic-function gf-name) - (when (and ocache (not (eq ocache cache))) (free-cache ocache)) dfun))) (defvar *dfun-count* nil)