X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=3be7f774be1cc42f6edf9ee579dac791de2f9b14;hb=c548f73e8dd676d6ec4576eba6ab661a5061bdfe;hp=3b02ee4586c00d672f6b9849ddbbd4f6b844dc24;hpb=62f25b3b18b66ae67d555ca8a05026dbf03d89e1;p=sbcl.git

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 3b02ee4..3be7f77 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))
@@ -1416,9 +1416,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))))))))
 
@@ -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))
@@ -1721,22 +1729,50 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
            (return t)))))
 
 (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))))))
 
 (defvar *dfun-count* nil)
 (defvar *dfun-list* nil)
@@ -1746,7 +1782,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*)))
@@ -1809,7 +1844,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)))