X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=5532c12f1f9d653285195be9e00c4591e5062bfd;hb=a572ab7de4266dec958d50612a8376df6bb45226;hp=6fc21e624a2736192ad5f56232de6a1fd578b100;hpb=daca1dbe7a2060dcdcae209b2e3bcf5f223bca8a;p=sbcl.git

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 6fc21e6..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)
@@ -1643,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)
@@ -1664,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))
@@ -1675,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)
@@ -1772,9 +1779,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
             ;; where we can end up in a metacircular loop here? In
             ;; case there are, better fetch it while interrupts are
             ;; still enabled...
-            (sb-sys:without-interrupts
-              (sb-thread::with-recursive-spinlock (lock)
-                (update))))))))
+            (sb-thread::call-with-recursive-system-spinlock #'update lock))))))
 
 (defvar *dfun-count* nil)
 (defvar *dfun-list* nil)
@@ -1784,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*)))
@@ -1847,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)))