X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=0ff03d99a3e59fd5116962b402fb96226f48ff6f;hb=6bbc22725d3bf663726ed9adca544e39316364a6;hp=c559b6199347b0ab7fe31e2fbbeeacdf8bc7aa83;hpb=c548f73e8dd676d6ec4576eba6ab661a5061bdfe;p=sbcl.git

diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp
index c559b61..0ff03d9 100644
--- a/src/pcl/cache.lisp
+++ b/src/pcl/cache.lisp
@@ -81,7 +81,8 @@
   ;;   (mod index (length vector))
   ;; using a bitmask.
   (vector #() :type simple-vector)
-  ;; The bitmask used to calculate (mod (* line-size line-hash) (length vector))).
+  ;; The bitmask used to calculate
+  ;;   (mod (* line-size line-hash) (length vector))).
   (mask 0 :type fixnum)
   ;; Current probe-depth needed in the cache.
   (depth 0 :type index)
@@ -148,22 +149,6 @@
 (defun cache-key-p (thing)
   (not (symbolp thing)))
 
-(eval-when (:compile-toplevel :load-toplevel :execute)
-  (sb-kernel:define-structure-slot-compare-and-swap compare-and-swap-cache-depth
-      :structure cache
-      :slot depth))
-
-;;; Utility macro for atomic updates without locking... doesn't
-;;; do much right now, and it would be nice to make this more magical.
-(defmacro compare-and-swap (place old new)
-  (unless (consp place)
-    (error "Don't know how to compare and swap ~S." place))
-  (ecase (car place)
-    (svref
-     `(simple-vector-compare-and-swap ,@(cdr place) ,old ,new))
-    (cache-depth
-     `(compare-and-swap-cache-depth ,@(cdr place) ,old ,new))))
-
 ;;; Atomically update the current probe depth of a cache.
 (defun note-cache-depth (cache depth)
   (loop for old = (cache-depth cache)
@@ -174,6 +159,7 @@
 ;;; Compute the starting index of the next cache line in the cache vector.
 (declaim (inline next-cache-index))
 (defun next-cache-index (mask index line-size)
+  (declare (type (unsigned-byte #.sb-vm:n-word-bits) index line-size mask))
   (logand mask (+ index line-size)))
 
 ;;; Returns the hash-value for layout, or executes ELSE if the layout
@@ -246,6 +232,7 @@
 ;;; Returns two values: a boolean indicating a hit or a miss, and a secondary
 ;;; value that is the value that was stored in the cache if any.
 (defun probe-cache (cache layouts)
+  (declare (optimize speed))
   (unless (consp layouts)
     (setf layouts (list layouts)))
   (let ((vector (cache-vector cache))
@@ -253,8 +240,9 @@
         (line-size (cache-line-size cache))
         (mask (cache-mask cache)))
     (flet ((probe-line (base)
+             (declare (optimize (sb-c::type-check 0)))
              (tagbody
-                (loop for offset from 0 below key-count
+                (loop for offset of-type index from 0 below key-count
                       for layout in layouts do
                       (unless (eq layout (svref vector (+ base offset)))
                         ;; missed
@@ -266,10 +254,11 @@
                   (return-from probe-cache (values t value)))
               :miss
                 (return-from probe-line (next-cache-index mask base line-size)))))
+      (declare (ftype (function (index) (values index &optional)) probe-line))
       (let ((index (compute-cache-index cache layouts)))
         (when index
-          (loop repeat (1+ (cache-depth cache)) do
-                (setf index (probe-line index)))))))
+          (loop repeat (1+ (cache-depth cache))
+                do (setf index (probe-line index)))))))
   (values nil nil))
 
 ;;; Tries to write LAYOUTS and VALUE at the cache line starting at
@@ -303,8 +292,7 @@
 ;;; true on success and false on failure, meaning the cache is too
 ;;; full.
 (defun try-update-cache (cache layouts value)
-  (let ((vector (cache-vector cache))
-        (index (or (compute-cache-index cache layouts)
+  (let ((index (or (compute-cache-index cache layouts)
                    ;; At least one of the layouts was invalid: just
                    ;; pretend we updated the cache, and let the next
                    ;; read pick up the mess.
@@ -336,9 +324,10 @@
 
 ;;;; Copies and expands the cache, dropping any invalidated or
 ;;;; incomplete lines.
-(defun copy-and-expand-cache (cache)
+(defun copy-and-expand-cache (cache layouts value)
   (let ((copy (%copy-cache cache))
         (length (length (cache-vector cache))))
+    (declare (index length))
     (when (< length +cache-vector-max-length+)
       (setf length (* 2 length)))
     (tagbody
@@ -350,6 +339,11 @@
              (cache-depth copy) 0
              (cache-mask copy) (compute-cache-mask length (cache-line-size cache))
              (cache-limit copy) (compute-limit (/ length (cache-line-size cache))))
+       ;; First insert the new one -- if we don't do this first and
+       ;; the cache has reached it's maximum size we may end up
+       ;; looping in FILL-CACHE.
+       (unless (try-update-cache copy layouts value)
+         (bug "Could not insert ~S:~S to supposedly empty ~S." layouts value cache))
        (map-cache (lambda (layouts value)
                     (unless (try-update-cache copy layouts value)
                       ;; If the cache would grow too much we drop the
@@ -412,7 +406,7 @@
                 ;; we just drop the invalid entries.
                 (%fill-cache (copy-cache cache) layouts value))
                (t
-                (%fill-cache (copy-and-expand-cache cache) layouts value)))))
+                (copy-and-expand-cache cache layouts value)))))
     (if (listp layouts)
         (%fill-cache cache layouts value)
         (%fill-cache cache (list layouts) value))))
@@ -427,8 +421,7 @@
          (fun (if (functionp function)
                   function
                   (fdefinition function)))
-         (index 0)
-         (key nil))
+         (index 0))
     (tagbody
      :map
        (let ((layouts
@@ -459,7 +452,6 @@
          (mask (cache-mask cache))
          (size (/ (length vector) line-size))
          (index 0)
-         (elt nil)
          (depth 0))
     (tagbody
      :copy