X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fpcl%2Fstd-class.lisp;h=fcb86c1e919086ed48e715185e30f777c01bd784;hb=157e21959c8023f146d6b03206aea6daa60e7b0d;hp=8721509ae53a30d4d32824c899fa1a949e1d0cb2;hpb=562e48a2bd3467121e24214110e535c841fbb622;p=sbcl.git

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 8721509..fcb86c1 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -173,15 +173,40 @@
 ;;; In each case, we maintain one value which is a cons. The car is the list
 ;;; methods. The cdr is a list of the generic functions. The cdr is always
 ;;; computed lazily.
+
+;;; This needs to be used recursively, in case a non-trivial user
+;;; defined ADD/REMOVE-DIRECT-METHOD method ends up calling another
+;;; function using the same lock.
+(defvar *specializer-lock* (sb-thread::make-spinlock :name "Specializer lock"))
+
+(defmethod add-direct-method :around ((specializer specializer) method)
+  ;; All the actions done under this lock are done in an order
+  ;; that is safe to unwind at any point.
+  (sb-thread::with-recursive-spinlock (*specializer-lock*)
+    (call-next-method)))
+
+(defmethod remove-direct-method :around ((specializer specializer) method)
+  ;; All the actions done under this lock are done in an order
+  ;; that is safe to unwind at any point.
+  (sb-thread::with-recursive-spinlock (*specializer-lock*)
+    (call-next-method)))
+
 (defmethod add-direct-method ((specializer class) (method method))
-  (with-slots (direct-methods) specializer
-    (setf (car direct-methods) (adjoin method (car direct-methods))     ;PUSH
-          (cdr direct-methods) ()))
+  (let ((cell (slot-value specializer 'direct-methods)))
+    ;; We need to first smash the CDR, because a parallel read may
+    ;; be in progress, and because if an interrupt catches us we
+    ;; need to have a consistent state.
+    (setf (cdr cell) ()
+          (car cell) (adjoin method (car cell))))
   method)
+
 (defmethod remove-direct-method ((specializer class) (method method))
-  (with-slots (direct-methods) specializer
-    (setf (car direct-methods) (remove method (car direct-methods))
-          (cdr direct-methods) ()))
+  (let ((cell (slot-value specializer 'direct-methods)))
+    ;; We need to first smash the CDR, because a parallel read may
+    ;; be in progress, and because if an interrupt catches us we
+    ;; need to have a consistent state.
+    (setf (cdr cell) ()
+          (car cell) (remove method (car cell))))
   method)
 
 (defmethod specializer-direct-methods ((specializer class))
@@ -189,15 +214,19 @@
     (car direct-methods)))
 
 (defmethod specializer-direct-generic-functions ((specializer class))
-  (with-slots (direct-methods) specializer
-    (or (cdr direct-methods)
-        (setf (cdr direct-methods)
-              (let (collect)
-                (dolist (m (car direct-methods))
-                  ;; the old PCL code used COLLECTING-ONCE which used
-                  ;; #'EQ to check for newness
-                  (pushnew (method-generic-function m) collect :test #'eq))
-                (nreverse collect))))))
+  (let ((cell (slot-value specializer 'direct-methods)))
+    ;; If an ADD/REMOVE-METHOD is in progress, no matter: either
+    ;; we behave as if we got just first or just after -- it's just
+    ;; for update that we need to lock.
+    (or (cdr cell)
+        (sb-thread::with-spinlock (*specializer-lock*)
+          (setf (cdr cell)
+                (let (collect)
+                  (dolist (m (car cell))
+                    ;; the old PCL code used COLLECTING-ONCE which used
+                    ;; #'EQ to check for newness
+                    (pushnew (method-generic-function m) collect :test #'eq))
+                  (nreverse collect)))))))
 
 ;;; This hash table is used to store the direct methods and direct generic
 ;;; functions of EQL specializers. Each value in the table is the cons.
@@ -215,12 +244,17 @@
   (let* ((object (specializer-object specializer))
          (table (specializer-method-table specializer))
          (entry (gethash object table)))
+    ;; This table is shared between multiple specializers, but
+    ;; no worries as (at least for the time being) our hash-tables
+    ;; are thread safe.
     (unless entry
-      (setq entry
-            (setf (gethash object table)
-                  (cons nil nil))))
-    (setf (car entry) (adjoin method (car entry))
-          (cdr entry) ())
+      (setf entry
+            (setf (gethash object table) (cons nil nil))))
+    ;; We need to first smash the CDR, because a parallel read may
+    ;; be in progress, and because if an interrupt catches us we
+    ;; need to have a consistent state.
+    (setf (cdr entry) ()
+          (car entry) (adjoin method (car entry)))
     method))
 
 (defmethod remove-direct-method ((specializer specializer-with-object)
@@ -228,8 +262,11 @@
   (let* ((object (specializer-object specializer))
          (entry (gethash object (specializer-method-table specializer))))
     (when entry
-      (setf (car entry) (remove method (car entry))
-            (cdr entry) ()))
+      ;; We need to first smash the CDR, because a parallel read may
+      ;; be in progress, and because if an interrupt catches us we
+      ;; need to have a consistent state.
+      (setf (cdr entry) ()
+            (car entry) (remove method (car entry))))
     method))
 
 (defmethod specializer-direct-methods ((specializer specializer-with-object))
@@ -242,11 +279,12 @@
          (entry (gethash object (specializer-method-table specializer))))
     (when entry
       (or (cdr entry)
-          (setf (cdr entry)
-                (let (collect)
-                  (dolist (m (car entry))
-                    (pushnew (method-generic-function m) collect :test #'eq))
-                  (nreverse collect)))))))
+          (sb-thread::with-spinlock (*specializer-lock*)
+            (setf (cdr entry)
+                  (let (collect)
+                    (dolist (m (car entry))
+                      (pushnew (method-generic-function m) collect :test #'eq))
+                    (nreverse collect))))))))
 
 (defun map-specializers (function)
   (map-all-classes (lambda (class)
@@ -496,7 +534,9 @@
       (setq %class-precedence-list (compute-class-precedence-list class))
       (setq cpl-available-p t)
       (add-direct-subclasses class direct-superclasses)
-      (setf (slot-value class 'slots) (compute-slots class))))
+      (let ((slots (compute-slots class)))
+        (setf (slot-value class 'slots) slots
+              (slot-value class 'slot-vector) (make-slot-vector class slots)))))
   ;; Comment from Gerd's PCL, 2003-05-15:
   ;;
   ;; We don't ADD-SLOT-ACCESSORS here because we don't want to
@@ -676,7 +716,9 @@
     (setf (slot-value class '%class-precedence-list)
           (compute-class-precedence-list class))
     (setf (slot-value class 'cpl-available-p) t)
-    (setf (slot-value class 'slots) (compute-slots class))
+    (let ((slots (compute-slots class)))
+      (setf (slot-value class 'slots) slots
+            (slot-value class 'slot-vector) (make-slot-vector class slots)))
     (let ((lclass (find-classoid (class-name class))))
       (setf (classoid-pcl-class lclass) class)
       (setf (slot-value class 'wrapper) (classoid-layout lclass)))
@@ -851,31 +893,31 @@
                    (make-instances-obsolete class)
                    (class-wrapper class)))))
 
-      (with-slots (wrapper slots) class
-        (update-lisp-class-layout class nwrapper)
-        (setf slots eslotds
-              (wrapper-instance-slots-layout nwrapper) nlayout
-              (wrapper-class-slots nwrapper) nwrapper-class-slots
-              (layout-length nwrapper) nslots
-              wrapper nwrapper)
-        (do* ((slots (slot-value class 'slots) (cdr slots))
-              (dupes nil))
-             ((null slots)
-              (when dupes
-                (style-warn
-                 "~@<slot names with the same SYMBOL-NAME but ~
+      (update-lisp-class-layout class nwrapper)
+      (setf (slot-value class 'slots) eslotds
+            (slot-value class 'slot-vector) (make-slot-vector class eslotds)
+            (wrapper-instance-slots-layout nwrapper) nlayout
+            (wrapper-class-slots nwrapper) nwrapper-class-slots
+            (layout-length nwrapper) nslots
+            (slot-value class 'wrapper) nwrapper)
+      (do* ((slots (slot-value class 'slots) (cdr slots))
+            (dupes nil))
+           ((null slots)
+            (when dupes
+              (style-warn
+               "~@<slot names with the same SYMBOL-NAME but ~
                   different SYMBOL-PACKAGE (possible package problem) ~
                   for class ~S:~4I~@:_~<~@{~S~^~:@_~}~:>~@:>"
-                  class dupes)))
-          (let* ((slot (car slots))
-                 (oslots (remove (slot-definition-name slot) (cdr slots)
-                                 :test #'string/=
-                                 :key #'slot-definition-name)))
-            (when oslots
-              (pushnew (cons (slot-definition-name slot)
-                             (mapcar #'slot-definition-name oslots))
-                       dupes
-                       :test #'string= :key #'car)))))
+               class dupes)))
+        (let* ((slot (car slots))
+               (oslots (remove (slot-definition-name slot) (cdr slots)
+                               :test #'string/=
+                               :key #'slot-definition-name)))
+          (when oslots
+            (pushnew (cons (slot-definition-name slot)
+                           (mapcar #'slot-definition-name oslots))
+                     dupes
+                     :test #'string= :key #'car))))
       (setf (slot-value class 'finalized-p) t)
       (unless (eq owrapper nwrapper)
         (update-pv-table-cache-info class)
@@ -1319,7 +1361,7 @@
              (type-of (obsolete-structure-datum condition))))))
 
 (defun obsolete-instance-trap (owrapper nwrapper instance)
-  (if (not (pcl-instance-p instance))
+  (if (not (layout-for-std-class-p owrapper))
       (if *in-obsolete-instance-trap*
           *the-wrapper-of-structure-object*
            (let ((*in-obsolete-instance-trap* t))
@@ -1515,6 +1557,11 @@
   (def class-direct-default-initargs)
   (def class-default-initargs))
 
+(defmethod class-slot-vector (class)
+  ;; Default method to cause FIND-SLOT-DEFINITION return NIL for all
+  ;; non SLOT-CLASS classes.
+  #(nil))
+
 (defmethod validate-superclass ((c class) (s built-in-class))
   (or (eq s *the-class-t*) (eq s *the-class-stream*)
       ;; FIXME: bad things happen if someone tries to mix in both