X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=c559b6199347b0ab7fe31e2fbbeeacdf8bc7aa83;hb=c548f73e8dd676d6ec4576eba6ab661a5061bdfe;hp=62fccf5330adcdc963f7b31a6dbc441b24f2538d;hpb=8b313a75eb6bcc7b1c8eda798c8350b49f94861c;p=sbcl.git diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 62fccf5..c559b61 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -23,1347 +23,502 @@ ;;;; warranty about the software, its performance or its conformity to any ;;;; specification. -(in-package "SB-PCL") - -;;; 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)) - -(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) - (sb-sys:without-interrupts - (fill (the simple-vector cache-vector) nil) - (setf (cache-vector-lock-count cache-vector) 0)) - cache-vector) - -(defmacro modify-cache (cache-vector &body body) - `(sb-sys:without-interrupts - (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 #.sb-kernel:layout-clos-hash-length)) - -(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) - -(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) - (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))) - -;;; some facilities for allocation and freeing caches as they are needed - -;;; This is done on the assumption that a better port of PCL will -;;; arrange to cons these all in the same static area. Given that, the -;;; fact that PCL tries to reuse them should be a win. - -(defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql)) - -;;; 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) - (let ((entry (gethash size *free-cache-vectors*))) - (sb-sys:without-interrupts - (cond ((null entry) - (setf (gethash size *free-cache-vectors*) (cons 0 nil)) - (get-cache-vector size)) - ((null (cdr entry)) - (incf (car entry)) - (flush-cache-vector-internal (allocate-cache-vector size))) - (t - (let ((cache (cdr entry))) - (setf (cdr entry) (cache-vector-ref cache 0)) - (flush-cache-vector-internal cache))))))) - -(defun free-cache-vector (cache-vector) - (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*))) - (sb-sys:without-interrupts - (if (null entry) - (error - "attempt to free a cache-vector not allocated by GET-CACHE-VECTOR") - (let ((thread (cdr entry))) - (loop (unless thread (return)) - (when (eq thread cache-vector) - (error "freeing a cache twice")) - (setq thread (cache-vector-ref thread 0))) - (flush-cache-vector-internal cache-vector) ; to help the GC - (setf (cache-vector-ref cache-vector 0) (cdr entry)) - (setf (cdr entry) cache-vector) - nil))))) - -;;; This is just for debugging and analysis. It shows the state of the -;;; free cache resource. -#+sb-show -(defun show-free-cache-vectors () - (let ((elements ())) - (maphash (lambda (s e) (push (list s e) elements)) *free-cache-vectors*) - (setq elements (sort elements #'< :key #'car)) - (dolist (e elements) - (let* ((size (car e)) - (entry (cadr e)) - (allocated (car entry)) - (head (cdr entry)) - (free 0)) - (loop (when (null head) (return t)) - (setq head (cache-vector-ref head 0)) - (incf free)) - (format t - "~&There are ~4D caches of size ~4D. (~D free ~3D%)" - allocated - size - free - (floor (* 100 (/ free (float allocated))))))))) - -;;;; 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 sb-kernel:layout-clos-hash-max)) -(defconstant wrapper-cache-number-mask sb-kernel:layout-clos-hash-max) -(defconstant wrapper-cache-number-adds-ok - (truncate most-positive-fixnum sb-kernel:layout-clos-hash-max)) - -;;;; 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 - sb-kernel:layout-clos-hash-length) - -(unless (boundp '*the-class-t*) - (setq *the-class-t* nil)) - -(defmacro wrapper-class (wrapper) - `(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper))) -(defmacro wrapper-no-of-instance-slots (wrapper) - `(sb-kernel:layout-length ,wrapper)) - -;;; WRAPPER-STATE returns T (not generalized boolean, but T exactly) -;;; iff the wrapper is valid. Any other return value denotes some -;;; invalid state. Special conventions have been set up for certain -;;; invalid states, e.g. obsoleteness or flushedness, but I (WHN -;;; 19991204) haven't been motivated to reverse engineer them from the -;;; code and document them here. -;;; -;;; FIXME: This is awkward and unmnemonic. There is a function -;;; (INVALID-WRAPPER-P) to test this return result abstractly for -;;; invalidness but it's not called consistently; the functions that -;;; need to know whether a wrapper is invalid often test (EQ -;;; (WRAPPER-STATE X) T), ick. It would be good to use the abstract -;;; test instead. It would probably be even better to switch the sense -;;; of the WRAPPER-STATE function, renaming it to WRAPPER-INVALID and -;;; making it synonymous with LAYOUT-INVALID. Then the -;;; INVALID-WRAPPER-P function would become trivial and would go away -;;; (replaced with WRAPPER-INVALID), since all the various invalid -;;; wrapper states would become generalized boolean "true" values. -- -;;; WHN 19991204 -#-sb-fluid (declaim (inline wrapper-state (setf wrapper-state))) -(defun wrapper-state (wrapper) - (let ((invalid (sb-kernel:layout-invalid wrapper))) - (cond ((null invalid) - t) - ((atom invalid) - ;; some non-PCL object. INVALID is probably :INVALID. We - ;; should arguably compute the new wrapper here instead of - ;; returning NIL, but we don't bother, since - ;; OBSOLETE-INSTANCE-TRAP can't use it. - '(:obsolete nil)) - (t - invalid)))) -(defun (setf wrapper-state) (new-value wrapper) - (setf (sb-kernel:layout-invalid wrapper) - (if (eq new-value t) - nil - new-value))) - -(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 (cl:find-class name nil))) - (cond - (found - (unless (sb-kernel:class-pcl-class found) - (setf (sb-kernel:class-pcl-class found) class)) - (aver (eq (sb-kernel:class-pcl-class found) class)) - (let ((layout (sb-kernel:class-layout found))) - (aver layout) - layout)) - (t - (make-wrapper-internal - :length length - :class (sb-kernel:make-standard-class :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 PCL::CLASS objects. -(defun make-wrapper (length class) - (cond - ((typep class 'std-class) - (make-wrapper-internal - :length length - :class - (let ((owrap (class-wrapper class))) - (cond (owrap - (sb-kernel:layout-class owrap)) - ((*subtypep (class-of class) - *the-class-standard-class*) - (cond ((and *pcl-class-boot* - (eq (slot-value class 'name) *pcl-class-boot*)) - (let ((found (cl:find-class (slot-value class 'name)))) - (unless (sb-kernel:class-pcl-class found) - (setf (sb-kernel:class-pcl-class found) class)) - (aver (eq (sb-kernel:class-pcl-class found) class)) - found)) - (t - (sb-kernel:make-standard-class :pcl-class class)))) - (t - (sb-kernel:make-random-pcl-class :pcl-class class)))))) - (t - (let* ((found (cl:find-class (slot-value class 'name))) - (layout (sb-kernel:class-layout found))) - (unless (sb-kernel:class-pcl-class found) - (setf (sb-kernel:class-pcl-class found) class)) - (aver (eq (sb-kernel:class-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) - `(sb-kernel:layout-clos-hash ,wrapper ,n)) - -(declaim (inline wrapper-class*)) -(defun wrapper-class* (wrapper) - (or (wrapper-class wrapper) - (find-structure-class - (cl:class-name (sb-kernel:layout-class 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) - (neq (wrapper-state wrapper) t)) - -(defvar *previous-nwrappers* (make-hash-table)) - -(defun invalidate-wrapper (owrapper state nwrapper) - (ecase state - ((:flush :obsolete) - (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 sb-kernel:layout-clos-hash-length) - (setf (cache-number-vector-ref ocnv i) 0))) - (push (setf (wrapper-state 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 (wrapper-state owrapper))) - (if (eq state t) - owrapper - (let ((nwrapper - (ecase (car state) - (:flush - (flush-cache-trap owrapper (cadr state) instance)) - (:obsolete - (obsolete-instance-trap owrapper (cadr state) instance))))) - ;; This little bit of error checking is superfluous. It only - ;; checks to see whether the person who implemented the trap - ;; handling screwed up. Since that person is hacking - ;; internal PCL code, and is not a user, this should be - ;; needless. Also, since this directly slows down instance - ;; update and generic function cache refilling, feel free to - ;; take it out sometime soon. - ;; - ;; FIXME: We probably need to add a #+SB-PARANOID feature to - ;; make stuff like this optional. Until then, it stays in. - (cond ((neq nwrapper (wrapper-of instance)) - (error "wrapper returned from trap not wrapper of instance")) - ((invalid-wrapper-p nwrapper) - (error "wrapper returned from trap invalid"))) - nwrapper)))) - -(defmacro check-wrapper-validity1 (object) - (let ((owrapper (gensym))) - `(let ((,owrapper (sb-kernel:layout-of object))) - (if (sb-kernel:layout-invalid ,owrapper) - (check-wrapper-validity ,object) - ,owrapper)))) - -(defvar *free-caches* nil) - -(defun get-cache (nkeys valuep limit-fn nlines) - (let ((cache (or (sb-sys:without-interrupts (pop *free-caches*)) - (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 (or (sb-sys:without-interrupts (pop *free-caches*)) - (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)) +;;;; 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 free-cache (cache) - (free-cache-vector (cache-vector cache)) - (setf (cache-vector cache) #()) - (setf (cache-owner cache) nil) - (push cache *free-caches*) - nil) - -(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)))))) - -;;; 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. -;;; -;;; 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)))))) - -;;; 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)) - (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 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 ===> - ;; 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)))) - -;;;; 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.)) - -(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 six 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 four 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-dfun-call (metatypes applyp fn-variable) - (let ((required - (let ((required nil)) - (dotimes (i (length metatypes)) - (push (dfun-arg-symbol i) required)) - (nreverse required)))) - (if applyp - `(function-apply ,fn-variable ,@required .dfun-rest-arg.) - `(function-funcall ,fn-variable ,@required)))) - -(defun make-dfun-arg-list (metatypes applyp) - (let ((required (let ((reversed-required nil)) - (dotimes (i (length metatypes)) - (push (dfun-arg-symbol i) reversed-required)) - (nreverse reversed-required)))) - (if applyp - `(list* ,@required .dfun-rest-arg.) - `(list ,@required)))) +(in-package "SB-PCL") -(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))) - -;;;; a comment from some PCL implementor: -;;;; Its too bad Common Lisp compilers freak out when you have a -;;;; DEFUN with a lot of LABELS in it. If I could do that I could -;;;; make this code much easier to read and work with. -;;;; Ahh Scheme... -;;;; In the absence of that, the following little macro makes the -;;;; code that follows a little bit more reasonable. I would like to -;;;; add that having to practically write my own compiler in order to -;;;; get just this simple thing is something of a drag. +;;;; 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. ;;;; -;;;; KLUDGE: Maybe we could actually implement this as LABELS now, -;;;; since AFAIK CMU CL doesn't freak out when you have a DEFUN with a -;;;; lot of LABELS in it (and if it does we can fix it instead of -;;;; working around it). -- WHN 19991204 +;;;; The cache vector uses the symbol SB-PCL::..EMPTY.. as a sentinel +;;;; value, to allow storing NILs in the vector as well. + +(defstruct (cache (:constructor %make-cache) + (:copier %copy-cache)) + ;; Number of keys the cache uses. + (key-count 1 :type (integer 1 (#.call-arguments-limit))) + ;; True if we store values in the cache. + (value) + ;; Number of vector elements a single cache line uses in the vector. + ;; This is always a power of two, so that the vector length can be both + ;; an exact multiple of this and a power of two. + (line-size 1 :type (integer 1 #.most-positive-fixnum)) + ;; Cache vector, its length is always both a multiple of line-size + ;; and a power of two. This is so that we can calculate + ;; (mod index (length vector)) + ;; using a bitmask. + (vector #() :type simple-vector) + ;; The bitmask used to calculate (mod (* line-size line-hash) (length vector))). + (mask 0 :type fixnum) + ;; Current probe-depth needed in the cache. + (depth 0 :type index) + ;; Maximum allowed probe-depth before the cache needs to expand. + (limit 0 :type index)) + +(defun compute-cache-mask (vector-length line-size) + ;; Since both vector-length and line-size are powers of two, we + ;; can compute a bitmask such that + ;; + ;; (logand ) + ;; + ;; is "morally equal" to + ;; + ;; (mod (* ) ) + ;; + ;; 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. +;;; +;;; 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))) (eval-when (:compile-toplevel :load-toplevel :execute) - -(defvar *cache* nil) - -;;; FIXME: should be undefined after bootstrapping -(defparameter *local-cache-functions* - '((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-fixnum (i (nkeys) list) - (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-fixnum (i (nkeys) t) - (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-fixnum (i (nkeys) wrappers-mismatch-p) - (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))))) - -(defmacro with-local-cache-functions ((cache) &body body) - `(let ((.cache. ,cache)) - (declare (type cache .cache.)) - (macrolet ,(mapcar (lambda (fn) - `(,(car fn) ,(cadr fn) - `(let (,,@(mapcar (lambda (var) - ``(,',var ,,var)) - (cadr fn))) - ,@',(cddr fn)))) - *local-cache-functions*) - ,@body))) - -) ; EVAL-WHEN - -;;; 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. -;;; -;;; FILL-CACHE returns 1 value: a new cache -;;; -;;; 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 &optional free-cache-p) - - ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check.. - (unless wrappers - (error "fill-cache: WRAPPERS arg is NIL!")) - - (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 free-cache-p)) - (expand-cache cache wrappers value free-cache-p))) - -(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)))))) + (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.) +;;; +;;; 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. +;;; +;;; 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 ) -;;; -;;; 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 free-old-cache-p) - (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) (free-cache ncache) 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)) - (progn (when free-old-cache-p (free-cache cache)) - (return (maybe-check-cache ncache))) - (flush-cache-vector-internal (cache-vector ncache)))))))) - -;;; returns: (values ) -(defun expand-cache (cache wrappers value free-old-cache-p) - ;;(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 t) - (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)) - (when free-old-cache-p (free-cache cache)) - (maybe-check-cache ncache))))) - -;;; 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))) - ((> 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 - -;;; Pre-allocate generic function caches. The hope is that this will -;;; put them nicely together in memory, and that that may be a win. Of -;;; course the first GC copy will probably blow that out, this really -;;; wants to be wrapped in something that declares the area static. -;;; -;;; This preallocation only creates about 25% more caches than PCL -;;; itself uses. Some ports may want to preallocate some more of -;;; these. -;;; -;;; KLUDGE: Isn't something very similar going on in precom1.lisp? Do -;;; we need it both here and there? Why? -- WHN 19991203 -(eval-when (:load-toplevel) - (dolist (n-size '((1 513) (3 257) (3 129) (14 128) (6 65) - (2 64) (7 33) (16 32) (16 17) (32 16) - (64 9) (64 8) (6 5) (128 4) (35 2))) - (let ((n (car n-size)) - (size (cadr n-size))) - (mapcar #'free-cache-vector - (mapcar #'get-cache-vector - (make-list n :initial-element size)))))) +;;; 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)))