X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=37002f97e223139d2eb92c7bd5c31413860fcf14;hb=44c9d978d04fd58ba8cae546ab45618c9a3d0050;hp=8f0ca1a9141ce8397a684bb0942ba757a26b3918;hpb=776a2f1275624352bbba37b03dabea03ec13a9e5;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 8f0ca1a..37002f9 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -187,17 +187,15 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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))) @@ -260,8 +258,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; 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)) @@ -1195,8 +1193,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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)))) @@ -1235,14 +1233,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (early-class-precedence-list accessor-class) (class-precedence-list - accessor-class))) - (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)))))) + 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) @@ -1280,9 +1274,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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 @@ -1290,23 +1284,20 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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) @@ -1416,9 +1407,17 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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)))))))) @@ -1466,7 +1465,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; 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) @@ -1635,12 +1634,21 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 root))) nil)) -;;; 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) @@ -1656,7 +1664,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 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)) @@ -1667,9 +1675,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (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) @@ -1744,13 +1753,13 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; 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. + ;; 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. ;; - ;; KLUDGE: We need to disable interrupts as long as - ;; WITH-FOO-LOCK is interrupt unsafe. Once they are interrupt - ;; safe we can allow interrupts here. (But if someone some day - ;; manages to get rid of the need for a recursive lock here we - ;; _will_ need without-interrupts once again.) + ;; 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 @@ -1759,9 +1768,12 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; KLUDGE: No need to lock during bootstrap. (if early-p (update) - (sb-sys:without-interrupts - (sb-thread::with-recursive-spinlock ((gf-lock generic-function)) - (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)))))) (defvar *dfun-count* nil) (defvar *dfun-list* nil) @@ -1771,7 +1783,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;;; 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*))) @@ -1834,7 +1846,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (format t "~% ~S~%" (caddr type+count+sizes))) *dfun-count*) (values)) -|# +||# (defun gfs-of-type (type) (unless (consp type) (setq type (list type)))