1.0.6.3: thread and interrupt safe CLOS cache

[sbcl.git] / src / pcl / vector.lisp

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index cc5ef22..5870bfe 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -33,9 +33,6 @@
          (when (eq ,slot-name sn) (return-from loop pos))
          (incf pos)))))
 \f
-(defun pv-cache-limit-fn (nlines)
-  (default-limit-fn nlines))
-
 (defstruct (pv-table (:predicate pv-tablep)
                      (:constructor make-pv-table-internal
                                    (slot-name-lists call-list))
@@ -208,19 +205,22 @@
          (call-list (pv-table-call-list pv-table))
          (cache (or (pv-table-cache pv-table)
                     (setf (pv-table-cache pv-table)
-                          (get-cache (- (length slot-name-lists)
-                                        (count nil slot-name-lists))
-                                     t
-                                     #'pv-cache-limit-fn
-                                     2)))))
-    (or (probe-cache cache pv-wrappers)
-        (let* ((pv (compute-pv slot-name-lists pv-wrappers))
-               (calls (compute-calls call-list pv-wrappers))
-               (pv-cell (cons pv calls))
-               (new-cache (fill-cache cache pv-wrappers pv-cell)))
-          (unless (eq new-cache cache)
-            (setf (pv-table-cache pv-table) new-cache))
-          pv-cell))))
+                          (make-cache :key-count (- (length slot-name-lists)
+                                                    (count nil slot-name-lists))
+                                      :value t
+                                      :size 2)))))
+    (multiple-value-bind (hitp value) (probe-cache cache pv-wrappers)
+      (if hitp
+          value
+          (let* ((pv (compute-pv slot-name-lists pv-wrappers))
+                 (calls (compute-calls call-list pv-wrappers))
+                 (pv-cell (cons pv calls))
+                 (new-cache (fill-cache cache pv-wrappers pv-cell)))
+            ;; This is safe: if another thread races us here the loser just
+            ;; misses the next time as well.
+            (unless (eq new-cache cache)
+              (setf (pv-table-cache pv-table) new-cache))
+            pv-cell)))))
 
 (defun make-pv-type-declaration (var)
   `(type simple-vector ,var))