-;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of
-;;; non-zero bits wrapper cache numbers will have.
-;;;
-;;; The value of this constant is the number of wrapper cache numbers
-;;; which can be added and still be certain the result will be a
-;;; fixnum. This is used by all the code that computes primary cache
-;;; locations from multiple wrappers.
-;;;
-;;; The value of this constant is used to derive the next two which
-;;; are the forms of this constant which it is more convenient for the
-;;; runtime code to use.
-(defconstant wrapper-cache-number-length
- (integer-length (1- layout-clos-hash-limit)))
-(defconstant wrapper-cache-number-mask (1- layout-clos-hash-limit))
-(defconstant wrapper-cache-number-adds-ok
- (truncate most-positive-fixnum (1- layout-clos-hash-limit)))
-\f
-;;;; wrappers themselves
-
-;;; FIXME: delete this comment, possibly replacing it with a reference
-;;; to Kiczales and Rodruigez
-;;;
-;;; This caching algorithm requires that wrappers have more than one
-;;; wrapper cache number. You should think of these multiple numbers
-;;; as being in columns. That is, for a given cache, the same column
-;;; of wrapper cache numbers will be used.
-;;;
-;;; If at some point the cache distribution of a cache gets bad, the
-;;; cache can be rehashed by switching to a different column.
-;;;
-;;; The columns are referred to by field number which is that number
-;;; which, when used as a second argument to wrapper-ref, will return
-;;; that column of wrapper cache number.
-;;;
-;;; This code is written to allow flexibility as to how many wrapper
-;;; cache numbers will be in each wrapper, and where they will be
-;;; located. It is also set up to allow port specific modifications to
-;;; `pack' the wrapper cache numbers on machines where the addressing
-;;; modes make that a good idea.
-
-(unless (boundp '*the-class-t*)
- (setq *the-class-t* nil))
-
-(defun get-cache (nkeys valuep limit-fn nlines)
- (let ((cache (make-cache)))
- (declare (type cache cache))
- (multiple-value-bind (cache-mask actual-size line-size nlines)
- (compute-cache-parameters nkeys valuep nlines)
- (setf (cache-nkeys cache) nkeys
- (cache-valuep cache) valuep
- (cache-nlines cache) nlines
- (cache-limit-fn cache) limit-fn
- (cache-mask cache) cache-mask
- (cache-size cache) actual-size
- (cache-line-size cache) line-size
- (cache-max-location cache) (let ((line (1- nlines)))
- (if (= nkeys 1)
- (* line line-size)
- (1+ (* line line-size))))
- (cache-vector cache) (get-cache-vector actual-size)
- (cache-overflow cache) nil)
- cache)))
-
-(defun get-cache-from-cache (old-cache new-nlines)
- (let ((nkeys (cache-nkeys old-cache))
- (valuep (cache-valuep old-cache))
- (cache (make-cache)))
- (declare (type cache cache))
- (multiple-value-bind (cache-mask actual-size line-size nlines)
- (if (= new-nlines (cache-nlines old-cache))
- (values (cache-mask old-cache) (cache-size old-cache)
- (cache-line-size old-cache) (cache-nlines old-cache))
- (compute-cache-parameters nkeys valuep new-nlines))
- (setf (cache-owner cache) (cache-owner old-cache)
- (cache-nkeys cache) nkeys
- (cache-valuep cache) valuep
- (cache-nlines cache) nlines
- (cache-limit-fn cache) (cache-limit-fn old-cache)
- (cache-mask cache) cache-mask
- (cache-size cache) actual-size
- (cache-line-size cache) line-size
- (cache-max-location cache) (let ((line (1- nlines)))
- (if (= nkeys 1)
- (* line line-size)
- (1+ (* line line-size))))
- (cache-vector cache) (get-cache-vector actual-size)
- (cache-overflow cache) nil)
- cache)))
-
-(defun copy-cache (old-cache)
- (let* ((new-cache (copy-cache-internal old-cache))
- (size (cache-size old-cache))
- (old-vector (cache-vector old-cache))
- (new-vector (get-cache-vector size)))
- (declare (simple-vector old-vector new-vector))
- (dotimes-fixnum (i size)
- (setf (svref new-vector i) (svref old-vector i)))
- (setf (cache-vector new-cache) new-vector)
- new-cache))
-
-(defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector)
- ;;(declare (values cache-mask actual-size line-size nlines))
- (declare (fixnum nkeys))
- (if (= nkeys 1)
- (let* ((line-size (if valuep 2 1))
- (cache-size (etypecase nlines-or-cache-vector
- (fixnum
- (* line-size
- (power-of-two-ceiling nlines-or-cache-vector)))
- (vector
- (cache-vector-size nlines-or-cache-vector)))))
- (declare (type (and unsigned-byte fixnum) line-size cache-size))
- (values (logxor (1- cache-size) (1- line-size))
- cache-size
- line-size
- (floor cache-size line-size)))
- (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys)))
- (cache-size (etypecase nlines-or-cache-vector
- (fixnum
- (* line-size
- (power-of-two-ceiling nlines-or-cache-vector)))
- (vector
- (1- (cache-vector-size nlines-or-cache-vector))))))
- (declare (fixnum line-size cache-size))
- (values (logxor (1- cache-size) (1- line-size))
- (1+ cache-size)
- line-size
- (floor cache-size line-size)))))
-\f
-;;; the various implementations of computing a primary cache location from
-;;; wrappers. Because some implementations of this must run fast there are
-;;; several implementations of the same algorithm.
-;;;
-;;; The algorithm is:
-;;;
-;;; SUM over the wrapper cache numbers,
-;;; ENSURING that the result is a fixnum
-;;; MASK the result against the mask argument.
-
-;;; The basic functional version. This is used by the cache miss code to
-;;; compute the primary location of an entry.
-(defun compute-primary-cache-location (mask wrappers)
- (declare (fixnum mask))
- (if (not (listp wrappers))
- (logand mask (layout-clos-hash wrappers))
- (let ((location 0)
- (i 0))
- (declare (fixnum location i))
- (dolist (wrapper wrappers)
- ;; First add the cache number of this wrapper to location.
- (let ((wrapper-cache-number (layout-clos-hash wrapper)))
- (if (zerop wrapper-cache-number)
- (return-from compute-primary-cache-location 0)
- (incf location wrapper-cache-number)))
- ;; Then, if we are working with lots of wrappers, deal with
- ;; the wrapper-cache-number-mask stuff.
- (when (and (not (zerop i))
- (zerop (mod i wrapper-cache-number-adds-ok)))
- (setq location
- (logand location wrapper-cache-number-mask)))
- (incf i))
- (1+ (logand mask location)))))
-
-;;; This version is called on a cache line. It fetches the wrappers
-;;; from the cache line and determines the primary location. Various
-;;; parts of the cache filling code call this to determine whether it
-;;; is appropriate to displace a given cache entry.
-;;;
-;;; If this comes across a wrapper whose CACHE-NO is 0, it returns the
-;;; symbol invalid to suggest to its caller that it would be provident
-;;; to blow away the cache line in question.
-(defun compute-primary-cache-location-from-location (to-cache
- from-location
- &optional
- (from-cache to-cache))
- (declare (type cache to-cache from-cache) (fixnum from-location))
- (let ((result 0)
- (cache-vector (cache-vector from-cache))
- (mask (cache-mask to-cache))
- (nkeys (cache-nkeys to-cache)))
- (declare (fixnum result mask nkeys)
- (simple-vector cache-vector))
- (dotimes-fixnum (i nkeys)
- ;; FIXME: Sometimes we get NIL here as wrapper, apparently because
- ;; another thread has stomped on the cache-vector.
- (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location)))
- (wcn (layout-clos-hash wrapper)))
- (incf result wcn))
- (when (and (not (zerop i))
- (zerop (mod i wrapper-cache-number-adds-ok)))
- (setq result (logand result wrapper-cache-number-mask))))
- (if (= nkeys 1)
- (logand mask result)
- (1+ (logand mask result)))))
-\f
-(defmacro with-local-cache-functions ((cache) &body body)
- `(let ((.cache. ,cache))
- (declare (type cache .cache.))
- (labels ((cache () .cache.)
- (nkeys () (cache-nkeys .cache.))
- (line-size () (cache-line-size .cache.))
- (c-vector () (cache-vector .cache.))
- (valuep () (cache-valuep .cache.))
- (nlines () (cache-nlines .cache.))
- (max-location () (cache-max-location .cache.))
- (limit-fn () (cache-limit-fn .cache.))
- (size () (cache-size .cache.))
- (mask () (cache-mask .cache.))
- (overflow () (cache-overflow .cache.))
- ;;
- ;; Return T IFF this cache location is reserved. The
- ;; only time this is true is for line number 0 of an
- ;; nkeys=1 cache.
- ;;
- (line-reserved-p (line)
- (declare (fixnum line))
- (and (= (nkeys) 1)
- (= line 0)))
- ;;
- (location-reserved-p (location)
- (declare (fixnum location))
- (and (= (nkeys) 1)
- (= location 0)))
- ;;
- ;; Given a line number, return the cache location.
- ;; This is the value that is the second argument to
- ;; cache-vector-ref. Basically, this deals with the
- ;; offset of nkeys>1 caches and multiplies by line
- ;; size.
- ;;
- (line-location (line)
- (declare (fixnum line))
- (when (line-reserved-p line)
- (error "line is reserved"))
- (if (= (nkeys) 1)
- (the fixnum (* line (line-size)))
- (the fixnum (1+ (the fixnum (* line (line-size)))))))
- ;;
- ;; Given a cache location, return the line. This is
- ;; the inverse of LINE-LOCATION.
- ;;
- (location-line (location)
- (declare (fixnum location))
- (if (= (nkeys) 1)
- (floor location (line-size))
- (floor (the fixnum (1- location)) (line-size))))
- ;;
- ;; Given a line number, return the wrappers stored at
- ;; that line. As usual, if nkeys=1, this returns a
- ;; single value. Only when nkeys>1 does it return a
- ;; list. An error is signalled if the line is
- ;; reserved.
- ;;
- (line-wrappers (line)
- (declare (fixnum line))
- (when (line-reserved-p line) (error "Line is reserved."))
- (location-wrappers (line-location line)))
- ;;
- (location-wrappers (location) ; avoid multiplies caused by line-location
- (declare (fixnum location))
- (if (= (nkeys) 1)
- (cache-vector-ref (c-vector) location)
- (let ((list (make-list (nkeys)))
- (vector (c-vector)))
- (declare (simple-vector vector))
- (dotimes (i (nkeys) list)
- (declare (fixnum i))
- (setf (nth i list)
- (cache-vector-ref vector (+ location i)))))))
- ;;
- ;; Given a line number, return true IFF the line's
- ;; wrappers are the same as wrappers.
- ;;
- (line-matches-wrappers-p (line wrappers)
- (declare (fixnum line))
- (and (not (line-reserved-p line))
- (location-matches-wrappers-p (line-location line)
- wrappers)))
- ;;
- (location-matches-wrappers-p (loc wrappers) ; must not be reserved
- (declare (fixnum loc))
- (let ((cache-vector (c-vector)))
- (declare (simple-vector cache-vector))
- (if (= (nkeys) 1)
- (eq wrappers (cache-vector-ref cache-vector loc))
- (dotimes (i (nkeys) t)
- (declare (fixnum i))
- (unless (eq (pop wrappers)
- (cache-vector-ref cache-vector (+ loc i)))
- (return nil))))))
- ;;
- ;; Given a line number, return the value stored at that line.
- ;; If valuep is NIL, this returns NIL. As with line-wrappers,
- ;; an error is signalled if the line is reserved.
- ;;
- (line-value (line)
- (declare (fixnum line))
- (when (line-reserved-p line) (error "Line is reserved."))
- (location-value (line-location line)))
- ;;
- (location-value (loc)
- (declare (fixnum loc))
- (and (valuep)
- (cache-vector-ref (c-vector) (+ loc (nkeys)))))
- ;;
- ;; Given a line number, return true IFF that line has data in
- ;; it. The state of the wrappers stored in the line is not
- ;; checked. An error is signalled if line is reserved.
- (line-full-p (line)
- (when (line-reserved-p line) (error "Line is reserved."))
- (not (null (cache-vector-ref (c-vector) (line-location line)))))
- ;;
- ;; Given a line number, return true IFF the line is full and
- ;; there are no invalid wrappers in the line, and the line's
- ;; wrappers are different from wrappers.
- ;; An error is signalled if the line is reserved.
- ;;
- (line-valid-p (line wrappers)
- (declare (fixnum line))
- (when (line-reserved-p line) (error "Line is reserved."))
- (location-valid-p (line-location line) wrappers))
- ;;
- (location-valid-p (loc wrappers)
- (declare (fixnum loc))
- (let ((cache-vector (c-vector))
- (wrappers-mismatch-p (null wrappers)))
- (declare (simple-vector cache-vector))
- (dotimes (i (nkeys) wrappers-mismatch-p)
- (declare (fixnum i))
- (let ((wrapper (cache-vector-ref cache-vector (+ loc i))))
- (when (or (null wrapper)
- (invalid-wrapper-p wrapper))
- (return nil))
- (unless (and wrappers
- (eq wrapper
- (if (consp wrappers)
- (pop wrappers)
- wrappers)))
- (setq wrappers-mismatch-p t))))))
- ;;
- ;; How many unreserved lines separate line-1 and line-2.
- ;;
- (line-separation (line-1 line-2)
- (declare (fixnum line-1 line-2))
- (let ((diff (the fixnum (- line-2 line-1))))
- (declare (fixnum diff))
- (when (minusp diff)
- (setq diff (+ diff (nlines)))
- (when (line-reserved-p 0)
- (setq diff (1- diff))))
- diff))
- ;;
- ;; Given a cache line, get the next cache line. This will not
- ;; return a reserved line.
- ;;
- (next-line (line)
- (declare (fixnum line))
- (if (= line (the fixnum (1- (nlines))))
- (if (line-reserved-p 0) 1 0)
- (the fixnum (1+ line))))
- ;;
- (next-location (loc)
- (declare (fixnum loc))
- (if (= loc (max-location))
- (if (= (nkeys) 1)
- (line-size)
- 1)
- (the fixnum (+ loc (line-size)))))
- ;;
- ;; Given a line which has a valid entry in it, this
- ;; will return the primary cache line of the wrappers
- ;; in that line. We just call
- ;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this
- ;; is an easier packaging up of the call to it.
- ;;
- (line-primary (line)
- (declare (fixnum line))
- (location-line (line-primary-location line)))
- ;;
- (line-primary-location (line)
- (declare (fixnum line))
- (compute-primary-cache-location-from-location
- (cache) (line-location line))))
- (declare (ignorable #'cache #'nkeys #'line-size #'c-vector #'valuep
- #'nlines #'max-location #'limit-fn #'size
- #'mask #'overflow #'line-reserved-p
- #'location-reserved-p #'line-location
- #'location-line #'line-wrappers #'location-wrappers
- #'line-matches-wrappers-p
- #'location-matches-wrappers-p
- #'line-value #'location-value #'line-full-p
- #'line-valid-p #'location-valid-p
- #'line-separation #'next-line #'next-location
- #'line-primary #'line-primary-location))
- ,@body)))
-\f
-;;; Here is where we actually fill, recache and expand caches.
+;;;; Public API:
+;;;;
+;;;; fill-cache
+;;;; probe-cache
+;;;; make-cache
+;;;; map-cache
+;;;; emit-cache-lookup
+;;;; copy-cache
+;;;; hash-table-to-cache
+;;;;
+;;;; This is a thread and interrupt safe reimplementation loosely
+;;;; based on the original PCL cache by Kickzales and Rodrigues,
+;;;; as described in "Efficient Method Dispatch in PCL".
+;;;;
+;;;; * Writes to cache are made atomic using compare-and-swap on
+;;;; wrappers. Wrappers are never moved or deleted after they have
+;;;; been written: to clean them out the cache need to be copied.
+;;;;
+;;;; * Copying or expanding the cache drops out incomplete and invalid
+;;;; lines.
+;;;;
+;;;; * Since the cache is used for memoization only we don't need to
+;;;; worry about which of simultaneous replacements (when expanding
+;;;; the cache) takes place: the loosing one will have its work
+;;;; redone later. This also allows us to drop entries when the
+;;;; cache is about to grow insanely huge.
+;;;;
+;;;; The cache is essentially a specialized hash-table for layouts, used
+;;;; for memoization of effective methods, slot locations, and constant
+;;;; return values.
+;;;;
+;;;; Subsequences of the cache vector are called cache lines.
+;;;;
+;;;; The cache vector uses the symbol SB-PCL::..EMPTY.. as a sentinel
+;;;; value, to allow storing NILs in the vector as well.
+
+(defstruct (cache (:constructor %make-cache)
+ (:copier %copy-cache))
+ ;; Number of keys the cache uses.
+ (key-count 1 :type (integer 1 (#.call-arguments-limit)))
+ ;; True if we store values in the cache.
+ (value)
+ ;; Number of vector elements a single cache line uses in the vector.
+ ;; This is always a power of two, so that the vector length can be both
+ ;; an exact multiple of this and a power of two.
+ (line-size 1 :type (integer 1 #.most-positive-fixnum))
+ ;; Cache vector, its length is always both a multiple of line-size
+ ;; and a power of two. This is so that we can calculate
+ ;; (mod index (length vector))
+ ;; using a bitmask.
+ (vector #() :type simple-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)
+ ;; Maximum allowed probe-depth before the cache needs to expand.
+ (limit 0 :type index))
+
+(defun compute-cache-mask (vector-length line-size)
+ ;; Since both vector-length and line-size are powers of two, we
+ ;; can compute a bitmask such that
+ ;;
+ ;; (logand <mask> <combined-layout-hash>)
+ ;;
+ ;; is "morally equal" to
+ ;;
+ ;; (mod (* <line-size> <combined-layout-hash>) <vector-length>)
+ ;;
+ ;; This is it: (1- vector-length) is #b111... of the approriate size
+ ;; to get the MOD, and (- line-size) gives right the number of zero
+ ;; bits at the low end.
+ (logand (1- vector-length) (- line-size)))
+
+;;; The smallest power of two that is equal to or greater then X.
+(declaim (inline power-of-two-ceiling))
+(defun power-of-two-ceiling (x)
+ (ash 1 (integer-length (1- x))))
+
+(defun cache-statistics (cache)
+ (let* ((vector (cache-vector cache))
+ (size (length vector))
+ (line-size (cache-line-size cache))
+ (total-lines (/ size line-size))
+ (free-lines (loop for i from 0 by line-size below size
+ unless (eq (svref vector i) '..empty..)
+ count t)))
+ (values (- total-lines free-lines) total-lines
+ (cache-depth cache) (cache-limit cache))))
+
+;;; Don't allocate insanely huge caches: this is 4096 lines for a
+;;; value cache with 8-15 keys -- probably "big enough for anyone",
+;;; and 16384 lines for a commonplace 2-key value cache.
+(defconstant +cache-vector-max-length+ (expt 2 16))
+
+;;; Compute the maximum allowed probe depth as a function of cache size.
+;;; Cache size refers to number of cache lines, not the length of the
+;;; cache vector.