(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)
+ (let ((new (make-hash-table :test 'equal)))
+ (dolist (class-name *standard-classes*)
+ (let ((class (find-class class-name)))
+ (dolist (slot (class-slots class))
+ (setf (gethash (cons class (slot-definition-name slot)) new)
+ (slot-definition-location slot)))))
+ (setf *standard-slot-locations* new)))
+
+(defun maybe-update-standard-slot-locations (class)
(when (and (eq *boot-state* 'complete)
(memq (class-name class) *standard-classes*))
(compute-standard-slot-locations)))
;;; This is the most general case. In this case, the accessor
;;; generic function has seen more than one class of argument and
;;; more than one slot index. A cache vector stores the wrappers
-;;; and corresponding slot indexes. Because each cache line is
-;;; more than one element long, a cache lock count is used.
+;;; and corresponding slot indexes.
+
(defstruct (dfun-info (:constructor nil)
(:copier nil))
(cache nil))
(let ((subcpl (member (ecase type
(reader (car specializers))
(writer (cadr specializers)))
- cpl)))
- (and subcpl (member found-specializer subcpl))))
+ cpl :test #'eq)))
+ (and subcpl (member found-specializer subcpl :test #'eq))))
(setf found-specializer (ecase type
(reader (car specializers))
(writer (cadr specializers))))
(early-class-precedence-list
accessor-class)
(class-precedence-list
- accessor-class)))
+ accessor-class))
+ :test #'eq)
(if early-p
(not (eq *the-class-standard-method*
(early-method-class meth)))
(writer (cadr specializers))))
(specl-cpl (if early-p
(early-class-precedence-list specl)
- (and (class-finalized-p specl)
- (class-precedence-list specl))))
- (so-p (member *the-class-standard-object* specl-cpl))
+ (when (class-finalized-p specl)
+ (class-precedence-list specl))))
+ (so-p (member *the-class-standard-object* specl-cpl :test #'eq))
(slot-name (if (consp method)
(and (early-method-standard-accessor-p method)
(early-method-standard-accessor-slot-name
(accessor-method-slot-name method))))
(when (or (null specl-cpl)
(null so-p)
- (member *the-class-structure-object* specl-cpl))
+ (member *the-class-structure-object* specl-cpl :test #'eq))
(return-from make-accessor-table nil))
;; 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))))
+ (let ((slotd (find-slot-definition class slot-name)))
(when slotd
- (unless (or early-p
- (slot-accessor-std-p slotd type))
+ (unless (or early-p (slot-accessor-std-p slotd type))
(return-from make-accessor-table nil))
(push (cons specl slotd) (gethash class table))))
(dolist (subclass (sb-pcl::class-direct-subclasses class))
+ (unless (class-finalized-p subclass)
+ (return-from make-accessor-table nil))
(aux subclass))))
(aux specl))))
(maphash (lambda (class specl+slotd-list)
(t specl2)))
(class-eq (case (car type2)
(eql specl2)
+ ;; FIXME: This says that all CLASS-EQ
+ ;; specializers are equally specific, which
+ ;; is fair enough because only one CLASS-EQ
+ ;; specializer can ever be appliable. If
+ ;; ORDER-SPECIALIZERS should only ever be
+ ;; called on specializers from applicable
+ ;; methods, we could replace this with a BUG.
(class-eq nil)
(class type1)))
(eql (case (car type2)
+ ;; similarly.
(eql nil)
(t specl1))))))))
;;; 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))))
+ (not (member class1 (cdr (class-precedence-list class2)) :test #'eq))
(class-can-precede-p class1 class2)))
(defun compute-precedence (lambda-list nreq argument-precedence-order)
root)))
nil))
\f
-;;; FIXME: Needs a lock.
+;;; Not synchronized, as all the uses we have for it are multiple ones
+;;; and need WITH-LOCKED-HASH-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?
+;;;
+;;; FIXME: This table also seems to contain early methods, which should
+;;; presumably be dropped during the bootstrap.
(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*)))
+ (let ((cache *effective-method-cache*))
+ (with-locked-hash-table (cache)
+ (dolist (method (generic-function-methods generic-function))
+ (remhash method cache)))))
(defun get-secondary-dispatch-function (gf methods types
&optional method-alist wrappers)
all-applicable-p
(all-sorted-p t)
function-p)
- (if (null methods)
+ (if (null methods)
(if function-p
(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-cache*)
- (setf (gethash key *effective-method-cache*)
- (cons nil nil)))))
+ (ht *effective-method-cache*)
+ (ht-value (with-locked-hash-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
(null method-alist-p) wrappers-p (not function-p))
(or (car ht-value)
(return t)))))
\f
(defun update-dfun (generic-function &optional dfun cache info)
- ;; Save DFUN-STATE, so that COMPUTE-DISCRIMINATING-FUNCTION can
- ;; access it, and so that it's there for eg. future cache updates.
- ;;
- ;; How atomic wrt. SET-FUNCALLABLE-INSTANCE-FUN does this need to
- ;; be?
- (set-dfun generic-function dfun cache info)
- (let* ((early-p (early-gf-p generic-function))
- (dfun (if early-p
- (or dfun (make-initial-dfun generic-function))
- (compute-discriminating-function generic-function))))
- (set-funcallable-instance-function generic-function dfun)
- (let ((gf-name (if early-p
- (!early-gf-name generic-function)
- (generic-function-name generic-function))))
- (set-fun-name generic-function gf-name)
- dfun)))
+ (let ((early-p (early-gf-p generic-function)))
+ (flet ((update ()
+ ;; Save DFUN-STATE, so that COMPUTE-DISCRIMINATING-FUNCTION can
+ ;; access it, and so that it's there for eg. future cache updates.
+ (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-function generic-function dfun)
+ (let ((gf-name (if early-p
+ (!early-gf-name generic-function)
+ (generic-function-name generic-function))))
+ (set-fun-name generic-function gf-name)
+ dfun))))
+ ;; This needs to be atomic per generic function, consider:
+ ;; 1. T1 sets dfun-state to S1 and computes discr. fun using S1
+ ;; 2. T2 sets dfun-state to S2 and computes discr. fun using S2
+ ;; 3. T2 sets fin
+ ;; 4. T1 sets fin
+ ;; Oops: now dfun-state and fin don't match! Since just calling
+ ;; a generic can cause the dispatch function to be updated we
+ ;; need a lock here.
+ ;;
+ ;; We need to accept recursion, because PCL is nasty and twisty,
+ ;; and we need to disable interrupts because it would be bad if
+ ;; we updated the DFUN-STATE but not the dispatch function.
+ ;;
+ ;; This is sufficient, because all the other calls to SET-DFUN
+ ;; 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)
+ (let ((lock (gf-lock generic-function)))
+ ;; FIXME: GF-LOCK is a generic function... Are there cases
+ ;; 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))))))
\f
(defvar *dfun-count* nil)
(defvar *dfun-list* nil)
;;; I'm aware of, but they look like they might be useful for
;;; debugging or performance tweaking or something, so I've just
;;; commented them out instead of deleting them. -- WHN 2001-03-28
-#|
+#||
(defun list-dfun (gf)
(let* ((sym (type-of (gf-dfun-info gf)))
(a (assq sym *dfun-list*)))
(format t "~% ~S~%" (caddr type+count+sizes)))
*dfun-count*)
(values))
-|#
+||#
(defun gfs-of-type (type)
(unless (consp type) (setq type (list type)))
projects / sbcl.git / blobdiff