;;; 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))
(setf *standard-slot-locations* new)))
(defun maybe-update-standard-slot-locations (class)
- (when (and (eq *boot-state* 'complete)
+ (when (and (eq **boot-state** 'complete)
(memq (class-name class) *standard-classes*))
(compute-standard-slot-locations)))
(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)))
(generic-function-methods gf)))
(default '(unknown)))
(and (null applyp)
- (or (not (eq *boot-state* 'complete))
+ (or (not (eq **boot-state** 'complete))
;; If COMPUTE-APPLICABLE-METHODS is specialized, we
;; can't use this, of course, because we can't tell
;; which methods will be considered applicable.
;; method has qualifiers, to make sure that emfs are really
;; method functions; see above.
(dolist (method methods t)
- (when (eq *boot-state* 'complete)
+ (when (eq **boot-state** 'complete)
(when (or (some #'eql-specializer-p
(safe-method-specializers method))
(safe-method-qualifiers method))
(return t)))))
(defun use-dispatch-dfun-p (gf &optional (caching-p (use-caching-dfun-p gf)))
- (when (eq *boot-state* 'complete)
+ (when (eq **boot-state** 'complete)
(unless (or caching-p
(gf-requires-emf-keyword-checks gf)
;; DISPATCH-DFUN-COST will error if it encounters a
(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)
(cond ((null methods)
(values
#'(lambda (&rest args)
- (apply #'no-applicable-method gf args))
+ (call-no-applicable-method gf args))
nil
(no-methods-dfun-info)))
((setq type (final-accessor-dfun-type gf))
;;; 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)
(safe-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)
- (if early-p
- (not (eq *the-class-standard-method*
- (early-method-class meth)))
- (accessor-method-p meth))
- (if early-p
- (early-accessor-method-slot-name 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)))))
+ (early-p (not (eq **boot-state** 'complete)))
+ (slot-name
+ (cond
+ ((and (consp meth)
+ (early-method-standard-accessor-p meth))
+ (early-method-standard-accessor-slot-name meth))
+ ((and (accessor-method-p 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))
(generic-function-methods gf)))
(all-index nil)
(no-class-slots-p t)
- (early-p (not (eq *boot-state* 'complete)))
+ (early-p (not (eq **boot-state** 'complete)))
first second (size 0))
(declare (fixnum size))
;; class -> {(specl slotd)}
precedence
(lambda (class1 class2 index)
(let* ((class (type-class (nth index types)))
- (cpl (if (eq *boot-state* 'complete)
+ (cpl (if (eq **boot-state** 'complete)
(class-precedence-list class)
(early-class-precedence-list class))))
(if (memq class2 (memq class1 cpl))
(stable-sort methods #'sorter)))
(defun order-specializers (specl1 specl2 index compare-classes-function)
- (let ((type1 (if (eq *boot-state* 'complete)
+ (let ((type1 (if (eq **boot-state** 'complete)
(specializer-type specl1)
(!bootstrap-get-slot 'specializer specl1 '%type)))
- (type2 (if (eq *boot-state* 'complete)
+ (type2 (if (eq **boot-state** 'complete)
(specializer-type specl2)
(!bootstrap-get-slot 'specializer specl2 '%type))))
(cond ((eq specl1 specl2)
;;; 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)
argument-precedence-order)))
(defun cpl-or-nil (class)
- (if (eq *boot-state* 'complete)
+ (if (eq **boot-state** 'complete)
(progn
;; KLUDGE: why not use (slot-boundp class
;; 'class-precedence-list)? Well, unfortunately, CPL-OR-NIL is
;; 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
(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))))
+ (braid-p (or (eq **boot-state** 'braid)
+ (eq **boot-state** 'complete))))
(labels ((do-class (class)
(unless (gethash class all-classes)
(setf (gethash class all-classes) t)
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)))))
(all-sorted-p t)
function-p)
(if (null methods)
- (if function-p
- (lambda (method-alist wrappers)
- (declare (ignore method-alist wrappers))
- #'(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))))
+ (lambda (method-alist wrappers)
+ (declare (ignore method-alist wrappers))
+ (lambda (&rest args)
+ (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
wrappers-p all-applicable-p
all-sorted-p function-p)
(if (and all-applicable-p all-sorted-p (not function-p))
- (if (eq *boot-state* 'complete)
+ (if (eq **boot-state** 'complete)
(let* ((combin (generic-function-method-combination gf))
(effective (compute-effective-method gf combin methods)))
(make-effective-method-function1 gf effective method-alist-p
(get-secondary-dispatch-function1 gf methods nil nil nil t sorted-p))
(defun methods-contain-eql-specializer-p (methods)
- (and (eq *boot-state* 'complete)
+ (and (eq **boot-state** 'complete)
(dolist (method methods nil)
(when (dolist (spec (method-specializers method) nil)
(when (eql-specializer-p spec) (return t)))
;; 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)