;;;; warranty about the software, its performance or its conformity to any
;;;; specification.
-(in-package "SB-PCL")
-\f
-;;; The caching algorithm implemented:
-;;;
-;;; << put a paper here >>
-;;;
-;;; For now, understand that as far as most of this code goes, a cache
-;;; has two important properties. The first is the number of wrappers
-;;; used as keys in each cache line. Throughout this code, this value
-;;; is always called NKEYS. The second is whether or not the cache
-;;; lines of a cache store a value. Throughout this code, this always
-;;; called VALUEP.
-;;;
-;;; Depending on these values, there are three kinds of caches.
-;;;
-;;; NKEYS = 1, VALUEP = NIL
-;;;
-;;; In this kind of cache, each line is 1 word long. No cache locking
-;;; is needed since all read's in the cache are a single value.
-;;; Nevertheless line 0 (location 0) is reserved, to ensure that
-;;; invalid wrappers will not get a first probe hit.
-;;;
-;;; To keep the code simpler, a cache lock count does appear in
-;;; location 0 of these caches, that count is incremented whenever
-;;; data is written to the cache. But, the actual lookup code (see
-;;; make-dlap) doesn't need to do locking when reading the cache.
-;;;
-;;; NKEYS = 1, VALUEP = T
-;;;
-;;; In this kind of cache, each line is 2 words long. Cache locking
-;;; must be done to ensure the synchronization of cache reads. Line 0
-;;; of the cache (location 0) is reserved for the cache lock count.
-;;; Location 1 of the cache is unused (in effect wasted).
-;;;
-;;; NKEYS > 1
-;;;
-;;; In this kind of cache, the 0 word of the cache holds the lock
-;;; count. The 1 word of the cache is line 0. Line 0 of these caches
-;;; is not reserved.
-;;;
-;;; This is done because in this sort of cache, the overhead of doing
-;;; the cache probe is high enough that the 1+ required to offset the
-;;; location is not a significant cost. In addition, because of the
-;;; larger line sizes, the space that would be wasted by reserving
-;;; line 0 to hold the lock count is more significant.
-\f
-;;; caches
-;;;
-;;; A cache is essentially just a vector. The use of the individual
-;;; `words' in the vector depends on particular properties of the
-;;; cache as described above.
-;;;
-;;; This defines an abstraction for caches in terms of their most
-;;; obvious implementation as simple vectors. But, please notice that
-;;; part of the implementation of this abstraction, is the function
-;;; lap-out-cache-ref. This means that most port-specific
-;;; modifications to the implementation of caches will require
-;;; corresponding port-specific modifications to the lap code
-;;; assembler.
-(defmacro cache-vector-ref (cache-vector location)
- `(svref (the simple-vector ,cache-vector)
- (sb-ext:truly-the fixnum ,location)))
-
-(defmacro cache-vector-size (cache-vector)
- `(array-dimension (the simple-vector ,cache-vector) 0))
-
-(defun allocate-cache-vector (size)
- (make-array size :adjustable nil))
-
-(defmacro cache-vector-lock-count (cache-vector)
- `(cache-vector-ref ,cache-vector 0))
-
-(defun flush-cache-vector-internal (cache-vector)
- (with-pcl-lock
- (fill (the simple-vector cache-vector) nil)
- (setf (cache-vector-lock-count cache-vector) 0))
- cache-vector)
-
-(defmacro modify-cache (cache-vector &body body)
- `(with-pcl-lock
- (multiple-value-prog1
- (progn ,@body)
- (let ((old-count (cache-vector-lock-count ,cache-vector)))
- (declare (fixnum old-count))
- (setf (cache-vector-lock-count ,cache-vector)
- (if (= old-count most-positive-fixnum)
- 1 (the fixnum (1+ old-count))))))))
-
-(deftype field-type ()
- '(mod #.layout-clos-hash-length))
+;;;; Note: as of SBCL 1.0.6.3 it is questionable if cache.lisp can
+;;;; anymore be considered to be "derived from software originally
+;;;; released by Xerox Corporation", as at that time the whole cache
+;;;; implementation was essentially redone from scratch.
-(eval-when (:compile-toplevel :load-toplevel :execute)
-(defun power-of-two-ceiling (x)
- (declare (fixnum x))
- ;;(expt 2 (ceiling (log x 2)))
- (the fixnum (ash 1 (integer-length (1- x)))))
-) ; EVAL-WHEN
-
-(defconstant +nkeys-limit+ 256)
+(in-package "SB-PCL")
-(defstruct (cache (:constructor make-cache ())
- (:copier copy-cache-internal))
- (owner nil)
- (nkeys 1 :type (integer 1 #.+nkeys-limit+))
- (valuep nil :type (member nil t))
- (nlines 0 :type fixnum)
- (field 0 :type field-type)
- (limit-fn #'default-limit-fn :type function)
- (mask 0 :type fixnum)
- (size 0 :type fixnum)
- (line-size 1 :type (integer 1 #.(power-of-two-ceiling (1+ +nkeys-limit+))))
- (max-location 0 :type fixnum)
+;;;; 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)
- (overflow nil :type list))
-
-#-sb-fluid (declaim (sb-ext:freeze-type cache))
-
-(defmacro cache-lock-count (cache)
- `(cache-vector-lock-count (cache-vector ,cache)))
-\f
-;;; Return a cache that has had FLUSH-CACHE-VECTOR-INTERNAL called on
-;;; it. This returns a cache of exactly the size requested, it won't
-;;; ever return a larger cache.
-(defun get-cache-vector (size)
- (flush-cache-vector-internal (make-array size)))
-
-\f
-;;;; wrapper cache numbers
-
-;;; 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 layout-clos-hash-max))
-(defconstant wrapper-cache-number-mask layout-clos-hash-max)
-(defconstant wrapper-cache-number-adds-ok
- (truncate most-positive-fixnum layout-clos-hash-max))
-\f
-;;;; wrappers themselves
-
-;;; 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.
-
-;;; In SBCL, as in CMU CL, we want to do type checking as early as
-;;; possible; structures help this. The structures are hard-wired to
-;;; have a fixed number of cache hash values, and that number must
-;;; correspond to the number of cache lines we use.
-(defconstant wrapper-cache-number-vector-length
- layout-clos-hash-length)
-
-(unless (boundp '*the-class-t*)
- (setq *the-class-t* nil))
-
-(defmacro wrapper-class (wrapper)
- `(classoid-pcl-class (layout-classoid ,wrapper)))
-(defmacro wrapper-no-of-instance-slots (wrapper)
- `(layout-length ,wrapper))
-
-(defmacro wrapper-instance-slots-layout (wrapper)
- `(%wrapper-instance-slots-layout ,wrapper))
-(defmacro wrapper-class-slots (wrapper)
- `(%wrapper-class-slots ,wrapper))
-(defmacro wrapper-cache-number-vector (x) x)
-
-;;; This is called in BRAID when we are making wrappers for classes
-;;; whose slots are not initialized yet, and which may be built-in
-;;; classes. We pass in the class name in addition to the class.
-(defun boot-make-wrapper (length name &optional class)
- (let ((found (find-classoid name nil)))
- (cond
- (found
- (unless (classoid-pcl-class found)
- (setf (classoid-pcl-class found) class))
- (aver (eq (classoid-pcl-class found) class))
- (let ((layout (classoid-layout found)))
- (aver layout)
- layout))
- (t
- (make-wrapper-internal
- :length length
- :classoid (make-standard-classoid
- :name name :pcl-class class))))))
-
-;;; The following variable may be set to a STANDARD-CLASS that has
-;;; already been created by the lisp code and which is to be redefined
-;;; by PCL. This allows STANDARD-CLASSes to be defined and used for
-;;; type testing and dispatch before PCL is loaded.
-(defvar *pcl-class-boot* nil)
-
-;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in
-;;; and structure classes already exist when PCL is initialized, so we
-;;; don't necessarily always make a wrapper. Also, we help maintain
-;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects.
-(defun make-wrapper (length class)
- (cond
- ((or (typep class 'std-class)
- (typep class 'forward-referenced-class))
- (make-wrapper-internal
- :length length
- :classoid
- (let ((owrap (class-wrapper class)))
- (cond (owrap
- (layout-classoid owrap))
- ((or (*subtypep (class-of class) *the-class-standard-class*)
- (typep class 'forward-referenced-class))
- (cond ((and *pcl-class-boot*
- (eq (slot-value class 'name) *pcl-class-boot*))
- (let ((found (find-classoid
- (slot-value class 'name))))
- (unless (classoid-pcl-class found)
- (setf (classoid-pcl-class found) class))
- (aver (eq (classoid-pcl-class found) class))
- found))
- (t
- (make-standard-classoid :pcl-class class))))
- (t
- (make-random-pcl-classoid :pcl-class class))))))
- (t
- (let* ((found (find-classoid (slot-value class 'name)))
- (layout (classoid-layout found)))
- (unless (classoid-pcl-class found)
- (setf (classoid-pcl-class found) class))
- (aver (eq (classoid-pcl-class found) class))
- (aver layout)
- layout))))
-
-(defconstant +first-wrapper-cache-number-index+ 0)
-
-(declaim (inline next-wrapper-cache-number-index))
-(defun next-wrapper-cache-number-index (field-number)
- (and (< field-number #.(1- wrapper-cache-number-vector-length))
- (1+ field-number)))
-
-;;; FIXME: Why are there two layers here, with one operator trivially
-;;; defined in terms of the other? It'd be nice either to have a
-;;; comment explaining why the separation is valuable, or to collapse
-;;; it into a single layer.
-;;;
-;;; FIXME (?): These are logically inline functions, but they need to
-;;; be SETFable, and for now it seems not worth the trouble to DEFUN
-;;; both inline FOO and inline (SETF FOO) for each one instead of a
-;;; single macro. Perhaps the best thing would be to make them
-;;; immutable (since it seems sort of surprising and gross to be able
-;;; to modify hash values) so that they can become inline functions
-;;; with no muss or fuss. I (WHN) didn't do this only because I didn't
-;;; know whether any code anywhere depends on the values being
-;;; modified.
-(defmacro cache-number-vector-ref (cnv n)
- `(wrapper-cache-number-vector-ref ,cnv ,n))
-(defmacro wrapper-cache-number-vector-ref (wrapper n)
- `(layout-clos-hash ,wrapper ,n))
-
-(declaim (inline wrapper-class*))
-(defun wrapper-class* (wrapper)
- (or (wrapper-class wrapper)
- (ensure-non-standard-class
- (classoid-name (layout-classoid wrapper)))))
-
-;;; The wrapper cache machinery provides general mechanism for
-;;; trapping on the next access to any instance of a given class. This
-;;; mechanism is used to implement the updating of instances when the
-;;; class is redefined (MAKE-INSTANCES-OBSOLETE). The same mechanism
-;;; is also used to update generic function caches when there is a
-;;; change to the superclasses of a class.
-;;;
-;;; Basically, a given wrapper can be valid or invalid. If it is
-;;; invalid, it means that any attempt to do a wrapper cache lookup
-;;; using the wrapper should trap. Also, methods on
-;;; SLOT-VALUE-USING-CLASS check the wrapper validity as well. This is
-;;; done by calling CHECK-WRAPPER-VALIDITY.
-
-(declaim (inline invalid-wrapper-p))
-(defun invalid-wrapper-p (wrapper)
- (not (null (layout-invalid wrapper))))
-
-(defvar *previous-nwrappers* (make-hash-table))
-
-(defun invalidate-wrapper (owrapper state nwrapper)
- (aver (member state '(:flush :obsolete) :test #'eq))
- (let ((new-previous ()))
- ;; First off, a previous call to INVALIDATE-WRAPPER may have
- ;; recorded OWRAPPER as an NWRAPPER to update to. Since OWRAPPER
- ;; is about to be invalid, it no longer makes sense to update to
- ;; it.
- ;;
- ;; We go back and change the previously invalidated wrappers so
- ;; that they will now update directly to NWRAPPER. This
- ;; corresponds to a kind of transitivity of wrapper updates.
- (dolist (previous (gethash owrapper *previous-nwrappers*))
- (when (eq state :obsolete)
- (setf (car previous) :obsolete))
- (setf (cadr previous) nwrapper)
- (push previous new-previous))
-
- (let ((ocnv (wrapper-cache-number-vector owrapper)))
- (dotimes (i layout-clos-hash-length)
- (setf (cache-number-vector-ref ocnv i) 0)))
-
- (push (setf (layout-invalid owrapper) (list state nwrapper))
- new-previous)
-
- (setf (gethash owrapper *previous-nwrappers*) ()
- (gethash nwrapper *previous-nwrappers*) new-previous)))
-
-(defun check-wrapper-validity (instance)
- (let* ((owrapper (wrapper-of instance))
- (state (layout-invalid owrapper)))
- (aver (not (eq state :uninitialized)))
- (etypecase state
- (null owrapper)
- ;; FIXME: I can't help thinking that, while this does cure the
- ;; symptoms observed from some class redefinitions, this isn't
- ;; the place to be doing this flushing. Nevertheless... --
- ;; CSR, 2003-05-31
- ;;
- ;; CMUCL comment:
- ;; We assume in this case, that the :INVALID is from a
- ;; previous call to REGISTER-LAYOUT for a superclass of
- ;; INSTANCE's class. See also the comment above
- ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this.
- ((member t)
- (let ((class (class-of instance)))
- (force-cache-flushes class)
- (class-wrapper class)))
- (cons
- (ecase (car state)
- (:flush
- (flush-cache-trap owrapper (cadr state) instance))
- (:obsolete
- (obsolete-instance-trap owrapper (cadr state) instance)))))))
-
-(declaim (inline check-obsolete-instance))
-(defun check-obsolete-instance (instance)
- (when (invalid-wrapper-p (layout-of instance))
- (check-wrapper-validity instance)))
-\f
-
-(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-field cache) +first-wrapper-cache-number-index+
- (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
- &optional (new-field +first-wrapper-cache-number-index+))
- (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-field cache) new-field
- (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-line-size (x)
- (power-of-two-ceiling x))
-
-(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 (if (typep nlines-or-cache-vector 'fixnum)
- (the fixnum
- (* line-size
- (the fixnum
- (power-of-two-ceiling
- nlines-or-cache-vector))))
- (cache-vector-size nlines-or-cache-vector))))
- (declare (fixnum line-size cache-size))
- (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
- cache-size
- line-size
- (the (values fixnum t) (floor cache-size line-size))))
- (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys)))
- (cache-size (if (typep nlines-or-cache-vector 'fixnum)
- (the fixnum
- (* line-size
- (the fixnum
- (power-of-two-ceiling
- nlines-or-cache-vector))))
- (1- (cache-vector-size nlines-or-cache-vector)))))
- (declare (fixnum line-size cache-size))
- (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
- (the fixnum (1+ cache-size))
- line-size
- (the (values fixnum t) (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 (field mask wrappers)
-
- (declare (type field-type field) (fixnum mask))
- (if (not (listp wrappers))
- (logand mask
- (the fixnum (wrapper-cache-number-vector-ref wrappers field)))
- (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 (wrapper-cache-number-vector-ref wrapper
- field)))
- (declare (fixnum wrapper-cache-number))
- (if (zerop wrapper-cache-number)
- (return-from compute-primary-cache-location 0)
- (setq location
- (the fixnum (+ 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))
- (the fixnum (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.
+ ;; 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.
;;;
-;;; 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))
- (field (cache-field to-cache))
- (mask (cache-mask to-cache))
- (nkeys (cache-nkeys to-cache)))
- (declare (type field-type field) (fixnum result mask nkeys)
- (simple-vector cache-vector))
- (dotimes-fixnum (i nkeys)
- (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location)))
- (wcn (wrapper-cache-number-vector-ref wrapper field)))
- (declare (fixnum wcn))
- (setq result (+ 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)
- (the fixnum (1+ (logand mask result))))))
-\f
-;;; NIL means nothing so far, no actual arg info has NILs
-;;; in the metatype
-;;; CLASS seen all sorts of metaclasses
-;;; (specifically, more than one of the next 4 values)
-;;; T means everything so far is the class T
-;;; STANDARD-CLASS seen only standard classes
-;;; BUILT-IN-CLASS seen only built in classes
-;;; STRUCTURE-CLASS seen only structure classes
-(defun raise-metatype (metatype new-specializer)
- (let ((slot (find-class 'slot-class))
- (std (find-class 'std-class))
- (standard (find-class 'standard-class))
- (fsc (find-class 'funcallable-standard-class))
- (condition (find-class 'condition-class))
- (structure (find-class 'structure-class))
- (built-in (find-class 'built-in-class)))
- (flet ((specializer->metatype (x)
- (let ((meta-specializer
- (if (eq *boot-state* 'complete)
- (class-of (specializer-class x))
- (class-of x))))
- (cond
- ((eq x *the-class-t*) t)
- ((*subtypep meta-specializer std) 'standard-instance)
- ((*subtypep meta-specializer standard) 'standard-instance)
- ((*subtypep meta-specializer fsc) 'standard-instance)
- ((*subtypep meta-specializer condition) 'condition-instance)
- ((*subtypep meta-specializer structure) 'structure-instance)
- ((*subtypep meta-specializer built-in) 'built-in-instance)
- ((*subtypep meta-specializer slot) 'slot-instance)
- (t (error "~@<PCL cannot handle the specializer ~S ~
- (meta-specializer ~S).~@:>"
- new-specializer
- meta-specializer))))))
- ;; We implement the following table. The notation is
- ;; that X and Y are distinct meta specializer names.
- ;;
- ;; NIL <anything> ===> <anything>
- ;; X X ===> X
- ;; X Y ===> CLASS
- (let ((new-metatype (specializer->metatype new-specializer)))
- (cond ((eq new-metatype 'slot-instance) 'class)
- ((null metatype) new-metatype)
- ((eq metatype new-metatype) new-metatype)
- (t 'class))))))
-
-(defmacro with-dfun-wrappers ((args metatypes)
- (dfun-wrappers invalid-wrapper-p
- &optional wrappers classes types)
- invalid-arguments-form
- &body body)
- `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
- (,dfun-wrappers nil) (dfun-wrappers-tail nil)
- ,@(when wrappers
- `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
- (dolist (mt ,metatypes)
- (unless args-tail
- (setq invalid-arguments-p t)
- (return nil))
- (let* ((arg (pop args-tail))
- (wrapper nil)
- ,@(when wrappers
- `((class *the-class-t*)
- (type t))))
- (unless (eq mt t)
- (setq wrapper (wrapper-of arg))
- (when (invalid-wrapper-p wrapper)
- (setq ,invalid-wrapper-p t)
- (setq wrapper (check-wrapper-validity arg)))
- (cond ((null ,dfun-wrappers)
- (setq ,dfun-wrappers wrapper))
- ((not (consp ,dfun-wrappers))
- (setq dfun-wrappers-tail (list wrapper))
- (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
- (t
- (let ((new-dfun-wrappers-tail (list wrapper)))
- (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
- (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
- ,@(when wrappers
- `((setq class (wrapper-class* wrapper))
- (setq type `(class-eq ,class)))))
- ,@(when wrappers
- `((push wrapper wrappers-rev)
- (push class classes-rev)
- (push type types-rev)))))
- (if invalid-arguments-p
- ,invalid-arguments-form
- (let* (,@(when wrappers
- `((,wrappers (nreverse wrappers-rev))
- (,classes (nreverse classes-rev))
- (,types (mapcar (lambda (class)
- `(class-eq ,class))
- ,classes)))))
- ,@body))))
-\f
-;;;; some support stuff for getting a hold of symbols that we need when
-;;;; building the discriminator codes. It's OK for these to be interned
-;;;; symbols because we don't capture any user code in the scope in which
-;;;; these symbols are bound.
-
-(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
+;;; FIXME: It would be nice to take the generic function optimization
+;;; policy into account here (speed vs. space.)
+(declaim (inline compute-limit))
+(defun compute-limit (size)
+ (ceiling (sqrt (sqrt size))))
+
+;;; Returns VALUE if it is not ..EMPTY.., otherwise executes ELSE:
+(defmacro non-empty-or (value else)
+ (with-unique-names (n-value)
+ `(let ((,n-value ,value))
+ (if (eq ,n-value '..empty..)
+ ,else
+ ,n-value))))
+
+;;; Fast way to check if a thing found at the position of a cache key is one:
+;;; it is always either a wrapper, or the ..EMPTY.. symbol.
+(declaim (inline cache-key-p))
+(defun cache-key-p (thing)
+ (not (symbolp thing)))
-(defun dfun-arg-symbol (arg-number)
- (or (nth arg-number (the list *dfun-arg-symbols*))
- (intern (format nil ".ARG~A." arg-number) *pcl-package*)))
-
-(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
-
-(defun slot-vector-symbol (arg-number)
- (or (nth arg-number (the list *slot-vector-symbols*))
- (intern (format nil ".SLOTS~A." arg-number) *pcl-package*)))
-
-;; FIXME: There ought to be a good way to factor out the idiom:
-;;
-;; (dotimes (i (length metatypes))
-;; (push (dfun-arg-symbol i) lambda-list))
-;;
-;; used in the following four functions into common code that we can
-;; declare inline or something. --njf 2001-12-20
-(defun make-dfun-lambda-list (metatypes applyp)
- (let ((lambda-list nil))
- (dotimes (i (length metatypes))
- (push (dfun-arg-symbol i) lambda-list))
- (when applyp
- (push '&rest lambda-list)
- (push '.dfun-rest-arg. lambda-list))
- (nreverse lambda-list)))
-
-(defun make-dlap-lambda-list (metatypes applyp)
- (let ((lambda-list nil))
- (dotimes (i (length metatypes))
- (push (dfun-arg-symbol i) lambda-list))
- ;; FIXME: This is translated directly from the old PCL code.
- ;; It didn't have a (PUSH '.DFUN-REST-ARG. LAMBDA-LIST) or
- ;; something similar, so we don't either. It's hard to see how
- ;; this could be correct, since &REST wants an argument after
- ;; it. This function works correctly because the caller
- ;; magically tacks on something after &REST. The calling functions
- ;; (in dlisp.lisp) should be fixed and this function rewritten.
- ;; --njf 2001-12-20
- (when applyp
- (push '&rest lambda-list))
- (nreverse lambda-list)))
-
-;; FIXME: The next two functions suffer from having a `.DFUN-REST-ARG.'
-;; in their lambda lists, but no corresponding `&REST' symbol. We assume
-;; this should be the case by analogy with the previous two functions.
-;; It works, and I don't know why. Check the calling functions and
-;; fix these too. --njf 2001-12-20
-(defun make-emf-call (metatypes applyp fn-variable &optional emf-type)
- (let ((required
- (let ((required nil))
- (dotimes (i (length metatypes))
- (push (dfun-arg-symbol i) required))
- (nreverse required))))
- `(,(if (eq emf-type 'fast-method-call)
- 'invoke-effective-method-function-fast
- 'invoke-effective-method-function)
- ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.)))))
-
-(defun make-fast-method-call-lambda-list (metatypes applyp)
- (let ((reversed-lambda-list nil))
- (push '.pv-cell. reversed-lambda-list)
- (push '.next-method-call. reversed-lambda-list)
- (dotimes (i (length metatypes))
- (push (dfun-arg-symbol i) reversed-lambda-list))
- (when applyp
- (push '.dfun-rest-arg. reversed-lambda-list))
- (nreverse reversed-lambda-list)))
-\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.))
- (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.))
- (field () (cache-field .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 (vector) location)
- (let ((list (make-list (nkeys)))
- (vector (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 (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 (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 (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 (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 #'vector #'valuep
- #'nlines #'max-location #'limit-fn #'size
- #'mask #'field #'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.
-;;;
-;;; The functions FILL-CACHE and PROBE-CACHE are the ONLY external
-;;; entrypoints into this code.
+(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)
+ while (and (< old depth)
+ (not (eq old (compare-and-swap (cache-depth cache)
+ old depth))))))
+
+;;; 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)
+ (logand mask (+ index line-size)))
+
+;;; Returns the hash-value for layout, or executes ELSE if the layout
+;;; is invalid.
+(defmacro hash-layout-or (layout else)
+ (with-unique-names (n-hash)
+ `(let ((,n-hash (layout-clos-hash ,layout)))
+ (if (zerop ,n-hash)
+ ,else
+ ,n-hash))))
+
+;;; Compute cache index for the cache and a list of layouts.
+(declaim (inline compute-cache-index))
+(defun compute-cache-index (cache layouts)
+ (let ((index (hash-layout-or (car layouts)
+ (return-from compute-cache-index nil))))
+ (declare (fixnum index))
+ (dolist (layout (cdr layouts))
+ (mixf index (hash-layout-or layout (return-from compute-cache-index nil))))
+ ;; align with cache lines
+ (logand index (cache-mask cache))))
+
+;;; Emit code that does lookup in cache bound to CACHE-VAR using
+;;; layouts bound to LAYOUT-VARS. Go to MISS-TAG on event of a miss or
+;;; invalid layout. Otherwise, if VALUE-VAR is non-nil, set it to the
+;;; value found. (VALUE-VAR is non-nil only when CACHE-VALUE is true.)
;;;
-;;; FILL-CACHE returns 1 value: a new cache
+;;; In other words, produces inlined code for COMPUTE-CACHE-INDEX when
+;;; number of keys and presence of values in the cache is known
+;;; beforehand.
+(defun emit-cache-lookup (cache-var layout-vars miss-tag value-var)
+ (let ((line-size (power-of-two-ceiling (+ (length layout-vars)
+ (if value-var 1 0)))))
+ (with-unique-names (n-index n-vector n-depth n-pointer n-mask
+ MATCH-WRAPPERS EXIT-WITH-HIT)
+ `(let* ((,n-index (hash-layout-or ,(car layout-vars) (go ,miss-tag)))
+ (,n-vector (cache-vector ,cache-var))
+ (,n-mask (cache-mask ,cache-var)))
+ (declare (index ,n-index))
+ ,@(mapcar (lambda (layout-var)
+ `(mixf ,n-index (hash-layout-or ,layout-var (go ,miss-tag))))
+ (cdr layout-vars))
+ ;; align with cache lines
+ (setf ,n-index (logand ,n-index ,n-mask))
+ (let ((,n-depth (cache-depth ,cache-var))
+ (,n-pointer ,n-index))
+ (declare (index ,n-depth ,n-pointer))
+ (tagbody
+ ,MATCH-WRAPPERS
+ (when (and ,@(mapcar
+ (lambda (layout-var)
+ `(prog1
+ (eq ,layout-var (svref ,n-vector ,n-pointer))
+ (incf ,n-pointer)))
+ layout-vars))
+ ,@(when value-var
+ `((setf ,value-var (non-empty-or (svref ,n-vector ,n-pointer)
+ (go ,miss-tag)))))
+ (go ,EXIT-WITH-HIT))
+ (if (zerop ,n-depth)
+ (go ,miss-tag)
+ (decf ,n-depth))
+ (setf ,n-index (next-cache-index ,n-mask ,n-index ,line-size)
+ ,n-pointer ,n-index)
+ (go ,MATCH-WRAPPERS)
+ ,EXIT-WITH-HIT))))))
+
+;;; Probes CACHE for LAYOUTS.
;;;
-;;; a wrapper field number
-;;; a cache
-;;; a mask
-;;; an absolute cache size (the size of the actual vector)
-;;; It tries to re-adjust the cache every time it makes a new fill.
-;;; The intuition here is that we want uniformity in the number of
-;;; probes needed to find an entry. Furthermore, adjusting has the
-;;; nice property of throwing out any entries that are invalid.
-(defvar *cache-expand-threshold* 1.25)
-
-(defun fill-cache (cache wrappers value)
- ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check..
- (assert wrappers)
-
- (or (fill-cache-p nil cache wrappers value)
- (and (< (ceiling (* (cache-count cache) 1.25))
- (if (= (cache-nkeys cache) 1)
- (1- (cache-nlines cache))
- (cache-nlines cache)))
- (adjust-cache cache wrappers value))
- (expand-cache cache wrappers value)))
-
-(defvar *check-cache-p* nil)
-
-(defmacro maybe-check-cache (cache)
- `(progn
- (when *check-cache-p*
- (check-cache ,cache))
- ,cache))
-
-(defun check-cache (cache)
- (with-local-cache-functions (cache)
- (let ((location (if (= (nkeys) 1) 0 1))
- (limit (funcall (limit-fn) (nlines))))
- (dotimes-fixnum (i (nlines) cache)
- (when (and (not (location-reserved-p location))
- (line-full-p i))
- (let* ((home-loc (compute-primary-cache-location-from-location
- cache location))
- (home (location-line (if (location-reserved-p home-loc)
- (next-location home-loc)
- home-loc)))
- (sep (when home (line-separation home i))))
- (when (and sep (> sep limit))
- (error "bad cache ~S ~@
- value at location ~W: ~W lines from its home. The limit is ~W."
- cache location sep limit))))
- (setq location (next-location location))))))
-
-(defun probe-cache (cache wrappers &optional default limit-fn)
- ;;(declare (values value))
- (unless wrappers
- ;; FIXME: This and another earlier test on a WRAPPERS arg can
- ;; be compact assertoids.
- (error "WRAPPERS arg is NIL!"))
- (with-local-cache-functions (cache)
- (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
- (limit (funcall (or limit-fn (limit-fn)) (nlines))))
- (declare (fixnum location limit))
- (when (location-reserved-p location)
- (setq location (next-location location)))
- (dotimes-fixnum (i (1+ limit))
- (when (location-matches-wrappers-p location wrappers)
- (return-from probe-cache (or (not (valuep))
- (location-value location))))
- (setq location (next-location location)))
- (dolist (entry (overflow))
- (when (equal (car entry) wrappers)
- (return-from probe-cache (or (not (valuep))
- (cdr entry)))))
- default)))
-
-(defun map-cache (function cache &optional set-p)
- (with-local-cache-functions (cache)
- (let ((set-p (and set-p (valuep))))
- (dotimes-fixnum (i (nlines) cache)
- (unless (or (line-reserved-p i) (not (line-valid-p i nil)))
- (let ((value (funcall function (line-wrappers i) (line-value i))))
- (when set-p
- (setf (cache-vector-ref (vector) (+ (line-location i) (nkeys)))
- value)))))
- (dolist (entry (overflow))
- (let ((value (funcall function (car entry) (cdr entry))))
- (when set-p
- (setf (cdr entry) value))))))
+;;; 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)
+ (unless (consp layouts)
+ (setf layouts (list layouts)))
+ (let ((vector (cache-vector cache))
+ (key-count (cache-key-count cache))
+ (line-size (cache-line-size cache))
+ (mask (cache-mask cache)))
+ (flet ((probe-line (base)
+ (tagbody
+ (loop for offset from 0 below key-count
+ for layout in layouts do
+ (unless (eq layout (svref vector (+ base offset)))
+ ;; missed
+ (go :miss)))
+ ;; all layouts match!
+ (let ((value (when (cache-value cache)
+ (non-empty-or (svref vector (+ base key-count))
+ (go :miss)))))
+ (return-from probe-cache (values t value)))
+ :miss
+ (return-from probe-line (next-cache-index mask base line-size)))))
+ (let ((index (compute-cache-index cache layouts)))
+ (when 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
+;;; the index BASE. Returns true on success, and false on failure.
+(defun try-update-cache-line (cache base layouts value)
+ (declare (index base))
+ (let ((vector (cache-vector cache))
+ (new (pop layouts)))
+ ;; If we unwind from here, we will be left with an incomplete
+ ;; cache line, but that is OK: next write using the same layouts
+ ;; will fill it, and reads will treat an incomplete line as a
+ ;; miss -- causing it to be filled.
+ (loop for old = (compare-and-swap (svref vector base) '..empty.. new) do
+ (when (and (cache-key-p old) (not (eq old new)))
+ ;; The place was already taken, and doesn't match our key.
+ (return-from try-update-cache-line nil))
+ (unless layouts
+ ;; All keys match or succesfully saved, save our value --
+ ;; just smash it in. Until the first time it is written
+ ;; there is ..EMPTY.. here, which probes look for, so we
+ ;; don't get bogus hits. This is necessary because we want
+ ;; to be able store arbitrary values here for use with
+ ;; constant-value dispatch functions.
+ (when (cache-value cache)
+ (setf (svref vector (1+ base)) value))
+ (return-from try-update-cache-line t))
+ (setf new (pop layouts))
+ (incf base))))
+
+;;; Tries to write LAYOUTS and VALUE somewhere in the cache. Returns
+;;; 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)
+ ;; At least one of the layouts was invalid: just
+ ;; pretend we updated the cache, and let the next
+ ;; read pick up the mess.
+ (return-from try-update-cache t)))
+ (line-size (cache-line-size cache))
+ (mask (cache-mask cache)))
+ (declare (index index))
+ (loop for depth from 0 upto (cache-limit cache) do
+ (when (try-update-cache-line cache index layouts value)
+ (note-cache-depth cache depth)
+ (return-from try-update-cache t))
+ (setf index (next-cache-index mask index line-size)))))
+
+;;; Constructs a new cache.
+(defun make-cache (&key (key-count (missing-arg)) (value (missing-arg))
+ (size 1))
+ (let* ((line-size (power-of-two-ceiling (+ key-count (if value 1 0))))
+ (adjusted-size (power-of-two-ceiling size))
+ (length (* adjusted-size line-size)))
+ (if (<= length +cache-vector-max-length+)
+ (%make-cache :key-count key-count
+ :line-size line-size
+ :vector (make-array length :initial-element '..empty..)
+ :value value
+ :mask (compute-cache-mask length line-size)
+ :limit (compute-limit adjusted-size))
+ ;; Make a smaller one, then
+ (make-cache :key-count key-count :value value :size (ceiling size 2)))))
+
+;;;; Copies and expands the cache, dropping any invalidated or
+;;;; incomplete lines.
+(defun copy-and-expand-cache (cache)
+ (let ((copy (%copy-cache cache))
+ (length (length (cache-vector cache))))
+ (when (< length +cache-vector-max-length+)
+ (setf length (* 2 length)))
+ (tagbody
+ :again
+ ;; Blow way the old vector first, so a GC potentially triggered by
+ ;; MAKE-ARRAY can collect it.
+ (setf (cache-vector copy) #()
+ (cache-vector copy) (make-array length :initial-element '..empty..)
+ (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))))
+ (map-cache (lambda (layouts value)
+ (unless (try-update-cache copy layouts value)
+ ;; If the cache would grow too much we drop the
+ ;; remaining the entries that don't fit. FIXME:
+ ;; It would be better to drop random entries to
+ ;; avoid getting into a rut here (best done by
+ ;; making MAP-CACHE map in a random order?), and
+ ;; possibly to downsize the cache more
+ ;; aggressively (on the assumption that most
+ ;; entries aren't getting used at the moment.)
+ (when (< length +cache-vector-max-length+)
+ (setf length (* 2 length))
+ (go :again))))
+ cache))
+ copy))
+
+(defun cache-has-invalid-entries-p (cache)
+ (let ((vector (cache-vector cache))
+ (line-size (cache-line-size cache))
+ (key-count (cache-key-count cache))
+ (mask (cache-mask cache))
+ (index 0))
+ (loop
+ ;; Check if the line is in use, and check validity of the keys.
+ (let ((key1 (svref vector index)))
+ (when (cache-key-p key1)
+ (if (zerop (layout-clos-hash key1))
+ ;; First key invalid.
+ (return-from cache-has-invalid-entries-p t)
+ ;; Line is in use and the first key is valid: check the rest.
+ (loop for offset from 1 below key-count
+ do (let ((thing (svref vector (+ index offset))))
+ (when (or (not (cache-key-p thing))
+ (zerop (layout-clos-hash thing)))
+ ;; Incomplete line or invalid layout.
+ (return-from cache-has-invalid-entries-p t)))))))
+ ;; Line empty of valid, onwards.
+ (setf index (next-cache-index mask index line-size))
+ (when (zerop index)
+ ;; wrapped around
+ (return-from cache-has-invalid-entries-p nil)))))
+
+(defun hash-table-to-cache (table &key value key-count)
+ (let ((cache (make-cache :key-count key-count :value value
+ :size (hash-table-count table))))
+ (maphash (lambda (class value)
+ (setq cache (fill-cache cache (class-wrapper class) value)))
+ table)
+ cache))
+
+;;; Inserts VALUE to CACHE keyd by LAYOUTS. Expands the cache if
+;;; necessary, and returns the new cache.
+(defun fill-cache (cache layouts value)
+ (labels
+ ((%fill-cache (cache layouts value)
+ (cond ((try-update-cache cache layouts value)
+ cache)
+ ((cache-has-invalid-entries-p cache)
+ ;; Don't expand yet: maybe there will be enough space if
+ ;; we just drop the invalid entries.
+ (%fill-cache (copy-cache cache) layouts value))
+ (t
+ (%fill-cache (copy-and-expand-cache cache) layouts value)))))
+ (if (listp layouts)
+ (%fill-cache cache layouts value)
+ (%fill-cache cache (list layouts) value))))
+
+;;; Calls FUNCTION with all layouts and values in cache.
+(defun map-cache (function cache)
+ (let* ((vector (cache-vector cache))
+ (key-count (cache-key-count cache))
+ (valuep (cache-value cache))
+ (line-size (cache-line-size cache))
+ (mask (cache-mask cache))
+ (fun (if (functionp function)
+ function
+ (fdefinition function)))
+ (index 0)
+ (key nil))
+ (tagbody
+ :map
+ (let ((layouts
+ (loop for offset from 0 below key-count
+ collect (non-empty-or (svref vector (+ offset index))
+ (go :next)))))
+ (let ((value (when valuep
+ (non-empty-or (svref vector (+ index key-count))
+ (go :next)))))
+ ;; Let the callee worry about invalid layouts
+ (funcall fun layouts value)))
+ :next
+ (setf index (next-cache-index mask index line-size))
+ (unless (zerop index)
+ (go :map))))
cache)
-(defun cache-count (cache)
- (with-local-cache-functions (cache)
- (let ((count 0))
- (declare (fixnum count))
- (dotimes-fixnum (i (nlines) count)
- (unless (line-reserved-p i)
- (when (line-full-p i)
- (incf count)))))))
-
-(defun entry-in-cache-p (cache wrappers value)
- (declare (ignore value))
- (with-local-cache-functions (cache)
- (dotimes-fixnum (i (nlines))
- (unless (line-reserved-p i)
- (when (equal (line-wrappers i) wrappers)
- (return t))))))
-
-;;; returns T or NIL
-(defun fill-cache-p (forcep cache wrappers value)
- (with-local-cache-functions (cache)
- (let* ((location (compute-primary-cache-location (field) (mask) wrappers))
- (primary (location-line location)))
- (declare (fixnum location primary))
- (multiple-value-bind (free emptyp)
- (find-free-cache-line primary cache wrappers)
- (when (or forcep emptyp)
- (when (not emptyp)
- (push (cons (line-wrappers free) (line-value free))
- (cache-overflow cache)))
- ;;(fill-line free wrappers value)
- (let ((line free))
- (declare (fixnum line))
- (when (line-reserved-p line)
- (error "attempt to fill a reserved line"))
- (let ((loc (line-location line))
- (cache-vector (vector)))
- (declare (fixnum loc) (simple-vector cache-vector))
- (cond ((= (nkeys) 1)
- (setf (cache-vector-ref cache-vector loc) wrappers)
- (when (valuep)
- (setf (cache-vector-ref cache-vector (1+ loc)) value)))
- (t
- (let ((i 0))
- (declare (fixnum i))
- (dolist (w wrappers)
- (setf (cache-vector-ref cache-vector (+ loc i)) w)
- (setq i (the fixnum (1+ i)))))
- (when (valuep)
- (setf (cache-vector-ref cache-vector (+ loc (nkeys)))
- value))))
- (maybe-check-cache cache))))))))
-
-(defun fill-cache-from-cache-p (forcep cache from-cache from-line)
- (declare (fixnum from-line))
- (with-local-cache-functions (cache)
- (let ((primary (location-line
- (compute-primary-cache-location-from-location
- cache (line-location from-line) from-cache))))
- (declare (fixnum primary))
- (multiple-value-bind (free emptyp)
- (find-free-cache-line primary cache)
- (when (or forcep emptyp)
- (when (not emptyp)
- (push (cons (line-wrappers free) (line-value free))
- (cache-overflow cache)))
- ;;(transfer-line from-cache-vector from-line cache-vector free)
- (let ((from-cache-vector (cache-vector from-cache))
- (to-cache-vector (vector))
- (to-line free))
- (declare (fixnum to-line))
- (if (line-reserved-p to-line)
- (error "transferring something into a reserved cache line")
- (let ((from-loc (line-location from-line))
- (to-loc (line-location to-line)))
- (declare (fixnum from-loc to-loc))
- (modify-cache to-cache-vector
- (dotimes-fixnum (i (line-size))
- (setf (cache-vector-ref to-cache-vector
- (+ to-loc i))
- (cache-vector-ref from-cache-vector
- (+ from-loc i)))))))
- (maybe-check-cache cache)))))))
-
-;;; Returns NIL or (values <field> <cache-vector>)
-;;;
-;;; This is only called when it isn't possible to put the entry in the
-;;; cache the easy way. That is, this function assumes that
-;;; FILL-CACHE-P has been called as returned NIL.
-;;;
-;;; If this returns NIL, it means that it wasn't possible to find a
-;;; wrapper field for which all of the entries could be put in the
-;;; cache (within the limit).
-(defun adjust-cache (cache wrappers value)
- (with-local-cache-functions (cache)
- (let ((ncache (get-cache-from-cache cache (nlines) (field))))
- (do ((nfield (cache-field ncache)
- (next-wrapper-cache-number-index nfield)))
- ((null nfield) nil)
- (setf (cache-field ncache) nfield)
- (labels ((try-one-fill-from-line (line)
- (fill-cache-from-cache-p nil ncache cache line))
- (try-one-fill (wrappers value)
- (fill-cache-p nil ncache wrappers value)))
- (if (and (dotimes-fixnum (i (nlines) t)
- (when (and (null (line-reserved-p i))
- (line-valid-p i wrappers))
- (unless (try-one-fill-from-line i) (return nil))))
- (dolist (wrappers+value (cache-overflow cache) t)
- (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
- (return nil)))
- (try-one-fill wrappers value))
- (return (maybe-check-cache ncache))
- (flush-cache-vector-internal (cache-vector ncache))))))))
-
-;;; returns: (values <cache>)
-(defun expand-cache (cache wrappers value)
- ;;(declare (values cache))
- (with-local-cache-functions (cache)
- (let ((ncache (get-cache-from-cache cache (* (nlines) 2))))
- (labels ((do-one-fill-from-line (line)
- (unless (fill-cache-from-cache-p nil ncache cache line)
- (do-one-fill (line-wrappers line) (line-value line))))
- (do-one-fill (wrappers value)
- (setq ncache (or (adjust-cache ncache wrappers value)
- (fill-cache-p t ncache wrappers value))))
- (try-one-fill (wrappers value)
- (fill-cache-p nil ncache wrappers value)))
- (dotimes-fixnum (i (nlines))
- (when (and (null (line-reserved-p i))
- (line-valid-p i wrappers))
- (do-one-fill-from-line i)))
- (dolist (wrappers+value (cache-overflow cache))
- (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
- (do-one-fill (car wrappers+value) (cdr wrappers+value))))
- (unless (try-one-fill wrappers value)
- (do-one-fill wrappers value))
- (maybe-check-cache ncache)))))
-\f
-;;; This is the heart of the cache filling mechanism. It implements
-;;; the decisions about where entries are placed.
-;;;
-;;; Find a line in the cache at which a new entry can be inserted.
-;;;
-;;; <line>
-;;; <empty?> is <line> in fact empty?
-(defun find-free-cache-line (primary cache &optional wrappers)
- ;;(declare (values line empty?))
- (declare (fixnum primary))
- (with-local-cache-functions (cache)
- (when (line-reserved-p primary) (setq primary (next-line primary)))
- (let ((limit (funcall (limit-fn) (nlines)))
- (wrappedp nil)
- (lines nil)
- (p primary) (s primary))
- (declare (fixnum p s limit))
- (block find-free
- (loop
- ;; Try to find a free line starting at <s>. <p> is the
- ;; primary line of the entry we are finding a free
- ;; line for, it is used to compute the separations.
- (do* ((line s (next-line line))
- (nsep (line-separation p s) (1+ nsep)))
- (())
- (declare (fixnum line nsep))
- (when (null (line-valid-p line wrappers)) ;If this line is empty or
- (push line lines) ;invalid, just use it.
- (return-from find-free))
- (when (and wrappedp (>= line primary))
- ;; have gone all the way around the cache, time to quit
- (return-from find-free-cache-line (values primary nil)))
- (let ((osep (line-separation (line-primary line) line)))
- (when (>= osep limit)
- (return-from find-free-cache-line (values primary nil)))
- (when (cond ((= nsep limit) t)
- ((= nsep osep) (zerop (random 2)))
- ((> nsep osep) t)
- (t nil))
- ;; See whether we can displace what is in this line so that we
- ;; can use the line.
- (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))
- (setq p (line-primary line))
- (setq s (next-line line))
- (push line lines)
- (return nil)))
- (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)))))
- ;; Do all the displacing.
- (loop
- (when (null (cdr lines)) (return nil))
- (let ((dline (pop lines))
- (line (car lines)))
- (declare (fixnum dline line))
- ;;Copy from line to dline (dline is known to be free).
- (let ((from-loc (line-location line))
- (to-loc (line-location dline))
- (cache-vector (vector)))
- (declare (fixnum from-loc to-loc) (simple-vector cache-vector))
- (modify-cache cache-vector
- (dotimes-fixnum (i (line-size))
- (setf (cache-vector-ref cache-vector
- (+ to-loc i))
- (cache-vector-ref cache-vector
- (+ from-loc i)))
- (setf (cache-vector-ref cache-vector
- (+ from-loc i))
- nil))))))
- (values (car lines) t))))
-
-(defun default-limit-fn (nlines)
- (case nlines
- ((1 2 4) 1)
- ((8 16) 4)
- (otherwise 6)))
-
-(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms
+;;; Copying a cache without expanding it is very much like mapping it:
+;;; we need to be carefull because there may be updates while we are
+;;; copying it, and we don't want to copy incomplete entries or invalid
+;;; ones.
+(defun copy-cache (cache)
+ (let* ((vector (cache-vector cache))
+ (copy (make-array (length vector) :initial-element '..empty..))
+ (line-size (cache-line-size cache))
+ (key-count (cache-key-count cache))
+ (valuep (cache-value cache))
+ (mask (cache-mask cache))
+ (size (/ (length vector) line-size))
+ (index 0)
+ (elt nil)
+ (depth 0))
+ (tagbody
+ :copy
+ (let ((layouts (loop for offset from 0 below key-count
+ collect (non-empty-or (svref vector (+ index offset))
+ (go :next)))))
+ ;; Check validity & compute primary index.
+ (let ((primary (or (compute-cache-index cache layouts)
+ (go :next))))
+ ;; Check & copy value.
+ (when valuep
+ (setf (svref copy (+ index key-count))
+ (non-empty-or (svref vector (+ index key-count))
+ (go :next))))
+ ;; Copy layouts.
+ (loop for offset from 0 below key-count do
+ (setf (svref copy (+ index offset)) (pop layouts)))
+ ;; Update probe depth.
+ (let ((distance (/ (- index primary) line-size)))
+ (setf depth (max depth (if (minusp distance)
+ ;; account for wrap-around
+ (+ distance size)
+ distance))))))
+ :next
+ (setf index (next-cache-index mask index line-size))
+ (unless (zerop index)
+ (go :copy)))
+ (%make-cache :vector copy
+ :depth depth
+ :key-count (cache-key-count cache)
+ :line-size line-size
+ :value valuep
+ :mask mask
+ :limit (cache-limit cache))))
+
+;;;; For debugging & collecting statistics.
+
+(defun map-all-caches (function)
+ (dolist (p (list-all-packages))
+ (do-symbols (s p)
+ (when (eq p (symbol-package s))
+ (dolist (name (list s
+ `(setf ,s)
+ (slot-reader-name s)
+ (slot-writer-name s)
+ (slot-boundp-name s)))
+ (when (fboundp name)
+ (let ((fun (fdefinition name)))
+ (when (typep fun 'generic-function)
+ (let ((cache (gf-dfun-cache fun)))
+ (when cache
+ (funcall function name cache)))))))))))
+
+(defun check-cache-consistency (cache)
+ (let ((table (make-hash-table :test 'equal)))
+ (map-cache (lambda (layouts value)
+ (declare (ignore value))
+ (if (gethash layouts table)
+ (cerror "Check futher."
+ "Multiple appearances of ~S." layouts)
+ (setf (gethash layouts table) t)))
+ cache)))
projects / sbcl.git / blobdiff