X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=12281d51f0d794ad7afbdbfb03cb19f9249638cf;hb=2d3cb6dba6461e98744eca2a1df4f770cea468ca;hp=7fa0dd51d2b84551a53316a16033fb8c1a794663;hpb=e8b69b1dd5564a4237b1bdc1060820c3b820cde2;p=sbcl.git diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 7fa0dd5..12281d5 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -189,7 +189,7 @@ #+sb-show (defun show-free-cache-vectors () (let ((elements ())) - (maphash #'(lambda (s e) (push (list s e) elements)) *free-cache-vectors*) + (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)) @@ -257,48 +257,10 @@ (setq *the-class-t* nil)) (defmacro wrapper-class (wrapper) - `(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper))) + `(sb-kernel:classoid-pcl-class (sb-kernel:layout-classoid ,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) @@ -309,19 +271,20 @@ ;;; 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))) + (let ((found (sb-kernel:find-classoid 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))) + (unless (sb-kernel:classoid-pcl-class found) + (setf (sb-kernel:classoid-pcl-class found) class)) + (aver (eq (sb-kernel:classoid-pcl-class found) class)) + (let ((layout (sb-kernel:classoid-layout found))) (aver layout) layout)) (t (make-wrapper-internal :length length - :class (sb-kernel:make-standard-class :name name :pcl-class class)))))) + :classoid (sb-kernel:make-standard-classoid + :name name :pcl-class class)))))) ;;; The following variable may be set to a STANDARD-CLASS that has ;;; already been created by the lisp code and which is to be redefined @@ -332,61 +295,70 @@ ;;; 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. +;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects. (defun make-wrapper (length class) (cond ((typep class 'std-class) (make-wrapper-internal :length length - :class + :classoid (let ((owrap (class-wrapper class))) (cond (owrap - (sb-kernel:layout-class owrap)) + (sb-kernel:layout-classoid 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)) + (let ((found (sb-kernel:find-classoid + (slot-value class 'name)))) + (unless (sb-kernel:classoid-pcl-class found) + (setf (sb-kernel:classoid-pcl-class found) class)) + (aver (eq (sb-kernel:classoid-pcl-class found) class)) found)) (t - (sb-kernel:make-standard-class :pcl-class class)))) + (sb-kernel:make-standard-classoid :pcl-class class)))) (t - (sb-kernel:make-random-pcl-class :pcl-class class)))))) + (sb-kernel:make-random-pcl-classoid :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)) + (let* ((found (sb-kernel:find-classoid (slot-value class 'name))) + (layout (sb-kernel:classoid-layout found))) + (unless (sb-kernel:classoid-pcl-class found) + (setf (sb-kernel:classoid-pcl-class found) class)) + (aver (eq (sb-kernel:classoid-pcl-class found) class)) (aver layout) layout)))) -;;; FIXME: The immediately following macros could become inline functions. - -(defmacro first-wrapper-cache-number-index () - 0) +(defconstant +first-wrapper-cache-number-index+ 0) -(defmacro next-wrapper-cache-number-index (field-number) - `(and (< ,field-number #.(1- wrapper-cache-number-vector-length)) - (1+ ,field-number))) +(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)) -(defmacro class-no-of-instance-slots (class) - `(wrapper-no-of-instance-slots (class-wrapper ,class))) - -(defmacro wrapper-class* (wrapper) - `(let ((wrapper ,wrapper)) - (or (wrapper-class wrapper) - (find-structure-class - (cl:class-name (sb-kernel:layout-class wrapper)))))) +(declaim (inline wrapper-class*)) +(defun wrapper-class* (wrapper) + (or (wrapper-class wrapper) + (find-structure-class + (sb-kernel:classoid-name (sb-kernel:layout-classoid wrapper))))) ;;; The wrapper cache machinery provides general mechanism for ;;; trapping on the next access to any instance of a given class. This @@ -401,72 +373,54 @@ ;;; SLOT-VALUE-USING-CLASS check the wrapper validity as well. This is ;;; done by calling CHECK-WRAPPER-VALIDITY. -;;; FIXME: could become inline function -(defmacro invalid-wrapper-p (wrapper) - `(neq (wrapper-state ,wrapper) t)) +(declaim (inline invalid-wrapper-p)) +(defun invalid-wrapper-p (wrapper) + (not (null (sb-kernel:layout-invalid wrapper)))) (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))))) + (aver (member state '(:flush :obsolete) :test #'eq)) + (let ((new-previous ())) + ;; First off, a previous call to INVALIDATE-WRAPPER may have + ;; recorded OWRAPPER as an NWRAPPER to update to. Since OWRAPPER + ;; is about to be invalid, it no longer makes sense to update to + ;; it. + ;; + ;; We go back and change the previously invalidated wrappers so + ;; that they will now update directly to NWRAPPER. This + ;; corresponds to a kind of transitivity of wrapper updates. + (dolist (previous (gethash owrapper *previous-nwrappers*)) + (when (eq state :obsolete) + (setf (car previous) :obsolete)) + (setf (cadr previous) nwrapper) + (push previous new-previous)) + + (let ((ocnv (wrapper-cache-number-vector owrapper))) + (dotimes (i sb-kernel:layout-clos-hash-length) + (setf (cache-number-vector-ref ocnv i) 0))) + + (push (setf (sb-kernel:layout-invalid owrapper) (list state nwrapper)) + new-previous) + + (setf (gethash owrapper *previous-nwrappers*) () + (gethash nwrapper *previous-nwrappers*) new-previous))) (defun check-wrapper-validity (instance) (let* ((owrapper (wrapper-of instance)) - (state (wrapper-state owrapper))) - (if (eq state t) + (state (sb-kernel:layout-invalid owrapper))) + (if (null state) 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)))) + (ecase (car state) + (:flush + (flush-cache-trap owrapper (cadr state) instance)) + (:obsolete + (obsolete-instance-trap owrapper (cadr state) instance)))))) + +(declaim (inline check-obsolete-instance)) +(defun check-obsolete-instance (instance) + (when (invalid-wrapper-p (sb-kernel:layout-of instance)) + (check-wrapper-validity instance))) (defvar *free-caches* nil) @@ -479,7 +433,7 @@ (setf (cache-nkeys cache) nkeys (cache-valuep cache) valuep (cache-nlines cache) nlines - (cache-field cache) (first-wrapper-cache-number-index) + (cache-field cache) +first-wrapper-cache-number-index+ (cache-limit-fn cache) limit-fn (cache-mask cache) cache-mask (cache-size cache) actual-size @@ -493,7 +447,7 @@ cache))) (defun get-cache-from-cache (old-cache new-nlines - &optional (new-field (first-wrapper-cache-number-index))) + &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*)) @@ -735,8 +689,8 @@ (let* (,@(when wrappers `((,wrappers (nreverse wrappers-rev)) (,classes (nreverse classes-rev)) - (,types (mapcar #'(lambda (class) - `(class-eq ,class)) + (,types (mapcar (lambda (class) + `(class-eq ,class)) ,classes))))) ,@body)))) @@ -762,7 +716,7 @@ ;; (dotimes (i (length metatypes)) ;; (push (dfun-arg-symbol i) lambda-list)) ;; -;; used in the following six functions into common code that we can +;; used in the following four functions into common code that we can ;; declare inline or something. --njf 2001-12-20 (defun make-dfun-lambda-list (metatypes applyp) (let ((lambda-list nil)) @@ -789,7 +743,7 @@ (push '&rest lambda-list)) (nreverse lambda-list))) -;; FIXME: The next four functions suffer from having a `.DFUN-REST-ARG.' +;; FIXME: The next two functions suffer from having a `.DFUN-REST-ARG.' ;; in their lambda lists, but no corresponding `&REST' symbol. We assume ;; this should be the case by analogy with the previous two functions. ;; It works, and I don't know why. Check the calling functions and @@ -805,229 +759,217 @@ '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 ((required nil)) - (dotimes (i (length metatypes)) - (push (dfun-arg-symbol i) required)) - (nreverse required)))) - (if applyp - `(list* ,@required .dfun-rest-arg.) - `(list ,@required)))) - (defun make-fast-method-call-lambda-list (metatypes applyp) - (let ((lambda-list nil)) - (push '.pv-cell. lambda-list) - (push '.next-method-call. lambda-list) + (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) lambda-list)) + (push (dfun-arg-symbol i) reversed-lambda-list)) (when applyp - (push '.dfun-rest-arg. lambda-list)) - (nreverse lambda-list))) - + (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. -;;;; -;;;; 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 - -(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*) + (labels ((cache () .cache.) + (nkeys () (cache-nkeys .cache.)) + (line-size () (cache-line-size .cache.)) + (vector () (cache-vector .cache.)) + (valuep () (cache-valuep .cache.)) + (nlines () (cache-nlines .cache.)) + (max-location () (cache-max-location .cache.)) + (limit-fn () (cache-limit-fn .cache.)) + (size () (cache-size .cache.)) + (mask () (cache-mask .cache.)) + (field () (cache-field .cache.)) + (overflow () (cache-overflow .cache.)) + ;; + ;; Return T IFF this cache location is reserved. The + ;; only time this is true is for line number 0 of an + ;; nkeys=1 cache. + ;; + (line-reserved-p (line) + (declare (fixnum line)) + (and (= (nkeys) 1) + (= line 0))) + ;; + (location-reserved-p (location) + (declare (fixnum location)) + (and (= (nkeys) 1) + (= location 0))) + ;; + ;; Given a line number, return the cache location. + ;; This is the value that is the second argument to + ;; cache-vector-ref. Basically, this deals with the + ;; offset of nkeys>1 caches and multiplies by line + ;; size. + ;; + (line-location (line) + (declare (fixnum line)) + (when (line-reserved-p line) + (error "line is reserved")) + (if (= (nkeys) 1) + (the fixnum (* line (line-size))) + (the fixnum (1+ (the fixnum (* line (line-size))))))) + ;; + ;; Given a cache location, return the line. This is + ;; the inverse of LINE-LOCATION. + ;; + (location-line (location) + (declare (fixnum location)) + (if (= (nkeys) 1) + (floor location (line-size)) + (floor (the fixnum (1- location)) (line-size)))) + ;; + ;; Given a line number, return the wrappers stored at + ;; that line. As usual, if nkeys=1, this returns a + ;; single value. Only when nkeys>1 does it return a + ;; list. An error is signalled if the line is + ;; reserved. + ;; + (line-wrappers (line) + (declare (fixnum line)) + (when (line-reserved-p line) (error "Line is reserved.")) + (location-wrappers (line-location line))) + ;; + (location-wrappers (location) ; avoid multiplies caused by line-location + (declare (fixnum location)) + (if (= (nkeys) 1) + (cache-vector-ref (vector) location) + (let ((list (make-list (nkeys))) + (vector (vector))) + (declare (simple-vector vector)) + (dotimes (i (nkeys) list) + (declare (fixnum i)) + (setf (nth i list) + (cache-vector-ref vector (+ location i))))))) + ;; + ;; Given a line number, return true IFF the line's + ;; wrappers are the same as wrappers. + ;; + (line-matches-wrappers-p (line wrappers) + (declare (fixnum line)) + (and (not (line-reserved-p line)) + (location-matches-wrappers-p (line-location line) + wrappers))) + ;; + (location-matches-wrappers-p (loc wrappers) ; must not be reserved + (declare (fixnum loc)) + (let ((cache-vector (vector))) + (declare (simple-vector cache-vector)) + (if (= (nkeys) 1) + (eq wrappers (cache-vector-ref cache-vector loc)) + (dotimes (i (nkeys) t) + (declare (fixnum i)) + (unless (eq (pop wrappers) + (cache-vector-ref cache-vector (+ loc i))) + (return nil)))))) + ;; + ;; Given a line number, return the value stored at that line. + ;; If valuep is NIL, this returns NIL. As with line-wrappers, + ;; an error is signalled if the line is reserved. + ;; + (line-value (line) + (declare (fixnum line)) + (when (line-reserved-p line) (error "Line is reserved.")) + (location-value (line-location line))) + ;; + (location-value (loc) + (declare (fixnum loc)) + (and (valuep) + (cache-vector-ref (vector) (+ loc (nkeys))))) + ;; + ;; Given a line number, return true IFF that line has data in + ;; it. The state of the wrappers stored in the line is not + ;; checked. An error is signalled if line is reserved. + (line-full-p (line) + (when (line-reserved-p line) (error "Line is reserved.")) + (not (null (cache-vector-ref (vector) (line-location line))))) + ;; + ;; Given a line number, return true IFF the line is full and + ;; there are no invalid wrappers in the line, and the line's + ;; wrappers are different from wrappers. + ;; An error is signalled if the line is reserved. + ;; + (line-valid-p (line wrappers) + (declare (fixnum line)) + (when (line-reserved-p line) (error "Line is reserved.")) + (location-valid-p (line-location line) wrappers)) + ;; + (location-valid-p (loc wrappers) + (declare (fixnum loc)) + (let ((cache-vector (vector)) + (wrappers-mismatch-p (null wrappers))) + (declare (simple-vector cache-vector)) + (dotimes (i (nkeys) wrappers-mismatch-p) + (declare (fixnum i)) + (let ((wrapper (cache-vector-ref cache-vector (+ loc i)))) + (when (or (null wrapper) + (invalid-wrapper-p wrapper)) + (return nil)) + (unless (and wrappers + (eq wrapper + (if (consp wrappers) + (pop wrappers) + wrappers))) + (setq wrappers-mismatch-p t)))))) + ;; + ;; How many unreserved lines separate line-1 and line-2. + ;; + (line-separation (line-1 line-2) + (declare (fixnum line-1 line-2)) + (let ((diff (the fixnum (- line-2 line-1)))) + (declare (fixnum diff)) + (when (minusp diff) + (setq diff (+ diff (nlines))) + (when (line-reserved-p 0) + (setq diff (1- diff)))) + diff)) + ;; + ;; Given a cache line, get the next cache line. This will not + ;; return a reserved line. + ;; + (next-line (line) + (declare (fixnum line)) + (if (= line (the fixnum (1- (nlines)))) + (if (line-reserved-p 0) 1 0) + (the fixnum (1+ line)))) + ;; + (next-location (loc) + (declare (fixnum loc)) + (if (= loc (max-location)) + (if (= (nkeys) 1) + (line-size) + 1) + (the fixnum (+ loc (line-size))))) + ;; + ;; Given a line which has a valid entry in it, this + ;; will return the primary cache line of the wrappers + ;; in that line. We just call + ;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this + ;; is an easier packaging up of the call to it. + ;; + (line-primary (line) + (declare (fixnum line)) + (location-line (line-primary-location line))) + ;; + (line-primary-location (line) + (declare (fixnum line)) + (compute-primary-cache-location-from-location + (cache) (line-location line)))) + (declare (ignorable #'cache #'nkeys #'line-size #'vector #'valuep + #'nlines #'max-location #'limit-fn #'size + #'mask #'field #'overflow #'line-reserved-p + #'location-reserved-p #'line-location + #'location-line #'line-wrappers #'location-wrappers + #'line-matches-wrappers-p + #'location-matches-wrappers-p + #'line-value #'location-value #'line-full-p + #'line-valid-p #'location-valid-p + #'line-separation #'next-line #'next-location + #'line-primary #'line-primary-location)) ,@body))) - -) ; EVAL-WHEN ;;; Here is where we actually fill, recache and expand caches. ;;; @@ -1340,32 +1282,3 @@ (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)))))) - -(defun caches-to-allocate () - (sort (let ((l nil)) - (maphash #'(lambda (size entry) - (push (list (car entry) size) l)) - sb-pcl::*free-caches*) - l) - #'> - :key #'cadr))