X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=c9960acc1e2a327c90fc177d6296f5d7e7995da4;hb=9be48f2a73ca5f4cc0848b8c0adad7127de10373;hp=313d96da7021cff6e5f8dc86f27a54c338a711fb;hpb=a987d443ea0935bfdfa2eb8547218fef9730a14f;p=sbcl.git diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 313d96d..c9960ac 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -96,37 +96,62 @@ (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) + ;; FIXME: To my eye this PCL-LOCK implies we should be holding the + ;; lock whenever we play with any cache vector, which doesn't seem + ;; to be true. On the other hand that would be too expensive as + ;; well, since it would mean serialization across all GFs. (with-pcl-lock (fill (the simple-vector cache-vector) nil) (setf (cache-vector-lock-count cache-vector) 0)) cache-vector) +;;; Return an empty cache vector +(defun get-cache-vector (size) + (declare (type (and unsigned-byte fixnum) size)) + (let ((cv (make-array size :initial-element nil))) + (setf (cache-vector-lock-count cv) 0) + cv)) + (defmacro modify-cache (cache-vector &body body) `(with-pcl-lock + ;; This locking scheme is less the sufficient, and not what the + ;; PCL implementors had planned: apparently we should increment + ;; the lock count atomically, and all cache users should check + ;; the count before and after they touch cache: if the counts + ;; match the cache was not altered, if they don't match the + ;; work needs to be redone. + ;; + ;; We probably want to re-engineer things so that the whole + ;; cache vector gets replaced atomically when we do things + ;; to it that could affect others. (multiple-value-prog1 (progn ,@body) (let ((old-count (cache-vector-lock-count ,cache-vector))) (declare (fixnum old-count)) (setf (cache-vector-lock-count ,cache-vector) (if (= old-count most-positive-fixnum) - 1 (the fixnum (1+ old-count)))))))) + 1 + (1+ old-count))))))) (deftype field-type () '(mod #.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 + (declaim (ftype (function (fixnum) (values (and unsigned-byte fixnum) &optional)) + power-of-two-ceiling)) + (defun power-of-two-ceiling (x) + ;; (expt 2 (ceiling (log x 2))) + (ash 1 (integer-length (1- x))))) + +;;; FIXME: We should probably keep just one of these -- or at least use just +;;; one. +(declaim (inline compute-line-size)) +(defun compute-line-size (x) + (power-of-two-ceiling x)) (defconstant +nkeys-limit+ 256) @@ -146,16 +171,6 @@ (overflow nil :type list)) #-sb-fluid (declaim (sb-ext:freeze-type cache)) - -(defmacro cache-lock-count (cache) - `(cache-vector-lock-count (cache-vector ,cache))) - -;;; Return a cache that has had FLUSH-CACHE-VECTOR-INTERNAL called on -;;; it. This returns a cache of exactly the size requested, it won't -;;; ever return a larger cache. -(defun get-cache-vector (size) - (flush-cache-vector-internal (make-array size))) - ;;;; wrapper cache numbers @@ -211,13 +226,6 @@ (defmacro wrapper-no-of-instance-slots (wrapper) `(layout-length ,wrapper)) -;;; FIXME: Why are these macros? -(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. @@ -258,6 +266,7 @@ (cond (owrap (layout-classoid owrap)) ((or (*subtypep (class-of class) *the-class-standard-class*) + (*subtypep (class-of class) *the-class-funcallable-standard-class*) (typep class 'forward-referenced-class)) (cond ((and *pcl-class-boot* (eq (slot-value class 'name) *pcl-class-boot*)) @@ -268,9 +277,11 @@ (aver (eq (classoid-pcl-class found) class)) found)) (t - (make-standard-classoid :pcl-class class)))) + (let ((name (slot-value class 'name))) + (make-standard-classoid :pcl-class class + :name (and (symbolp name) name)))))) (t - (make-random-pcl-classoid :pcl-class class)))))) + (bug "Got to T branch in ~S" 'make-wrapper)))))) (t (let* ((found (find-classoid (slot-value class 'name))) (layout (classoid-layout found))) @@ -287,25 +298,6 @@ (and (< field-number #.(1- wrapper-cache-number-vector-length)) (1+ field-number))) -;;; FIXME: Why are there two layers here, with one operator trivially -;;; defined in terms of the other? It'd be nice either to have a -;;; comment explaining why the separation is valuable, or to collapse -;;; it into a single layer. -;;; -;;; FIXME (?): These are logically inline functions, but they need to -;;; be SETFable, and for now it seems not worth the trouble to DEFUN -;;; both inline FOO and inline (SETF FOO) for each one instead of a -;;; single macro. Perhaps the best thing would be to make them -;;; immutable (since it seems sort of surprising and gross to be able -;;; to modify hash values) so that they can become inline functions -;;; with no muss or fuss. I (WHN) didn't do this only because I didn't -;;; know whether any code anywhere depends on the values being -;;; modified. -(defmacro cache-number-vector-ref (cnv n) - `(wrapper-cache-number-vector-ref ,cnv ,n)) -(defmacro wrapper-cache-number-vector-ref (wrapper n) - `(layout-clos-hash ,wrapper ,n)) - (declaim (inline wrapper-class*)) (defun wrapper-class* (wrapper) (or (wrapper-class wrapper) @@ -329,8 +321,10 @@ (defun invalid-wrapper-p (wrapper) (not (null (layout-invalid wrapper)))) +;;; We only use this inside INVALIDATE-WRAPPER. (defvar *previous-nwrappers* (make-hash-table)) +;;; We always call this inside WITH-PCL-LOCK. (defun invalidate-wrapper (owrapper state nwrapper) (aver (member state '(:flush :obsolete) :test #'eq)) (let ((new-previous ())) @@ -348,15 +342,20 @@ (setf (cadr previous) nwrapper) (push previous new-previous)) - (let ((ocnv (wrapper-cache-number-vector owrapper))) - (dotimes (i layout-clos-hash-length) - (setf (cache-number-vector-ref ocnv i) 0))) + ;; FIXME: We are here inside PCL lock, but might someone be + ;; accessing the wrapper at the same time from outside the lock? + ;; Can it matter that they get 0 from one slot and a valid value + ;; from another? + (dotimes (i layout-clos-hash-length) + (setf (layout-clos-hash owrapper i) 0)) + ;; FIXME: We could save a whopping cons by using (STATE . WRAPPER) + ;; instead (push (setf (layout-invalid owrapper) (list state nwrapper)) new-previous) - (setf (gethash owrapper *previous-nwrappers*) () - (gethash nwrapper *previous-nwrappers*) new-previous))) + (remhash owrapper *previous-nwrappers*) + (setf (gethash nwrapper *previous-nwrappers*) new-previous))) (defun check-wrapper-validity (instance) (let* ((owrapper (wrapper-of instance)) @@ -450,39 +449,34 @@ (setf (cache-vector new-cache) new-vector) new-cache)) -(defun compute-line-size (x) - (power-of-two-ceiling x)) - (defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector) ;;(declare (values cache-mask actual-size line-size nlines)) (declare (fixnum nkeys)) (if (= nkeys 1) (let* ((line-size (if valuep 2 1)) - (cache-size (if (typep nlines-or-cache-vector 'fixnum) - (the fixnum - (* line-size - (the fixnum - (power-of-two-ceiling - nlines-or-cache-vector)))) - (cache-vector-size nlines-or-cache-vector)))) - (declare (fixnum line-size cache-size)) - (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) + (cache-size (etypecase nlines-or-cache-vector + (fixnum + (* line-size + (power-of-two-ceiling nlines-or-cache-vector))) + (vector + (cache-vector-size nlines-or-cache-vector))))) + (declare (type (and unsigned-byte fixnum) line-size cache-size)) + (values (logxor (1- cache-size) (1- line-size)) cache-size line-size - (the (values fixnum t) (floor cache-size line-size)))) + (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))))) + (cache-size (etypecase nlines-or-cache-vector + (fixnum + (* line-size + (power-of-two-ceiling nlines-or-cache-vector))) + (vector + (1- (cache-vector-size nlines-or-cache-vector)))))) (declare (fixnum line-size cache-size)) - (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) - (the fixnum (1+ cache-size)) + (values (logxor (1- cache-size) (1- line-size)) + (1+ cache-size) line-size - (the (values fixnum t) (floor cache-size line-size)))))) + (floor cache-size line-size))))) ;;; the various implementations of computing a primary cache location from ;;; wrappers. Because some implementations of this must run fast there are @@ -497,22 +491,19 @@ ;;; 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)) + (logand mask (layout-clos-hash 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))) + (let ((wrapper-cache-number (layout-clos-hash 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))))) + (incf location wrapper-cache-number))) ;; Then, if we are working with lots of wrappers, deal with ;; the wrapper-cache-number-mask stuff. (when (and (not (zerop i)) @@ -520,7 +511,7 @@ (setq location (logand location wrapper-cache-number-mask))) (incf i)) - (the fixnum (1+ (logand mask location)))))) + (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 @@ -543,32 +534,39 @@ (declare (type field-type field) (fixnum result mask nkeys) (simple-vector cache-vector)) (dotimes-fixnum (i nkeys) + ;; FIXME: Sometimes we get NIL here as wrapper, apparently because + ;; another thread has stomped on the cache-vector. (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location))) - (wcn (wrapper-cache-number-vector-ref wrapper field))) + (wcn (layout-clos-hash wrapper field))) (declare (fixnum wcn)) - (setq result (+ result wcn))) + (incf result wcn)) (when (and (not (zerop i)) (zerop (mod i wrapper-cache-number-adds-ok))) (setq result (logand result wrapper-cache-number-mask)))) (if (= nkeys 1) (logand mask result) - (the fixnum (1+ (logand mask result)))))) + (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 +;;; 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 5 values) or else have seen something which doesn't +;;; fall into a single category (SLOT-INSTANCE, FORWARD). +;;; +;;; T: means everything so far is the class T +;;; STANDARD-INSTANCE: seen only standard classes +;;; BUILT-IN-INSTANCE: seen only built in classes +;;; STRUCTURE-INSTANCE: seen only structure classes +;;; CONDITION-INSTANCE: seen only condition classes (defun raise-metatype (metatype new-specializer) (let ((slot (find-class 'slot-class)) (standard (find-class 'standard-class)) (fsc (find-class 'funcallable-standard-class)) (condition (find-class 'condition-class)) (structure (find-class 'structure-class)) - (built-in (find-class 'built-in-class))) + (built-in (find-class 'built-in-class)) + (frc (find-class 'forward-referenced-class))) (flet ((specializer->metatype (x) (let ((meta-specializer (if (eq *boot-state* 'complete) @@ -582,18 +580,19 @@ ((*subtypep meta-specializer structure) 'structure-instance) ((*subtypep meta-specializer built-in) 'built-in-instance) ((*subtypep meta-specializer slot) 'slot-instance) + ((*subtypep meta-specializer frc) 'forward) (t (error "~@" - new-specializer - meta-specializer)))))) + 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 + ;; NIL ===> + ;; X X ===> X + ;; X Y ===> CLASS (let ((new-metatype (specializer->metatype new-specializer))) (cond ((eq new-metatype 'slot-instance) 'class) + ((eq new-metatype 'forward) 'class) ((null metatype) new-metatype) ((eq metatype new-metatype) new-metatype) (t 'class)))))) @@ -652,75 +651,84 @@ ;;;; symbols because we don't capture any user code in the scope in which ;;;; these symbols are bound. +(declaim (list *dfun-arg-symbols*)) (defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.)) (defun dfun-arg-symbol (arg-number) - (or (nth arg-number (the list *dfun-arg-symbols*)) + (or (nth arg-number *dfun-arg-symbols*) (format-symbol *pcl-package* ".ARG~A." arg-number))) +(declaim (list *slot-vector-symbols*)) (defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.)) (defun slot-vector-symbol (arg-number) - (or (nth arg-number (the list *slot-vector-symbols*)) + (or (nth arg-number *slot-vector-symbols*) (format-symbol *pcl-package* ".SLOTS~A." arg-number))) -;; FIXME: There ought to be a good way to factor out the idiom: -;; -;; (dotimes (i (length metatypes)) -;; (push (dfun-arg-symbol i) lambda-list)) -;; -;; used in the following four functions into common code that we can -;; declare inline or something. --njf 2001-12-20 +(declaim (inline make-dfun-required-args)) +(defun make-dfun-required-args (metatypes) + ;; Micro-optimizations 'R Us + (labels ((rec (types i) + (declare (fixnum i)) + (when types + (cons (dfun-arg-symbol i) + (rec (cdr types) (1+ i)))))) + (rec metatypes 0))) + (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))) + (let ((required (make-dfun-required-args metatypes))) + (if applyp + (nconc required + ;; Use &MORE arguments to avoid consing up an &REST list + ;; that we might not need at all. See MAKE-EMF-CALL and + ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other + ;; pieces. + '(&more .dfun-more-context. .dfun-more-count.)) + required))) (defun make-dlap-lambda-list (metatypes applyp) - (let ((lambda-list nil)) - (dotimes (i (length metatypes)) - (push (dfun-arg-symbol i) lambda-list)) - ;; FIXME: This is translated directly from the old PCL code. - ;; It didn't have a (PUSH '.DFUN-REST-ARG. LAMBDA-LIST) or - ;; something similar, so we don't either. It's hard to see how - ;; this could be correct, since &REST wants an argument after - ;; it. This function works correctly because the caller - ;; magically tacks on something after &REST. The calling functions - ;; (in dlisp.lisp) should be fixed and this function rewritten. - ;; --njf 2001-12-20 - (when applyp - (push '&rest lambda-list)) - (nreverse lambda-list))) - -;; FIXME: The next two functions suffer from having a `.DFUN-REST-ARG.' -;; in their lambda lists, but no corresponding `&REST' symbol. We assume -;; this should be the case by analogy with the previous two functions. -;; It works, and I don't know why. Check the calling functions and -;; fix these too. --njf 2001-12-20 + (let* ((required (make-dfun-required-args metatypes)) + (lambda-list (if applyp + (append required '(&more .more-context. .more-count.)) + required))) + ;; Return the full lambda list, the required arguments, a form + ;; that will generate a rest-list, and a list of the &MORE + ;; parameters used. + (values lambda-list + required + (when applyp + '((sb-c::%listify-rest-args + .more-context. + (the (and unsigned-byte fixnum) + .more-count.)))) + (when applyp + '(.more-context. .more-count.))))) + (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)))) + (let ((required (make-dfun-required-args metatypes))) `(,(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.))))) + ,fn-variable + ,applyp + :required-args ,required + ;; INVOKE-EFFECTIVE-METHOD-FUNCTION will decide whether to use + ;; the :REST-ARG version or the :MORE-ARG version depending on + ;; the type of the EMF. + :rest-arg ,(if applyp + ;; Creates a list from the &MORE arguments. + '((sb-c::%listify-rest-args + .dfun-more-context. + (the (and unsigned-byte fixnum) + .dfun-more-count.))) + nil) + :more-arg ,(when applyp + '(.dfun-more-context. .dfun-more-count.))))) (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))) + (list* '.pv-cell. '.next-method-call. + (make-dfun-lambda-list metatypes applyp))) + (defmacro with-local-cache-functions ((cache) &body body) `(let ((.cache. ,cache)) @@ -728,7 +736,7 @@ (labels ((cache () .cache.) (nkeys () (cache-nkeys .cache.)) (line-size () (cache-line-size .cache.)) - (vector () (cache-vector .cache.)) + (c-vector () (cache-vector .cache.)) (valuep () (cache-valuep .cache.)) (nlines () (cache-nlines .cache.)) (max-location () (cache-max-location .cache.)) @@ -789,9 +797,9 @@ (location-wrappers (location) ; avoid multiplies caused by line-location (declare (fixnum location)) (if (= (nkeys) 1) - (cache-vector-ref (vector) location) + (cache-vector-ref (c-vector) location) (let ((list (make-list (nkeys))) - (vector (vector))) + (vector (c-vector))) (declare (simple-vector vector)) (dotimes (i (nkeys) list) (declare (fixnum i)) @@ -809,7 +817,7 @@ ;; (location-matches-wrappers-p (loc wrappers) ; must not be reserved (declare (fixnum loc)) - (let ((cache-vector (vector))) + (let ((cache-vector (c-vector))) (declare (simple-vector cache-vector)) (if (= (nkeys) 1) (eq wrappers (cache-vector-ref cache-vector loc)) @@ -831,14 +839,14 @@ (location-value (loc) (declare (fixnum loc)) (and (valuep) - (cache-vector-ref (vector) (+ loc (nkeys))))) + (cache-vector-ref (c-vector) (+ loc (nkeys))))) ;; ;; Given a line number, return true IFF that line has data in ;; it. The state of the wrappers stored in the line is not ;; checked. An error is signalled if line is reserved. (line-full-p (line) (when (line-reserved-p line) (error "Line is reserved.")) - (not (null (cache-vector-ref (vector) (line-location line))))) + (not (null (cache-vector-ref (c-vector) (line-location line))))) ;; ;; Given a line number, return true IFF the line is full and ;; there are no invalid wrappers in the line, and the line's @@ -852,7 +860,7 @@ ;; (location-valid-p (loc wrappers) (declare (fixnum loc)) - (let ((cache-vector (vector)) + (let ((cache-vector (c-vector)) (wrappers-mismatch-p (null wrappers))) (declare (simple-vector cache-vector)) (dotimes (i (nkeys) wrappers-mismatch-p) @@ -911,7 +919,7 @@ (declare (fixnum line)) (compute-primary-cache-location-from-location (cache) (line-location line)))) - (declare (ignorable #'cache #'nkeys #'line-size #'vector #'valuep + (declare (ignorable #'cache #'nkeys #'line-size #'c-vector #'valuep #'nlines #'max-location #'limit-fn #'size #'mask #'field #'overflow #'line-reserved-p #'location-reserved-p #'line-location @@ -944,7 +952,6 @@ (defun fill-cache (cache wrappers value) ;; FILL-CACHE won't return if WRAPPERS is nil, might as well check.. (aver wrappers) - (or (fill-cache-p nil cache wrappers value) (and (< (ceiling (* (cache-count cache) *cache-expand-threshold*)) (if (= (cache-nkeys cache) 1) @@ -981,7 +988,6 @@ (setq location (next-location location)))))) (defun probe-cache (cache wrappers &optional default limit-fn) - ;;(declare (values value)) (aver wrappers) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) @@ -1007,7 +1013,8 @@ (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))) + ;; FIXME: Cache modification: should we not be holding a lock? + (setf (cache-vector-ref (c-vector) (+ (line-location i) (nkeys))) value))))) (dolist (entry (overflow)) (let ((value (funcall function (car entry) (cdr entry)))) @@ -1033,6 +1040,8 @@ (return t)))))) ;;; returns T or NIL +;;; +;;; FIXME: Deceptive name as this has side-effects. (defun fill-cache-p (forcep cache wrappers value) (with-local-cache-functions (cache) (let* ((location (compute-primary-cache-location (field) (mask) wrappers)) @@ -1051,14 +1060,16 @@ (when (not emptyp) (push (cons (line-wrappers free) (line-value free)) (cache-overflow cache))) - ;;(fill-line free wrappers value) + ;; (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))) + (cache-vector (c-vector))) (declare (fixnum loc) (simple-vector cache-vector)) + ;; FIXME: Cache modifications: should we not be holding + ;; a lock? (cond ((= (nkeys) 1) (setf (cache-vector-ref cache-vector loc) wrappers) (when (valuep) @@ -1074,6 +1085,7 @@ value)))) (maybe-check-cache cache)))))))) +;;; FIXME: Deceptive name as this has side-effects (defun fill-cache-from-cache-p (forcep cache from-cache from-line) (declare (fixnum from-line)) (with-local-cache-functions (cache) @@ -1089,7 +1101,7 @@ (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-cache-vector (c-vector)) (to-line free)) (declare (fixnum to-line)) (if (line-reserved-p to-line) @@ -1219,7 +1231,7 @@ ;;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))) + (cache-vector (c-vector))) (declare (fixnum from-loc to-loc) (simple-vector cache-vector)) (modify-cache cache-vector (dotimes-fixnum (i (line-size)) @@ -1237,5 +1249,3 @@ ((1 2 4) 1) ((8 16) 4) (otherwise 6))) - -(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms