From 562e48a2bd3467121e24214110e535c841fbb622 Mon Sep 17 00:00:00 2001 From: Nikodemus Siivola Date: Mon, 28 May 2007 18:52:26 +0000 Subject: [PATCH] 1.0.6.3: thread and interrupt safe CLOS cache * New cache implementation. While the patch appears to modify src/pcl/cache.lisp, it is really a wholesale reimplementation. -- Use compare-and-swap to provide atomicity where necessary. -- Layouts are write-once, but cached values can be replaced atomically. -- Expanding the cache (or dropping invalidated and incomplete entries) copies the cache. -- Use ..EMPTY.. as a sentinel value to denote unused cache line slot. -- Cache index zero is no longer special. -- Maximum cache size is limited to avoid ridiculously huge caches. -- API changes in the cache code: MAKE-CACHE replaces GET-CACHE. PROBE-CACHE now returns a primary indicating a hit or a miss, and returns the probed value as the second return value. * Move remaining non-cache related code from cache.lisp. * Delete unused closure-based dispatch code (src/pcl/dlisp2.lisp). If we want to support a compilerless build at some future date this code can be always resurrected from the CVS -- or better yet, can be re-implemented. * Delete MAKE-FINAL-ONE-INDEX-ACCESSOR-DFUN, inlining it to the call-sites for easier understanding. (Yes, there is such a thing as too much abstraction.) --- NEWS | 3 + src/code/array.lisp | 1 + src/cold/warm.lisp | 1 - src/pcl/boot.lisp | 2 - src/pcl/cache.lisp | 1225 ++++++++++++++++-------------------------------- src/pcl/dfun.lisp | 93 ++-- src/pcl/dlisp.lisp | 146 +----- src/pcl/dlisp2.lisp | 132 ------ src/pcl/methods.lisp | 10 +- src/pcl/std-class.lisp | 6 +- src/pcl/vector.lisp | 32 +- version.lisp-expr | 2 +- 12 files changed, 481 insertions(+), 1172 deletions(-) delete mode 100644 src/pcl/dlisp2.lisp diff --git a/NEWS b/NEWS index 0f94229..6fed3ba 100644 --- a/NEWS +++ b/NEWS @@ -2,6 +2,9 @@ changes in sbcl-1.0.7 relative to sbcl-1.0.6: * enhancement: name of a socket-stream is now "a socket" instead of "a constant string". + * bug fix: the cache used by the CLOS to store precomputed effective + methods, slot offsets, and constant return values is now thread and + interrupt safe. changes in sbcl-1.0.6 relative to sbcl-1.0.5: * new contrib: sb-cover, an experimental code coverage tool, is included diff --git a/src/code/array.lisp b/src/code/array.lisp index d61aa46..50f730a 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -56,6 +56,7 @@ (values vector index)) (values array index))) +(declaim (inline simple-vector-compare-and-swap)) (defun simple-vector-compare-and-swap (vector index old new) #!+(or x86 x86-64) (%simple-vector-compare-and-swap vector diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 142aaa3..6fd757b 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -128,7 +128,6 @@ "SRC;PCL;WRAPPER" "SRC;PCL;CACHE" "SRC;PCL;DLISP" - "SRC;PCL;DLISP2" "SRC;PCL;BOOT" "SRC;PCL;VECTOR" "SRC;PCL;SLOTS-BOOT" diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 6d8c52c..8d87432 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -2009,8 +2009,6 @@ bootstrapping. (setf (gf-dfun-state generic-function) new-value))) (defun set-dfun (gf &optional dfun cache info) - (when cache - (setf (cache-owner cache) gf)) (let ((new-state (if (and dfun (or cache info)) (list* dfun cache info) dfun))) diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 29af071..196b57a 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -23,826 +23,423 @@ ;;;; warranty about the software, its performance or its conformity to any ;;;; specification. -(in-package "SB-PCL") - -;;; Ye olde CMUCL comment follows, but it seems likely that the paper -;;; that would be inserted would resemble Kiczales and Rodruigez, -;;; Efficient Method Dispatch in PCL, ACM 1990. Some of the details -;;; changed between that paper and "May Day PCL" of 1992; some other -;;; details have changed since, but reading that paper gives the broad -;;; idea. -;;; -;;; 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. - -;;; 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)) - -(defmacro cache-vector-lock-count (cache-vector) - `(cache-vector-ref ,cache-vector 0)) +;;;; 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. -(defun flush-cache-vector-internal (cache-vector) - ;; FIXME: To my eye this PCL-LOCK implies we should be holding the - ;; lock whenever we play with any cache vector, which doesn't seem - ;; to be true. On the other hand that would be too expensive as - ;; well, since it would mean serialization across all GFs. - (with-pcl-lock - (fill (the simple-vector cache-vector) nil) - (setf (cache-vector-lock-count cache-vector) 0)) - cache-vector) - -;;; Return an empty cache vector -(defun get-cache-vector (size) - (declare (type (and unsigned-byte fixnum) size)) - (let ((cv (make-array size :initial-element nil))) - (setf (cache-vector-lock-count cv) 0) - cv)) - -(defmacro modify-cache (cache-vector &body body) - `(with-pcl-lock - ;; This locking scheme is less the sufficient, and not what the - ;; PCL implementors had planned: apparently we should increment - ;; the lock count atomically, and all cache users should check - ;; the count before and after they touch cache: if the counts - ;; match the cache was not altered, if they don't match the - ;; work needs to be redone. - ;; - ;; We probably want to re-engineer things so that the whole - ;; cache vector gets replaced atomically when we do things - ;; to it that could affect others. - (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 - (1+ old-count))))))) - -(eval-when (:compile-toplevel :load-toplevel :execute) - (declaim (ftype (function (fixnum) (values (and unsigned-byte fixnum) &optional)) - power-of-two-ceiling)) - (defun power-of-two-ceiling (x) - ;; (expt 2 (ceiling (log x 2))) - (ash 1 (integer-length (1- x))))) - -;;; FIXME: We should probably keep just one of these -- or at least use just -;;; one. -(declaim (inline compute-line-size)) -(defun compute-line-size (x) - (power-of-two-ceiling x)) - -(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) - (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)) - -;;;; 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 (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))) - -;;;; 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))))) - -;;; 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: + ;; The bitmask used to calculate (mod index (length vector))l + (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)) + +;;; 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)))) + +;;; Don't allocate insanely huge caches. +(defconstant +cache-vector-max-length+ (expt 2 14)) + +;;; 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. ;;; -;;; SUM over the wrapper cache numbers, -;;; ENSURING that the result is a fixnum -;;; MASK the result against the mask argument. +;;; 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 size) 2)) + +;;; 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))) -;;; 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))))) - -(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))) - -;;; 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)))) + (dolist (layout (cdr layouts)) + (mixf index (hash-layout-or layout (return-from compute-cache-index nil)))) + ;; align with cache lines + (logand (* (cache-line-size cache) 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))) + (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 (* ,line-size ,n-index) (cache-mask ,cache-var))) + (let ((,n-depth (cache-depth ,cache-var)) + (,n-pointer ,n-index) + (,n-mask (cache-mask ,cache-var))) + (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.. - (aver wrappers) - (or (fill-cache-p nil 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) - (aver wrappers) - (with-local-cache-functions (cache) - (let* ((location (compute-primary-cache-location (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 - ;; FIXME: Cache modification: should we not be holding a lock? - (setf (cache-vector-ref (c-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 (1- length) + :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 + (setf (cache-vector copy) (make-array length :initial-element '..empty..) + (cache-depth copy) 0 + (cache-mask copy) (1- length) + (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) + (and (find-if (lambda (elt) + (and (typep elt 'layout) + (zerop (layout-clos-hash elt)))) + (cache-vector cache)) + t)) + +(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 -;;; -;;; FIXME: Deceptive name as this has side-effects. -(defun fill-cache-p (forcep cache wrappers value) - (with-local-cache-functions (cache) - (let* ((location (compute-primary-cache-location (mask) wrappers)) - (primary (location-line location))) - (declare (fixnum location primary)) - ;; FIXME: I tried (aver (> location 0)) and (aver (not - ;; (location-reserved-p location))) here, on the basis that - ;; particularly passing a LOCATION of 0 for a cache with more - ;; than one key would cause PRIMARY to be -1. However, the - ;; AVERs triggered during the bootstrap, and removing them - ;; didn't cause anything to break, so I've left them removed. - ;; I'm still confused as to what is right. -- CSR, 2006-04-20 - (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 (c-vector))) - (declare (fixnum loc) (simple-vector cache-vector)) - ;; FIXME: Cache modifications: should we not be holding - ;; a lock? - (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)))))))) - -;;; FIXME: Deceptive name as this has side-effects -(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 (c-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: (values ) -(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 (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))))) - -(defvar *pcl-misc-random-state* (make-random-state)) - -;;; 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. -;;; -;;; -;;; is 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 .

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 *pcl-misc-random-state*))) - ((> 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 (c-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))) +;;; 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)) + (size (/ (length vector) line-size)) + (mask (cache-mask cache)) + (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 (cache-mask cache) + :limit (cache-limit cache)))) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 3b5a599..a8bb544 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -401,7 +401,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (reader 'emit-one-index-readers) (boundp 'emit-one-index-boundps) (writer 'emit-one-index-writers))) - (cache (or cache (get-cache 1 nil #'one-index-limit-fn 4))) + (cache (or cache (make-cache :key-count 1 :value nil :size 4))) (dfun-info (one-index-dfun-info type index cache))) (declare (type cache cache)) (values @@ -412,19 +412,12 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 cache dfun-info))) -(defun make-final-one-index-accessor-dfun (gf type index table) - (let ((cache (fill-dfun-cache table nil 1 #'one-index-limit-fn))) - (make-one-index-accessor-dfun gf type index cache))) - -(defun one-index-limit-fn (nlines) - (default-limit-fn nlines)) - (defun make-n-n-accessor-dfun (gf type &optional cache) (let* ((emit (ecase type (reader 'emit-n-n-readers) (boundp 'emit-n-n-boundps) (writer 'emit-n-n-writers))) - (cache (or cache (get-cache 1 t #'n-n-accessors-limit-fn 2))) + (cache (or cache (make-cache :key-count 1 :value t :size 2))) (dfun-info (n-n-dfun-info type cache))) (declare (type cache cache)) (values @@ -434,13 +427,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 cache dfun-info))) -(defun make-final-n-n-accessor-dfun (gf type table) - (let ((cache (fill-dfun-cache table t 1 #'n-n-accessors-limit-fn))) - (make-n-n-accessor-dfun gf type cache))) - -(defun n-n-accessors-limit-fn (nlines) - (default-limit-fn nlines)) - (defun make-checking-dfun (generic-function function &optional cache) (unless cache (when (use-caching-dfun-p generic-function) @@ -457,7 +443,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 function) nil dfun-info)) - (let* ((cache (or cache (get-cache nkeys nil #'checking-limit-fn 2))) + (let* ((cache (or cache (make-cache :key-count nkeys :value nil :size 2))) (dfun-info (checking-dfun-info function cache))) (values (funcall (get-dfun-constructor 'emit-checking metatypes applyp) @@ -468,8 +454,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 cache dfun-info))))) -(defun make-final-checking-dfun (generic-function function - classes-list new-class) +(defun make-final-checking-dfun (generic-function function classes-list new-class) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq applyp nkeys)) @@ -477,9 +462,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (values (lambda (&rest args) (invoke-emf function args)) nil (default-method-only-dfun-info)) - (let ((cache (make-final-ordinary-dfun-internal - generic-function nil #'checking-limit-fn - classes-list new-class))) + (let ((cache (make-final-ordinary-dfun-cache + generic-function nil classes-list new-class))) (make-checking-dfun generic-function function cache))))) (defun use-default-method-only-dfun-p (generic-function) @@ -500,9 +484,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (if (early-gf-p generic-function) (early-gf-methods generic-function) (generic-function-methods generic-function))))) - -(defun checking-limit-fn (nlines) - (default-limit-fn nlines)) (defun make-caching-dfun (generic-function &optional cache) (unless cache @@ -515,7 +496,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq)) - (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) + (let* ((cache (or cache (make-cache :key-count nkeys :value t :size 2))) (dfun-info (caching-dfun-info cache))) (values (funcall (get-dfun-constructor 'emit-caching metatypes applyp) @@ -526,14 +507,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 dfun-info)))) (defun make-final-caching-dfun (generic-function classes-list new-class) - (let ((cache (make-final-ordinary-dfun-internal - generic-function t #'caching-limit-fn - classes-list new-class))) + (let ((cache (make-final-ordinary-dfun-cache + generic-function t classes-list new-class))) (make-caching-dfun generic-function cache))) -(defun caching-limit-fn (nlines) - (default-limit-fn nlines)) - (defun insure-caching-dfun (gf) (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info gf) @@ -590,8 +567,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (multiple-value-bind (nreq applyp metatypes nkeys) (get-generic-fun-info generic-function) (declare (ignore nreq applyp)) - (let* ((cache (or cache (get-cache nkeys t #'caching-limit-fn 2))) + (let* ((cache (or cache (make-cache :key-count nkeys :value t :size 2))) (dfun-info (constant-value-dfun-info cache))) + (declare (type cache cache)) (values (funcall (get-dfun-constructor 'emit-constant-value metatypes) cache @@ -601,9 +579,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 dfun-info)))) (defun make-final-constant-value-dfun (generic-function classes-list new-class) - (let ((cache (make-final-ordinary-dfun-internal - generic-function :constant-value #'caching-limit-fn - classes-list new-class))) + (let ((cache (make-final-ordinary-dfun-cache + generic-function :constant-value classes-list new-class))) (make-constant-value-dfun generic-function cache))) (defun gf-has-method-with-nonstandard-specializer-p (gf) @@ -702,18 +679,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dolist (gf (gfs-of-type '(dispatch initial-dispatch))) (dfun-update gf #'make-dispatch-dfun))) -(defun fill-dfun-cache (table valuep nkeys limit-fn &optional cache) - (let ((cache (or cache (get-cache nkeys valuep limit-fn - (+ (hash-table-count table) 3))))) - (maphash (lambda (classes value) - (setq cache (fill-cache cache - (class-wrapper classes) - value))) - table) - cache)) - -(defun make-final-ordinary-dfun-internal (generic-function valuep limit-fn - classes-list new-class) +(defun make-final-ordinary-dfun-cache + (generic-function valuep classes-list new-class) (let* ((arg-info (gf-arg-info generic-function)) (nkeys (arg-info-nkeys arg-info)) (new-class (and new-class @@ -724,8 +691,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 new-class)) (cache (if new-class (copy-cache (gf-dfun-cache generic-function)) - (get-cache nkeys (not (null valuep)) limit-fn 4)))) - (make-emf-cache generic-function valuep cache classes-list new-class))) + (make-cache :key-count nkeys :value (not (null valuep)) + :size 4)))) + (make-emf-cache generic-function valuep cache classes-list new-class))) (defvar *dfun-miss-gfs-on-stack* ()) @@ -861,8 +829,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 ((use-caching-dfun-p gf) (dfun-update gf #'make-caching-dfun)) (t - (dfun-update - gf #'make-checking-dfun + (dfun-update gf #'make-checking-dfun ;; nemf is suitable only for caching, have to do this: (cache-miss-values gf args 'checking)))))) @@ -871,6 +838,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (make-final-dfun-internal gf classes-list) (set-dfun gf dfun cache info))) +;;; FIXME: What is this? (defvar *new-class* nil) (defun final-accessor-dfun-type (gf) @@ -922,10 +890,11 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (w1 (class-wrapper second))) (make-two-class-accessor-dfun gf type w0 w1 all-index))) ((or (integerp all-index) (consp all-index)) - (make-final-one-index-accessor-dfun - gf type all-index table)) + (let ((cache (hash-table-to-cache table :value nil :key-count 1))) + (make-one-index-accessor-dfun gf type all-index cache))) (no-class-slots-p - (make-final-n-n-accessor-dfun gf type table)) + (let ((cache (hash-table-to-cache table :value t :key-count 1))) + (make-n-n-accessor-dfun gf type cache))) (t (make-final-caching-dfun gf classes-list new-class))) (make-final-caching-dfun gf classes-list new-class))))) @@ -961,6 +930,7 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (t (make-final-caching-dfun gf classes-list new-class))))) +(defvar *pcl-misc-random-state* (make-random-state)) (defun accessor-miss (gf new object dfun-info) (let* ((ostate (type-of dfun-info)) @@ -1000,7 +970,6 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((ncache (fill-cache cache wrappers nindex))) (unless (eq ncache cache) (funcall update-fn ncache))))) - (cond ((null ntype) (caching)) ((or invalidp @@ -1045,6 +1014,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (dfun-miss (generic-function args wrappers invalidp nemf) (cond (invalidp) ((eq oemf nemf) + ;; The cache of a checking dfun doesn't hold any values, + ;; so this NIL appears to be just a dummy-value we use in + ;; order to insert the wrappers into the cache. (let ((ncache (fill-cache cache wrappers nil))) (unless (eq ncache cache) (dfun-update generic-function #'make-checking-dfun @@ -1070,9 +1042,10 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (typecase emf (constant-fast-method-call (constant-fast-method-call-value emf)) - (constant-method-call (constant-method-call-value emf)) - (t (bug "~S with non-constant EMF ~S" - 'constant-value-miss emf)))) + (constant-method-call + (constant-method-call-value emf)) + (t + (bug "~S with non-constant EMF ~S" 'constant-value-miss emf)))) (ncache (fill-cache ocache wrappers value))) (unless (eq ncache ocache) (dfun-update generic-function @@ -1749,6 +1722,8 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (defun update-dfun (generic-function &optional dfun cache info) (let* ((early-p (early-gf-p generic-function))) + ;; FIXME: How atomic wrt. SET-FUNCALLABLE-INSTANCE-FUN does + ;; this need to be? (set-dfun generic-function dfun cache info) (let ((dfun (if early-p (or dfun (make-initial-dfun generic-function)) diff --git a/src/pcl/dlisp.lisp b/src/pcl/dlisp.lisp index 7ed3463..486541b 100644 --- a/src/pcl/dlisp.lisp +++ b/src/pcl/dlisp.lisp @@ -23,6 +23,7 @@ (in-package "SB-PCL") + ;;;; 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 @@ -246,7 +247,7 @@ (fsc-instance-wrapper ,instance))))) (block access (when (and wrapper - (/= (layout-clos-hash wrapper) 0) + (not (zerop (layout-clos-hash wrapper))) ,@(if (eql 1 1-or-2-class) `((eq wrapper wrapper-0)) `((or (eq wrapper wrapper-0) @@ -383,147 +384,12 @@ (error "Every metatype is T.")) `(prog () (return - (let ((cache-vector (cache-vector ,cache-var)) - (mask (cache-mask ,cache-var)) - (size (cache-size ,cache-var)) - (overflow (cache-overflow ,cache-var)) - ,@wrapper-bindings) - (declare (fixnum size mask)) - ,(emit-cache-lookup wrapper-vars miss-tag value-var) + (let ,wrapper-bindings + ,(emit-cache-lookup cache-var wrapper-vars miss-tag value-var) ,hit-form)) ,miss-tag (return ,miss-form)))) -(defun emit-cache-lookup (wrapper-vars miss-tag value-reg) - (cond ((cdr wrapper-vars) - (emit-greater-than-1-dlap wrapper-vars miss-tag value-reg)) - (value-reg - (emit-1-t-dlap (car wrapper-vars) miss-tag value-reg)) - (t - (emit-1-nil-dlap (car wrapper-vars) miss-tag)))) - -(defun emit-1-nil-dlap (wrapper miss-label) - `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper - miss-label)) - (location primary)) - (declare (fixnum primary location)) - (block search - (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) - (return-from search nil)) - (setq location (the fixnum (+ location 1))) - (when (= location size) - (setq location 0)) - (when (= location primary) - (dolist (entry overflow) - (when (eq (car entry) ,wrapper) - (return-from search nil))) - (go ,miss-label)))))) - -(defmacro get-cache-vector-lock-count (cache-vector) - `(let ((lock-count (cache-vector-lock-count ,cache-vector))) - (unless (typep lock-count 'fixnum) - (error "My cache got freed somehow.")) - (the fixnum lock-count))) - -(defun emit-1-t-dlap (wrapper miss-label value) - `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper - miss-label)) - (initial-lock-count (get-cache-vector-lock-count cache-vector))) - (declare (fixnum primary initial-lock-count)) - (let ((location primary)) - (declare (fixnum location)) - (block search - (loop (when (eq ,wrapper (cache-vector-ref cache-vector location)) - (setq ,value (cache-vector-ref cache-vector (1+ location))) - (return-from search nil)) - (setq location (the fixnum (+ location 2))) - (when (= location size) - (setq location 0)) - (when (= location primary) - (dolist (entry overflow) - (when (eq (car entry) ,wrapper) - (setq ,value (cdr entry)) - (return-from search nil))) - (go ,miss-label)))) - (unless (= initial-lock-count - (get-cache-vector-lock-count cache-vector)) - (go ,miss-label))))) - -(defun emit-greater-than-1-dlap (wrappers miss-label value) - (declare (type list wrappers)) - (let ((cache-line-size (compute-line-size (+ (length wrappers) - (if value 1 0))))) - `(let ((primary 0) - (size-1 (the fixnum (- size 1)))) - (declare (fixnum primary size-1)) - ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label) - (let ((initial-lock-count (get-cache-vector-lock-count cache-vector))) - (declare (fixnum initial-lock-count)) - (let ((location primary) - (next-location 0)) - (declare (fixnum location next-location)) - (block search - (loop (setq next-location - (the fixnum (+ location ,cache-line-size))) - (when (and ,@(mapcar - (lambda (wrapper) - `(eq ,wrapper - (cache-vector-ref - cache-vector - (setq location - (the fixnum (+ location 1)))))) - wrappers)) - ,@(when value - `((setq location (the fixnum (+ location 1))) - (setq ,value (cache-vector-ref cache-vector - location)))) - (return-from search nil)) - (setq location next-location) - (when (= location size-1) - (setq location 0)) - (when (= location primary) - (dolist (entry overflow) - (let ((entry-wrappers (car entry))) - (when (and ,@(mapcar (lambda (wrapper) - `(eq ,wrapper - (pop entry-wrappers))) - wrappers)) - ,@(when value - `((setq ,value (cdr entry)))) - (return-from search nil)))) - (go ,miss-label)))) - (unless (= initial-lock-count - (get-cache-vector-lock-count cache-vector)) - (go ,miss-label))))))) - -(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label) - `(let ((wrapper-cache-no (layout-clos-hash ,wrapper))) - (declare (fixnum wrapper-cache-no)) - (when (zerop wrapper-cache-no) (go ,miss-label)) - ,(let ((form `(logand mask wrapper-cache-no))) - `(the fixnum ,form)))) - -(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label) - (declare (type list wrappers)) - ;; This returns 1 less that the actual location. - `(progn - ,@(let ((adds 0) (len (length wrappers))) - (declare (fixnum adds len)) - (mapcar (lambda (wrapper) - `(let ((wrapper-cache-no (layout-clos-hash ,wrapper))) - (declare (fixnum wrapper-cache-no)) - (when (zerop wrapper-cache-no) (go ,miss-label)) - (setq primary (the fixnum (+ primary wrapper-cache-no))) - ,@(progn - (incf adds) - (when (or (zerop (mod adds - wrapper-cache-number-adds-ok)) - (eql adds len)) - `((setq primary - ,(let ((form `(logand primary mask))) - `(the fixnum ,form)))))))) - wrappers)))) - ;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the ;;; CMU/SBCL approach of using funcallable instances, that branch may ;;; run on non-pcl instances (structures). The result will be the @@ -531,7 +397,7 @@ ;;; "slots" will be whatever the first slot is, but will be ignored. ;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures ;;; as well as PCL fins. -(defun emit-fetch-wrapper (metatype argument miss-label &optional slot) +(defun emit-fetch-wrapper (metatype argument miss-tag &optional slot) (ecase metatype ((standard-instance) `(cond ((std-instance-p ,argument) @@ -541,7 +407,7 @@ ,@(when slot `((setq ,slot (fsc-instance-slots ,argument)))) (fsc-instance-wrapper ,argument)) (t - (go ,miss-label)))) + (go ,miss-tag)))) ;; Sep92 PCL used to distinguish between some of these cases (and ;; spuriously exclude others). Since in SBCL ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all diff --git a/src/pcl/dlisp2.lisp b/src/pcl/dlisp2.lisp deleted file mode 100644 index 538c781..0000000 --- a/src/pcl/dlisp2.lisp +++ /dev/null @@ -1,132 +0,0 @@ -;;;; This software is part of the SBCL system. See the README file for -;;;; more information. - -;;;; This software is derived from software originally released by Xerox -;;;; Corporation. Copyright and release statements follow. Later modifications -;;;; to the software are in the public domain and are provided with -;;;; absolutely no warranty. See the COPYING and CREDITS files for more -;;;; information. - -;;;; copyright information from original PCL sources: -;;;; -;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. -;;;; All rights reserved. -;;;; -;;;; Use and copying of this software and preparation of derivative works based -;;;; upon this software are permitted. Any distribution of this software or -;;;; derivative works must comply with all applicable United States export -;;;; control laws. -;;;; -;;;; This software is made available AS IS, and Xerox Corporation makes no -;;;; warranty about the software, its performance or its conformity to any -;;;; specification. - -(in-package "SB-PCL") - -;;;; The whole of this file is dead code as long as *optimize-cache-functions-p* -;;;; is true, which it currently _always_ is. - - -(defun emit-reader/writer-function (reader/writer 1-or-2-class class-slot-p) - (values - (ecase reader/writer - (:reader (ecase 1-or-2-class - (1 (if class-slot-p - (emit-reader/writer-macro :reader 1 t) - (emit-reader/writer-macro :reader 1 nil))) - (2 (if class-slot-p - (emit-reader/writer-macro :reader 2 t) - (emit-reader/writer-macro :reader 2 nil))))) - (:writer (ecase 1-or-2-class - (1 (if class-slot-p - (emit-reader/writer-macro :writer 1 t) - (emit-reader/writer-macro :writer 1 nil))) - (2 (if class-slot-p - (emit-reader/writer-macro :writer 2 t) - (emit-reader/writer-macro :writer 2 nil))))) - (:boundp (ecase 1-or-2-class - (1 (if class-slot-p - (emit-reader/writer-macro :boundp 1 t) - (emit-reader/writer-macro :boundp 1 nil))) - (2 (if class-slot-p - (emit-reader/writer-macro :boundp 2 t) - (emit-reader/writer-macro :boundp 2 nil)))))) - nil)) - -(defun emit-one-or-n-index-reader/writer-function - (reader/writer cached-index-p class-slot-p) - (values - (ecase reader/writer - (:reader (if cached-index-p - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :reader t t) - (emit-one-or-n-index-reader/writer-macro :reader t nil)) - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :reader nil t) - (emit-one-or-n-index-reader/writer-macro :reader nil nil)))) - (:writer (if cached-index-p - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :writer t t) - (emit-one-or-n-index-reader/writer-macro :writer t nil)) - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :writer nil t) - (emit-one-or-n-index-reader/writer-macro :writer nil nil)))) - (:boundp (if cached-index-p - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :boundp t t) - (emit-one-or-n-index-reader/writer-macro :boundp t nil)) - (if class-slot-p - (emit-one-or-n-index-reader/writer-macro :boundp nil t) - (emit-one-or-n-index-reader/writer-macro :boundp nil nil))))) - nil)) - -(defun emit-checking-or-caching-function (cached-emf-p return-value-p metatypes applyp) - (values (emit-checking-or-caching-function-preliminary - cached-emf-p return-value-p metatypes applyp) - t)) - -(defvar *not-in-cache* (make-symbol "not in cache")) - -(defun emit-checking-or-caching-function-preliminary - (cached-emf-p return-value-p metatypes applyp) - (declare (ignore applyp)) - (if cached-emf-p - (lambda (cache miss-fn) - (declare (type function miss-fn)) - #'(lambda (&rest args) - (declare #.*optimize-speed*) - (with-dfun-wrappers (args metatypes) - (dfun-wrappers invalid-wrapper-p) - (apply miss-fn args) - (if invalid-wrapper-p - (apply miss-fn args) - (let ((emf (probe-cache cache dfun-wrappers *not-in-cache*))) - (if (eq emf *not-in-cache*) - (apply miss-fn args) - (if return-value-p - emf - (invoke-emf emf args)))))))) - (lambda (cache emf miss-fn) - (declare (type function miss-fn)) - #'(lambda (&rest args) - (declare #.*optimize-speed*) - (with-dfun-wrappers (args metatypes) - (dfun-wrappers invalid-wrapper-p) - (apply miss-fn args) - (if invalid-wrapper-p - (apply miss-fn args) - (let ((found-p (not (eq *not-in-cache* - (probe-cache cache dfun-wrappers - *not-in-cache*))))) - (if found-p - (invoke-emf emf args) - (if return-value-p - t - (apply miss-fn args)))))))))) - -(defun emit-default-only-function (metatypes applyp) - (declare (ignore metatypes applyp)) - (values (lambda (emf) - (lambda (&rest args) - (invoke-emf emf args))) - t)) diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp index eeb37f9..d8ce44c 100644 --- a/src/pcl/methods.lisp +++ b/src/pcl/methods.lisp @@ -965,14 +965,12 @@ (nkeys (arg-info-nkeys arg-info)) (metatypes (arg-info-metatypes arg-info)) (wrappers (unless (eq nkeys 1) (make-list nkeys))) - (precompute-p (gf-precompute-dfun-and-emf-p arg-info)) - (default '(default))) + (precompute-p (gf-precompute-dfun-and-emf-p arg-info))) (flet ((add-class-list (classes) (when (or (null new-class) (memq new-class classes)) (let ((%wrappers (get-wrappers-from-classes nkeys wrappers classes metatypes))) - (when (and %wrappers - (eq default (probe-cache cache %wrappers default))) + (when (and %wrappers (not (probe-cache cache %wrappers))) (let ((value (cond ((eq valuep t) (sdfun-for-caching generic-function classes)) @@ -1541,6 +1539,10 @@ ((gf-precompute-dfun-and-emf-p arg-info) (multiple-value-bind (dfun cache info) (make-final-dfun-internal gf) + ;; FIXME: What does the next comment mean? Presumably it + ;; refers to the age-old implementation where cache vectors + ;; where cached resources? Also, the first thing UPDATE-DFUN + ;; does it SET-DFUN, so do we really need it here? (set-dfun gf dfun cache info) ; lest the cache be freed twice (update-dfun gf dfun cache info)))))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 6b09912..8721509 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -856,7 +856,7 @@ (setf slots eslotds (wrapper-instance-slots-layout nwrapper) nlayout (wrapper-class-slots nwrapper) nwrapper-class-slots - (wrapper-no-of-instance-slots nwrapper) nslots + (layout-length nwrapper) nslots wrapper nwrapper) (do* ((slots (slot-value class 'slots) (cdr slots)) (dupes nil)) @@ -1230,7 +1230,7 @@ ;; good style. There has to be a better way! -- CSR, ;; 2002-10-29 (eq (layout-invalid owrapper) t)) - (let ((nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) + (let ((nwrapper (make-wrapper (layout-length owrapper) class))) (setf (wrapper-instance-slots-layout nwrapper) (wrapper-instance-slots-layout owrapper)) @@ -1257,7 +1257,7 @@ ;;; through the UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism. (defmethod make-instances-obsolete ((class std-class)) (let* ((owrapper (class-wrapper class)) - (nwrapper (make-wrapper (wrapper-no-of-instance-slots owrapper) + (nwrapper (make-wrapper (layout-length owrapper) class))) (unless (class-finalized-p class) (if (class-has-a-forward-referenced-superclass-p class) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index cc5ef22..5870bfe 100644 --- 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))))) -(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)) diff --git a/version.lisp-expr b/version.lisp-expr index c0fe41d..1b48e09 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.6.2" +"1.0.6.3" -- 1.7.10.4