(every (lambda (mt) (eq mt t)) metatypes)))
(defun use-caching-dfun-p (generic-function)
- (some (lambda (method)
- (let ((fmf (if (listp method)
- (third method)
- (method-fast-function method))))
- (method-function-get fmf :slot-name-lists)))
+ (some (lambda (method) (method-plist-value method :slot-name-lists))
;; KLUDGE: As of sbcl-0.6.4, it's very important for
;; efficiency to know the type of the sequence argument to
;; quantifiers (SOME/NOTANY/etc.) at compile time, but
(dolist (method methods t)
(when (eq *boot-state* 'complete)
(when (or (some #'eql-specializer-p
- (method-specializers method))
- (method-qualifiers method))
+ (safe-method-specializers method))
+ (safe-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)))
+ (let ((value (method-plist-value method :constant-value default)))
(when (or (eq value default)
(and boolean-values-p
(not (member value '(t nil)))))
(let ((cdc (caching-dfun-cost gf))) ; fast
(> cdc (dispatch-dfun-cost gf cdc))))))
-(defparameter *non-built-in-typep-cost* 1)
-(defparameter *structure-typep-cost* 1)
-(defparameter *built-in-typep-cost* 0)
+(defparameter *non-built-in-typep-cost* 100)
+(defparameter *structure-typep-cost* 15)
+(defparameter *built-in-typep-cost* 5)
;;; According to comments in the original CMU CL version of PCL,
;;; the cost LIMIT is important to cut off exponential growth for
max-cost-so-far))
#'identity))
-(defparameter *cache-lookup-cost* 1)
-(defparameter *wrapper-of-cost* 0)
-(defparameter *secondary-dfun-call-cost* 1)
+(defparameter *cache-lookup-cost* 30)
+(defparameter *wrapper-of-cost* 15)
+(defparameter *secondary-dfun-call-cost* 30)
(defun caching-dfun-cost (gf)
(let ((nreq (get-generic-fun-info gf)))
*secondary-dfun-call-cost*
0))))
-(setq *non-built-in-typep-cost* 100)
-(setq *structure-typep-cost* 15)
-(setq *built-in-typep-cost* 5)
-(setq *cache-lookup-cost* 30)
-(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)
(defvar *lazy-dfun-compute-p* t)
(defvar *early-p* nil)
+;;; This variable is used for controlling the load-time effective
+;;; method precomputation: precomputation will only be done for emfs
+;;; with fewer than methods than this value. This value has
+;;; traditionally been NIL on SBCL (meaning that precomputation will
+;;; always be done) but that makes method loading O(n^2). Use a small
+;;; value for now, to flush out any possible problems that doing a
+;;; limited amount of precomputation might cause. If none appear, we
+;;; might change it to a larger value later. -- JES, 2006-12-01
(declaim (type (or null unsigned-byte) *max-emf-precomputation-methods*))
-(defvar *max-emf-precomputation-methods* nil)
+(defvar *max-emf-precomputation-methods* 1)
(defun finalize-specializers (gf)
(let ((methods (generic-function-methods gf)))
(defvar *new-class* nil)
-(defvar *free-hash-tables* (mapcar #'list '(eq equal eql)))
-
-(defmacro with-hash-table ((table test) &body forms)
- `(let* ((.free. (assoc ',test *free-hash-tables*))
- (,table (if (cdr .free.)
- (pop (cdr .free.))
- (make-hash-table :test ',test))))
- (multiple-value-prog1
- (progn ,@forms)
- (clrhash ,table)
- (push ,table (cdr .free.)))))
-
-(defmacro with-eq-hash-table ((table) &body forms)
- `(with-hash-table (,table eq) ,@forms))
-
(defun final-accessor-dfun-type (gf)
(let ((methods (if (early-gf-p gf)
(early-gf-methods gf)
(generic-function-methods gf))))
(cond ((every (lambda (method)
(if (consp method)
- (eq *the-class-standard-reader-method*
- (early-method-class method))
- (standard-reader-method-p method)))
+ (let ((class (early-method-class method)))
+ (or (eq class *the-class-standard-reader-method*)
+ (eq class *the-class-global-reader-method*)))
+ (or (standard-reader-method-p method)
+ (global-reader-method-p method))))
methods)
'reader)
((every (lambda (method)
(if (consp method)
- (eq *the-class-standard-boundp-method*
- (early-method-class method))
- (standard-boundp-method-p method)))
+ (let ((class (early-method-class method)))
+ (or (eq class *the-class-standard-boundp-method*)
+ (eq class *the-class-global-boundp-method*)))
+ (or (standard-boundp-method-p method)
+ (global-boundp-method-p method))))
methods)
'boundp)
((every (lambda (method)
(if (consp method)
- (eq *the-class-standard-writer-method*
- (early-method-class method))
- (standard-writer-method-p method)))
+ (let ((class (early-method-class method)))
+ (or (eq class *the-class-standard-writer-method*)
+ (eq class *the-class-global-writer-method*)))
+ (and
+ (or (standard-writer-method-p method)
+ (global-writer-method-p method))
+ (not (safe-p
+ (slot-definition-class
+ (accessor-method-slot-definition method)))))))
methods)
'writer))))
(defun make-final-accessor-dfun (gf type &optional classes-list new-class)
- (with-eq-hash-table (table)
+ (let ((table (make-hash-table :test #'eq)))
(multiple-value-bind (table all-index first second size no-class-slots-p)
(make-accessor-table gf type table)
(if table
(t
(make-final-caching-dfun gf classes-list new-class)))))
-(defvar *accessor-miss-history* nil)
(defun accessor-miss (gf new object dfun-info)
- (let ((wrapper (wrapper-of object))
- (previous-miss (assq gf *accessor-miss-history*)))
- (when (eq wrapper (cdr previous-miss))
- (error "~@<Vicious metacircle: The computation of a ~
- dfun of ~s for argument ~s uses the dfun being ~
- computed.~@:>"
- gf object))
- (let* ((*accessor-miss-history* (acons gf wrapper *accessor-miss-history*))
- (ostate (type-of dfun-info))
- (otype (dfun-info-accessor-type dfun-info))
- oindex ow0 ow1 cache
- (args (ecase otype
- ((reader boundp) (list object))
- (writer (list new object)))))
- (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
- ;; The following lexical functions change the state of the
- ;; dfun to that which is their name. They accept arguments
- ;; which are the parameters of the new state, and get other
- ;; information from the lexical variables bound above.
- (flet ((two-class (index w0 w1)
- (when (zerop (random 2)) (psetf w0 w1 w1 w0))
+ (let* ((ostate (type-of dfun-info))
+ (otype (dfun-info-accessor-type dfun-info))
+ oindex ow0 ow1 cache
+ (args (ecase otype
+ ((reader boundp) (list object))
+ (writer (list new object)))))
+ (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
+ ;; The following lexical functions change the state of the
+ ;; dfun to that which is their name. They accept arguments
+ ;; which are the parameters of the new state, and get other
+ ;; information from the lexical variables bound above.
+ (flet ((two-class (index w0 w1)
+ (when (zerop (random 2 *pcl-misc-random-state*))
+ (psetf w0 w1 w1 w0))
(dfun-update gf
#'make-two-class-accessor-dfun
ntype
(setq cache (dfun-info-cache dfun-info))
(if (consp nindex)
(caching)
- (do-fill #'n-n)))))))))))
+ (do-fill #'n-n))))))))))
(defun checking-miss (generic-function args dfun-info)
(let ((oemf (dfun-info-function dfun-info))
(let ((ocache (dfun-info-cache dfun-info)))
(dfun-miss (generic-function args wrappers invalidp emf nil nil t)
(unless invalidp
- (let* ((function
+ (let* ((value
(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))
+ (constant-fast-method-call
+ (constant-fast-method-call-value emf))
+ (constant-method-call (constant-method-call-value emf))
+ (t (bug "~S with non-constant EMF ~S"
+ 'constant-value-miss emf))))
(ncache (fill-cache ocache wrappers value)))
(unless (eq ncache ocache)
(dfun-update generic-function
;;; 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)
- (let ((cpl (standard-slot-value/class class 'class-precedence-list))
+ (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)))
+ (qualifiers (standard-slot-value/method method 'qualifiers)))
(when (and (null qualifiers)
(let ((subcpl (member (ecase type
(reader (car specializers))
(dolist (meth methods)
(when (if (consp meth)
(early-method-qualifiers meth)
- (method-qualifiers meth))
+ (safe-method-qualifiers meth))
(return-from accessor-values-internal (values nil nil))))
(let* ((meth (car methods))
(early-p (not (eq *boot-state* 'complete)))
(if early-p
(not (eq *the-class-standard-method*
(early-method-class meth)))
- (standard-accessor-method-p meth))
+ (accessor-method-p meth))
(if early-p
(early-accessor-method-slot-name meth)
(accessor-method-slot-name meth))))))
(find-slot-definition accessor-class slot-name)))))
(when (and slotd
(or early-p
- (slot-accessor-std-p slotd accessor-type)))
+ (slot-accessor-std-p slotd accessor-type))
+ (or early-p
+ (not (safe-p accessor-class))))
(values (if early-p
(early-slot-definition-location slotd)
(slot-definition-location slotd))
method))
(accessor-method-slot-name method))))
(when (or (null specl-cpl)
+ (null so-p)
(member *the-class-structure-object* specl-cpl))
(return-from make-accessor-table nil))
- (maphash (lambda (class slotd)
- (let ((cpl (if early-p
- (early-class-precedence-list class)
- (class-precedence-list class))))
- (when (memq specl cpl)
- (unless (and (or so-p
- (member *the-class-standard-object*
- cpl))
- (or early-p
- (slot-accessor-std-p slotd type)))
+ ;; Collect all the slot-definitions for SLOT-NAME from SPECL and
+ ;; all of its subclasses. If either SPECL or one of the subclasses
+ ;; is not a standard-class, bail out.
+ (labels ((aux (class)
+ ;; FIND-SLOT-DEFINITION might not be defined yet
+ (let ((slotd (find-if (lambda (x)
+ (eq (sb-pcl::slot-definition-name x)
+ slot-name))
+ (sb-pcl::class-slots class))))
+ (when slotd
+ (unless (or early-p
+ (slot-accessor-std-p slotd type))
(return-from make-accessor-table nil))
- (push (cons specl slotd) (gethash class table)))))
- (gethash slot-name *name->class->slotd-table*))))
+ (push (cons specl slotd) (gethash class table))))
+ (dolist (subclass (sb-pcl::class-direct-subclasses class))
+ (aux subclass))))
+ (aux specl))))
(maphash (lambda (class specl+slotd-list)
(dolist (sclass (if early-p
(early-class-precedence-list class)
(let ((definite-p t) (possibly-applicable-methods nil))
(dolist (method (if (early-gf-p generic-function)
(early-gf-methods generic-function)
- (if (eq (class-of generic-function)
- *the-class-standard-generic-function*)
- ;; KLUDGE: see comment by GET-GENERIC-FUN-INFO
- (clos-slots-ref (fsc-instance-slots generic-function) *sgf-methods-index*)
- (generic-function-methods generic-function))))
+ (safe-generic-function-methods generic-function)))
(let ((specls (if (consp method)
(early-method-specializers method t)
- (method-specializers method)))
+ (safe-method-specializers method)))
(types types)
(possibly-applicable-p t) (applicable-p t))
(dolist (specl specls)
(defun order-specializers (specl1 specl2 index compare-classes-function)
(let ((type1 (if (eq *boot-state* 'complete)
(specializer-type specl1)
- (!bootstrap-get-slot 'specializer specl1 'type)))
+ (!bootstrap-get-slot 'specializer specl1 '%type)))
(type2 (if (eq *boot-state* 'complete)
(specializer-type specl2)
- (!bootstrap-get-slot 'specializer specl2 'type))))
+ (!bootstrap-get-slot 'specializer specl2 '%type))))
(cond ((eq specl1 specl2)
nil)
((atom type1)
(defun cpl-or-nil (class)
(if (eq *boot-state* 'complete)
- ;; 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))
+ (progn
+ ;; 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)
+ (return-from cpl-or-nil (class-precedence-list class)))
+
+ ;; if we can finalize an unfinalized class, then do so
+ (when (and (not (class-finalized-p class))
+ (not (class-has-a-forward-referenced-superclass-p class)))
+ (finalize-inheritance class)
+ (class-precedence-list class)))
+
(early-class-precedence-list class)))
(defun saut-and (specl type)
'specializer-applicable-using-type-p
type)))))
-(defun map-all-classes (function &optional (root t))
- (let ((braid-p (or (eq *boot-state* 'braid)
+(defun map-all-classes (fun &optional (root t))
+ (let ((all-classes (make-hash-table :test 'eq))
+ (braid-p (or (eq *boot-state* 'braid)
(eq *boot-state* 'complete))))
(labels ((do-class (class)
- (mapc #'do-class
- (if braid-p
- (class-direct-subclasses class)
- (early-class-direct-subclasses class)))
- (funcall function class)))
+ (unless (gethash class all-classes)
+ (setf (gethash class all-classes) t)
+ (funcall fun class)
+ (mapc #'do-class
+ (if braid-p
+ (class-direct-subclasses class)
+ (early-class-direct-subclasses class))))))
(do-class (if (symbolp root)
(find-class root)
- root)))))
+ root)))
+ nil))
\f
+;;; FIXME: Needs a lock.
(defvar *effective-method-cache* (make-hash-table :test 'eq))
(defun flush-effective-method-cache (generic-function)