;;; lookup machinery.
(defvar *standard-classes*
+ ;; KLUDGE: order matters! finding effective slot definitions
+ ;; involves calling slot-definition-name, and we need to do that to
+ ;; break metacycles, so STANDARD-EFFECTIVE-SLOT-DEFINITION must
+ ;; precede STANDARD-DIRECT-SLOT-DEFINITION in this list, at least
+ ;; until ACCESSES-STANDARD-CLASS-SLOT-P is generalized
'(standard-method standard-generic-function standard-class
- standard-effective-slot-definition))
+ standard-effective-slot-definition standard-direct-slot-definition))
(defvar *standard-slot-locations* (make-hash-table :test 'equal))
(standard-slot-value slotd slot-name
*the-class-standard-effective-slot-definition*))
+(defun standard-slot-value/dslotd (slotd slot-name)
+ (standard-slot-value slotd slot-name
+ *the-class-standard-direct-slot-definition*))
+
(defun standard-slot-value/class (class slot-name)
(standard-slot-value class slot-name *the-class-standard-class*))
\f
(:include dfun-info)
(:copier nil)))
-(defstruct (initial-dispatch (:constructor initial-dispatch-dfun-info ())
- (:include dfun-info)
- (:copier nil)))
-
(defstruct (dispatch (:constructor dispatch-dfun-info ())
(:include dfun-info)
(:copier nil)))
(make-dispatch-dfun gf))
(defun update-dispatch-dfuns ()
- (dolist (gf (gfs-of-type '(dispatch initial-dispatch)))
+ (dolist (gf (gfs-of-type '(dispatch)))
(dfun-update gf #'make-dispatch-dfun)))
(defun make-final-ordinary-dfun-cache
(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* 1)
-
-(defun finalize-specializers (gf)
- (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
- #'(lambda (&rest args)
- (initial-dfun gf args))))
+ (let ((initial-dfun #'(lambda (&rest args) (initial-dfun gf args))))
(multiple-value-bind (dfun cache 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))))))
+ (if (eq **boot-state** 'complete)
+ (values initial-dfun nil (initial-dfun-info))
+ (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)
;;; 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))))
+ (labels
+ ((all-dslotds (class &aux done)
+ (labels ((all-dslotds-aux (class)
+ (if (or (member class done) (not (eq (class-of class) *the-class-standard-class*)))
+ nil
+ (progn
+ (push class done)
+ (append (standard-slot-value/class class 'direct-slots)
+ (mapcan #'(lambda (c)
+ (copy-list (all-dslotds-aux c)))
+ (standard-slot-value/class class 'direct-superclasses)))))))
+ (all-dslotds-aux class)))
+ (standard-class-slot-access (gf class)
+
+ (loop with gf-name = (standard-slot-value/gf gf 'name)
+ with eslotds = (standard-slot-value/class class 'slots)
+ with dslotds = (all-dslotds class)
+ for dslotd in dslotds
+ as readers = (standard-slot-value/dslotd dslotd 'readers)
+ as writers = (standard-slot-value/dslotd dslotd 'writers)
+ as name = (standard-slot-value/dslotd dslotd 'name)
+ as eslotd = (find name eslotds :key (lambda (x) (standard-slot-value/eslotd x 'name)))
+ if (member gf-name readers :test #'equal)
+ return (values eslotd 'reader)
+ else if (member gf-name writers :test #'equal)
+ return (values eslotd 'writer))))
(dolist (class-name *standard-classes*)
(let ((class (find-class class-name)))
(multiple-value-bind (slotd accessor-type)
(accessor-values-internal accessor-type accessor-class methods)))
(defun accessor-values-internal (accessor-type accessor-class methods)
+ (unless accessor-class
+ (return-from accessor-values-internal (values nil nil)))
(dolist (meth methods)
(when (if (consp meth)
(early-method-qualifiers meth)
(return-from accessor-values-internal (values nil nil))))
(let* ((meth (car methods))
(early-p (not (eq **boot-state** 'complete)))
- (slot-name (when accessor-class
- (if (consp meth)
- (and (early-method-standard-accessor-p meth)
- (early-method-standard-accessor-slot-name meth))
- (and (member *the-class-standard-object*
- (if early-p
- (early-class-precedence-list
- accessor-class)
- (class-precedence-list
- accessor-class))
- :test #'eq)
- (accessor-method-p meth)
- (accessor-method-slot-name meth)))))
- (slotd (and accessor-class
- (if early-p
- (dolist (slot (early-class-slotds accessor-class) nil)
- (when (eql slot-name
- (early-slot-definition-name slot))
- (return slot)))
- (find-slot-definition accessor-class slot-name)))))
+ (slot-name
+ (cond
+ ((and (consp meth)
+ (early-method-standard-accessor-p meth))
+ (early-method-standard-accessor-slot-name meth))
+ ((and (atom meth)
+ (member *the-class-standard-object*
+ (if early-p
+ (early-class-precedence-list accessor-class)
+ (class-precedence-list accessor-class))))
+ (accessor-method-slot-name meth))
+ (t (return-from accessor-values-internal (values nil nil)))))
+ (slotd (if early-p
+ (dolist (slot (early-class-slotds accessor-class) nil)
+ (when (eql slot-name (early-slot-definition-name slot))
+ (return slot)))
+ (find-slot-definition accessor-class slot-name))))
(when (and slotd
- (or early-p
- (slot-accessor-std-p slotd accessor-type))
- (or early-p
- (not (safe-p accessor-class))))
+ (or early-p (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))
;;; 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)) :test #'eq))
- (class-can-precede-p class1 class2)))
+ (not (member class1 (cdr (class-precedence-list class2)) :test #'eq)))
(defun compute-precedence (lambda-list nreq argument-precedence-order)
(if (null argument-precedence-order)
;; 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)))
+ (not (class-has-a-forward-referenced-superclass-p class))
+ (not (class-has-a-cpl-protocol-violation-p class)))
(finalize-inheritance class)
(class-precedence-list class)))
(let ((pred (memq specl (cpl-or-nil type))))
(values pred
(or pred
- (if (not *in-precompute-effective-methods-p*)
+ (if (not *in-*subtypep*)
;; classes might get common subclass
(superclasses-compatible-p specl type)
;; worry only about existing classes
nil))
\f
;;; Not synchronized, as all the uses we have for it are multiple ones
-;;; and need WITH-LOCKED-HASH-TABLE in any case.
+;;; and need WITH-LOCKED-SYSTEM-TABLE in any case.
;;;
;;; FIXME: Is it really more efficient to store this stuff in a global
;;; table instead of having a slot in each method?
(defun flush-effective-method-cache (generic-function)
(let ((cache *effective-method-cache*))
- (with-locked-hash-table (cache)
+ (with-locked-system-table (cache)
(dolist (method (generic-function-methods generic-function))
(remhash method cache)))))
(call-no-applicable-method gf args)))
(let* ((key (car methods))
(ht *effective-method-cache*)
- (ht-value (with-locked-hash-table (ht)
+ (ht-value (with-locked-system-table (ht)
(or (gethash key ht)
(setf (gethash key ht) (cons nil nil))))))
(if (and (null (cdr methods)) all-applicable-p ; the most common case
;; are part of this same code path (done while the lock is held),
;; which we AVER.
;;
- ;; FIXME: When our mutexes are smart about the need to wake up
- ;; sleepers we can put a mutex here instead -- but in the meantime
- ;; we use a spinlock to avoid a syscall for every dfun update.
- ;;
;; KLUDGE: No need to lock during bootstrap.
(if early-p
(update)
;; where we can end up in a metacircular loop here? In
;; case there are, better fetch it while interrupts are
;; still enabled...
- (sb-thread::call-with-recursive-system-spinlock #'update lock))))))
+ (sb-thread::call-with-recursive-system-lock #'update lock))))))
\f
(defvar *dfun-count* nil)
(defvar *dfun-list* nil)
projects / sbcl.git / blobdiff