X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=5532c12f1f9d653285195be9e00c4591e5062bfd;hb=a572ab7de4266dec958d50612a8376df6bb45226;hp=8f0ca1a9141ce8397a684bb0942ba757a26b3918;hpb=776a2f1275624352bbba37b03dabea03ec13a9e5;p=sbcl.git diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 8f0ca1a..5532c12 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -260,8 +260,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)) @@ -1280,8 +1280,8 @@ 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)))) + (when (class-finalized-p specl) + (class-precedence-list specl)))) (so-p (member *the-class-standard-object* specl-cpl)) (slot-name (if (consp method) (and (early-method-standard-accessor-p method) @@ -1296,17 +1296,14 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ;; 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 +1413,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)))))))) @@ -1635,12 +1640,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 +1670,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 +1681,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 +1759,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 +1774,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 +1789,6 @@ 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 +1851,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)))