(in-package "SB-PCL")
\f
+;;; Ye olde CMUCL comment follows, but it seems likely that the paper
+;;; that would be inserted would resemble Kiczales and Rodruigez,
+;;; Efficient Method Dispatch in PCL, ACM 1990. Some of the details
+;;; changed between that paper and "May Day PCL" of 1992; some other
+;;; details have changed since, but reading that paper gives the broad
+;;; idea.
+;;;
;;; The caching algorithm implemented:
;;;
;;; << put a paper here >>
;;; assembler.
(defmacro cache-vector-ref (cache-vector location)
`(svref (the simple-vector ,cache-vector)
- (sb-ext:truly-the fixnum ,location)))
+ (sb-ext:truly-the fixnum ,location)))
(defmacro cache-vector-size (cache-vector)
`(array-dimension (the simple-vector ,cache-vector) 0))
(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))))))))
+ (declare (fixnum old-count))
+ (setf (cache-vector-lock-count ,cache-vector)
+ (if (= old-count most-positive-fixnum)
+ 1 (the fixnum (1+ old-count))))))))
(deftype field-type ()
'(mod #.layout-clos-hash-length))
(defconstant +nkeys-limit+ 256)
(defstruct (cache (:constructor make-cache ())
- (:copier copy-cache-internal))
+ (:copier copy-cache-internal))
(owner nil)
(nkeys 1 :type (integer 1 #.+nkeys-limit+))
(valuep nil :type (member nil t))
;;; ever return a larger cache.
(defun get-cache-vector (size)
(flush-cache-vector-internal (make-array size)))
-
+
\f
;;;; wrapper cache numbers
(cond
(found
(unless (classoid-pcl-class found)
- (setf (classoid-pcl-class found) class))
+ (setf (classoid-pcl-class found) class))
(aver (eq (classoid-pcl-class found) class))
(let ((layout (classoid-layout found)))
- (aver layout)
- layout))
+ (aver layout)
+ layout))
(t
(make-wrapper-internal
:length length
:classoid (make-standard-classoid
- :name name :pcl-class 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
(defun make-wrapper (length class)
(cond
((or (typep class 'std-class)
- (typep class 'forward-referenced-class))
+ (typep class 'forward-referenced-class))
(make-wrapper-internal
:length length
:classoid
(let ((owrap (class-wrapper class)))
- (cond (owrap
- (layout-classoid owrap))
- ((or (*subtypep (class-of class) *the-class-standard-class*)
- (typep class 'forward-referenced-class))
- (cond ((and *pcl-class-boot*
- (eq (slot-value class 'name) *pcl-class-boot*))
- (let ((found (find-classoid
- (slot-value class 'name))))
- (unless (classoid-pcl-class found)
- (setf (classoid-pcl-class found) class))
- (aver (eq (classoid-pcl-class found) class))
- found))
- (t
- (make-standard-classoid :pcl-class class))))
- (t
- (make-random-pcl-classoid :pcl-class class))))))
+ (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*))
+ (let ((found (find-classoid
+ (slot-value class 'name))))
+ (unless (classoid-pcl-class found)
+ (setf (classoid-pcl-class found) class))
+ (aver (eq (classoid-pcl-class found) class))
+ found))
+ (t
+ (let ((name (slot-value class 'name)))
+ (make-standard-classoid :pcl-class class
+ :name (and (symbolp name) name))))))
+ (t
+ (bug "Got to T branch in ~S" 'make-wrapper))))))
(t
(let* ((found (find-classoid (slot-value class 'name)))
- (layout (classoid-layout found)))
+ (layout (classoid-layout found)))
(unless (classoid-pcl-class found)
- (setf (classoid-pcl-class found) class))
+ (setf (classoid-pcl-class found) class))
(aver (eq (classoid-pcl-class found) class))
(aver layout)
layout))))
;; corresponds to a kind of transitivity of wrapper updates.
(dolist (previous (gethash owrapper *previous-nwrappers*))
(when (eq state :obsolete)
- (setf (car previous) :obsolete))
+ (setf (car previous) :obsolete))
(setf (cadr previous) nwrapper)
(push previous new-previous))
(let ((ocnv (wrapper-cache-number-vector owrapper)))
(dotimes (i layout-clos-hash-length)
- (setf (cache-number-vector-ref ocnv i) 0)))
+ (setf (cache-number-vector-ref ocnv i) 0)))
(push (setf (layout-invalid owrapper) (list state nwrapper))
- new-previous)
+ new-previous)
(setf (gethash owrapper *previous-nwrappers*) ()
- (gethash nwrapper *previous-nwrappers*) new-previous)))
+ (gethash nwrapper *previous-nwrappers*) new-previous)))
(defun check-wrapper-validity (instance)
(let* ((owrapper (wrapper-of instance))
- (state (layout-invalid owrapper)))
+ (state (layout-invalid owrapper)))
(aver (not (eq state :uninitialized)))
(etypecase state
(null owrapper)
(check-wrapper-validity instance))
(cons
(ecase (car state)
- (:flush
- (flush-cache-trap owrapper (cadr state) instance))
- (:obsolete
- (obsolete-instance-trap owrapper (cadr state) instance)))))))
+ (: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)
(let ((cache (make-cache)))
(declare (type cache cache))
(multiple-value-bind (cache-mask actual-size line-size nlines)
- (compute-cache-parameters nkeys valuep 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-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+))
+ &optional (new-field +first-wrapper-cache-number-index+))
(let ((nkeys (cache-nkeys old-cache))
- (valuep (cache-valuep old-cache))
- (cache (make-cache)))
+ (valuep (cache-valuep old-cache))
+ (cache (make-cache)))
(declare (type cache cache))
(multiple-value-bind (cache-mask actual-size line-size nlines)
- (if (= new-nlines (cache-nlines old-cache))
- (values (cache-mask old-cache) (cache-size old-cache)
- (cache-line-size old-cache) (cache-nlines old-cache))
- (compute-cache-parameters nkeys valuep new-nlines))
+ (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-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)))
+ (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)))
(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))))
+ (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))))))
+ (cache-size (if (typep nlines-or-cache-vector 'fixnum)
+ (the fixnum
+ (* line-size
+ (the fixnum
+ (power-of-two-ceiling
+ nlines-or-cache-vector))))
+ (1- (cache-vector-size nlines-or-cache-vector)))))
+ (declare (fixnum line-size cache-size))
+ (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
+ (the fixnum (1+ cache-size))
+ line-size
+ (the (values fixnum t) (floor cache-size line-size))))))
\f
;;; the various implementations of computing a primary cache location from
;;; wrappers. Because some implementations of this must run fast there are
(declare (type field-type field) (fixnum mask))
(if (not (listp wrappers))
(logand mask
- (the fixnum (wrapper-cache-number-vector-ref wrappers field)))
+ (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))))))
+ (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
;;; 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))
+ 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)))
+ (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))
+ (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)))
+ (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))))
+ (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))))))
+ (logand mask result)
+ (the fixnum (1+ (logand mask result))))))
\f
-;;; NIL means nothing so far, no actual arg info has NILs
-;;; in the metatype
-;;; CLASS seen all sorts of metaclasses
-;;; (specifically, more than one of the next 4 values)
-;;; T means everything so far is the class T
-;;; STANDARD-CLASS seen only standard classes
-;;; BUILT-IN-CLASS seen only built in classes
-;;; STRUCTURE-CLASS seen only structure classes
+;;; 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))
- (std (find-class 'std-class))
- (standard (find-class 'standard-class))
- (fsc (find-class 'funcallable-standard-class))
- (condition (find-class 'condition-class))
- (structure (find-class 'structure-class))
- (built-in (find-class 'built-in-class)))
+ (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))
+ (frc (find-class 'forward-referenced-class)))
(flet ((specializer->metatype (x)
- (let ((meta-specializer
- (if (eq *boot-state* 'complete)
- (class-of (specializer-class x))
- (class-of x))))
- (cond
- ((eq x *the-class-t*) t)
- ((*subtypep meta-specializer std) 'standard-instance)
- ((*subtypep meta-specializer standard) 'standard-instance)
- ((*subtypep meta-specializer fsc) 'standard-instance)
- ((*subtypep meta-specializer condition) 'condition-instance)
- ((*subtypep meta-specializer structure) 'structure-instance)
- ((*subtypep meta-specializer built-in) 'built-in-instance)
- ((*subtypep meta-specializer slot) 'slot-instance)
- (t (error "~@<PCL cannot handle the specializer ~S ~
+ (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 standard) 'standard-instance)
+ ((*subtypep meta-specializer fsc) 'standard-instance)
+ ((*subtypep meta-specializer condition) 'condition-instance)
+ ((*subtypep meta-specializer structure) 'structure-instance)
+ ((*subtypep meta-specializer built-in) 'built-in-instance)
+ ((*subtypep meta-specializer slot) 'slot-instance)
+ ((*subtypep meta-specializer frc) 'forward)
+ (t (error "~@<PCL cannot handle the specializer ~S ~
(meta-specializer ~S).~@:>"
- 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 <anything> ===> <anything>
- ;; X X ===> X
- ;; X Y ===> CLASS
+ ;; NIL <anything> ===> <anything>
+ ;; X X ===> X
+ ;; X Y ===> CLASS
(let ((new-metatype (specializer->metatype new-specializer)))
- (cond ((eq new-metatype 'slot-instance) 'class)
- ((null metatype) new-metatype)
- ((eq metatype new-metatype) new-metatype)
- (t 'class))))))
+ (cond ((eq new-metatype 'slot-instance) 'class)
+ ((eq new-metatype 'forward) '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)
+ (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))))
+ (,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))
+ (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)))))
+ (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))))
+ ,invalid-arguments-form
+ (let* (,@(when wrappers
+ `((,wrappers (nreverse wrappers-rev))
+ (,classes (nreverse classes-rev))
+ (,types (mapcar (lambda (class)
+ `(class-eq ,class))
+ ,classes)))))
+ ,@body))))
\f
;;;; some support stuff for getting a hold of symbols that we need when
;;;; building the discriminator codes. It's OK for these to be interned
(push (dfun-arg-symbol i) required))
(nreverse required))))
`(,(if (eq emf-type 'fast-method-call)
- 'invoke-effective-method-function-fast
- 'invoke-effective-method-function)
+ 'invoke-effective-method-function-fast
+ 'invoke-effective-method-function)
,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.)))))
(defun make-fast-method-call-lambda-list (metatypes applyp)
`(let ((.cache. ,cache))
(declare (type cache .cache.))
(labels ((cache () .cache.)
- (nkeys () (cache-nkeys .cache.))
- (line-size () (cache-line-size .cache.))
- (vector () (cache-vector .cache.))
- (valuep () (cache-valuep .cache.))
- (nlines () (cache-nlines .cache.))
- (max-location () (cache-max-location .cache.))
- (limit-fn () (cache-limit-fn .cache.))
- (size () (cache-size .cache.))
- (mask () (cache-mask .cache.))
- (field () (cache-field .cache.))
- (overflow () (cache-overflow .cache.))
- ;;
- ;; Return T IFF this cache location is reserved. The
- ;; only time this is true is for line number 0 of an
- ;; nkeys=1 cache.
- ;;
- (line-reserved-p (line)
- (declare (fixnum line))
- (and (= (nkeys) 1)
- (= line 0)))
- ;;
- (location-reserved-p (location)
- (declare (fixnum location))
- (and (= (nkeys) 1)
- (= location 0)))
- ;;
- ;; Given a line number, return the cache location.
- ;; This is the value that is the second argument to
- ;; cache-vector-ref. Basically, this deals with the
- ;; offset of nkeys>1 caches and multiplies by line
- ;; size.
- ;;
- (line-location (line)
- (declare (fixnum line))
- (when (line-reserved-p line)
- (error "line is reserved"))
- (if (= (nkeys) 1)
- (the fixnum (* line (line-size)))
- (the fixnum (1+ (the fixnum (* line (line-size)))))))
- ;;
- ;; Given a cache location, return the line. This is
- ;; the inverse of LINE-LOCATION.
- ;;
- (location-line (location)
- (declare (fixnum location))
- (if (= (nkeys) 1)
- (floor location (line-size))
- (floor (the fixnum (1- location)) (line-size))))
- ;;
- ;; Given a line number, return the wrappers stored at
- ;; that line. As usual, if nkeys=1, this returns a
- ;; single value. Only when nkeys>1 does it return a
- ;; list. An error is signalled if the line is
- ;; reserved.
- ;;
- (line-wrappers (line)
- (declare (fixnum line))
- (when (line-reserved-p line) (error "Line is reserved."))
- (location-wrappers (line-location line)))
- ;;
- (location-wrappers (location) ; avoid multiplies caused by line-location
- (declare (fixnum location))
- (if (= (nkeys) 1)
- (cache-vector-ref (vector) location)
- (let ((list (make-list (nkeys)))
- (vector (vector)))
- (declare (simple-vector vector))
- (dotimes (i (nkeys) list)
- (declare (fixnum i))
- (setf (nth i list)
- (cache-vector-ref vector (+ location i)))))))
- ;;
- ;; Given a line number, return true IFF the line's
- ;; wrappers are the same as wrappers.
- ;;
- (line-matches-wrappers-p (line wrappers)
- (declare (fixnum line))
- (and (not (line-reserved-p line))
- (location-matches-wrappers-p (line-location line)
- wrappers)))
- ;;
- (location-matches-wrappers-p (loc wrappers) ; must not be reserved
- (declare (fixnum loc))
- (let ((cache-vector (vector)))
- (declare (simple-vector cache-vector))
- (if (= (nkeys) 1)
- (eq wrappers (cache-vector-ref cache-vector loc))
- (dotimes (i (nkeys) t)
- (declare (fixnum i))
- (unless (eq (pop wrappers)
- (cache-vector-ref cache-vector (+ loc i)))
- (return nil))))))
- ;;
- ;; Given a line number, return the value stored at that line.
- ;; If valuep is NIL, this returns NIL. As with line-wrappers,
- ;; an error is signalled if the line is reserved.
- ;;
- (line-value (line)
- (declare (fixnum line))
- (when (line-reserved-p line) (error "Line is reserved."))
- (location-value (line-location line)))
- ;;
- (location-value (loc)
- (declare (fixnum loc))
- (and (valuep)
- (cache-vector-ref (vector) (+ loc (nkeys)))))
- ;;
- ;; Given a line number, return true IFF that line has data in
- ;; it. The state of the wrappers stored in the line is not
- ;; checked. An error is signalled if line is reserved.
- (line-full-p (line)
- (when (line-reserved-p line) (error "Line is reserved."))
- (not (null (cache-vector-ref (vector) (line-location line)))))
- ;;
- ;; Given a line number, return true IFF the line is full and
- ;; there are no invalid wrappers in the line, and the line's
- ;; wrappers are different from wrappers.
- ;; An error is signalled if the line is reserved.
- ;;
- (line-valid-p (line wrappers)
- (declare (fixnum line))
- (when (line-reserved-p line) (error "Line is reserved."))
- (location-valid-p (line-location line) wrappers))
- ;;
- (location-valid-p (loc wrappers)
- (declare (fixnum loc))
- (let ((cache-vector (vector))
- (wrappers-mismatch-p (null wrappers)))
- (declare (simple-vector cache-vector))
- (dotimes (i (nkeys) wrappers-mismatch-p)
- (declare (fixnum i))
- (let ((wrapper (cache-vector-ref cache-vector (+ loc i))))
- (when (or (null wrapper)
- (invalid-wrapper-p wrapper))
- (return nil))
- (unless (and wrappers
- (eq wrapper
- (if (consp wrappers)
- (pop wrappers)
- wrappers)))
- (setq wrappers-mismatch-p t))))))
- ;;
- ;; How many unreserved lines separate line-1 and line-2.
- ;;
- (line-separation (line-1 line-2)
- (declare (fixnum line-1 line-2))
- (let ((diff (the fixnum (- line-2 line-1))))
- (declare (fixnum diff))
- (when (minusp diff)
- (setq diff (+ diff (nlines)))
- (when (line-reserved-p 0)
- (setq diff (1- diff))))
- diff))
- ;;
- ;; Given a cache line, get the next cache line. This will not
- ;; return a reserved line.
- ;;
- (next-line (line)
- (declare (fixnum line))
- (if (= line (the fixnum (1- (nlines))))
- (if (line-reserved-p 0) 1 0)
- (the fixnum (1+ line))))
- ;;
- (next-location (loc)
- (declare (fixnum loc))
- (if (= loc (max-location))
- (if (= (nkeys) 1)
- (line-size)
- 1)
- (the fixnum (+ loc (line-size)))))
- ;;
- ;; Given a line which has a valid entry in it, this
- ;; will return the primary cache line of the wrappers
- ;; in that line. We just call
- ;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION, this
- ;; is an easier packaging up of the call to it.
- ;;
- (line-primary (line)
- (declare (fixnum line))
- (location-line (line-primary-location line)))
- ;;
- (line-primary-location (line)
- (declare (fixnum line))
- (compute-primary-cache-location-from-location
- (cache) (line-location line))))
+ (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))
+ #'nlines #'max-location #'limit-fn #'size
+ #'mask #'field #'overflow #'line-reserved-p
+ #'location-reserved-p #'line-location
+ #'location-line #'line-wrappers #'location-wrappers
+ #'line-matches-wrappers-p
+ #'location-matches-wrappers-p
+ #'line-value #'location-value #'line-full-p
+ #'line-valid-p #'location-valid-p
+ #'line-separation #'next-line #'next-location
+ #'line-primary #'line-primary-location))
,@body)))
\f
;;; Here is where we actually fill, recache and expand caches.
(defun fill-cache (cache wrappers value)
;; FILL-CACHE won't return if WRAPPERS is nil, might as well check..
- (assert wrappers)
+ (aver wrappers)
(or (fill-cache-p nil cache wrappers value)
- (and (< (ceiling (* (cache-count cache) 1.25))
- (if (= (cache-nkeys cache) 1)
- (1- (cache-nlines cache))
- (cache-nlines cache)))
- (adjust-cache cache wrappers value))
+ (and (< (ceiling (* (cache-count cache) *cache-expand-threshold*))
+ (if (= (cache-nkeys cache) 1)
+ (1- (cache-nlines cache))
+ (cache-nlines cache)))
+ (adjust-cache cache wrappers value))
(expand-cache cache wrappers value)))
(defvar *check-cache-p* nil)
(defun check-cache (cache)
(with-local-cache-functions (cache)
(let ((location (if (= (nkeys) 1) 0 1))
- (limit (funcall (limit-fn) (nlines))))
+ (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))))))
+ (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!"))
+ (aver wrappers)
(with-local-cache-functions (cache)
(let* ((location (compute-primary-cache-location (field) (mask) wrappers))
- (limit (funcall (or limit-fn (limit-fn)) (nlines))))
+ (limit (funcall (or limit-fn (limit-fn)) (nlines))))
(declare (fixnum location limit))
(when (location-reserved-p location)
- (setq location (next-location 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)))
+ (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)))))
+ (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)))))
+ (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))))))
+ (let ((value (funcall function (car entry) (cdr entry))))
+ (when set-p
+ (setf (cdr entry) value))))))
cache)
(defun cache-count (cache)
(let ((count 0))
(declare (fixnum count))
(dotimes-fixnum (i (nlines) count)
- (unless (line-reserved-p i)
- (when (line-full-p i)
- (incf 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))))))
+ (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)))
+ (primary (location-line location)))
(declare (fixnum location primary))
+ ;; FIXME: I tried (aver (> location 0)) and (aver (not
+ ;; (location-reserved-p location))) here, on the basis that
+ ;; particularly passing a LOCATION of 0 for a cache with more
+ ;; than one key would cause PRIMARY to be -1. However, the
+ ;; AVERs triggered during the bootstrap, and removing them
+ ;; didn't cause anything to break, so I've left them removed.
+ ;; I'm still confused as to what is right. -- CSR, 2006-04-20
(multiple-value-bind (free emptyp)
- (find-free-cache-line primary cache wrappers)
- (when (or forcep emptyp)
- (when (not emptyp)
- (push (cons (line-wrappers free) (line-value free))
- (cache-overflow cache)))
- ;;(fill-line free wrappers value)
- (let ((line free))
- (declare (fixnum line))
- (when (line-reserved-p line)
- (error "attempt to fill a reserved line"))
- (let ((loc (line-location line))
- (cache-vector (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))))))))
+ (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))))
+ (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)))))))
+ (find-free-cache-line primary cache)
+ (when (or forcep emptyp)
+ (when (not emptyp)
+ (push (cons (line-wrappers free) (line-value free))
+ (cache-overflow cache)))
+ ;;(transfer-line from-cache-vector from-line cache-vector free)
+ (let ((from-cache-vector (cache-vector from-cache))
+ (to-cache-vector (vector))
+ (to-line free))
+ (declare (fixnum to-line))
+ (if (line-reserved-p to-line)
+ (error "transferring something into a reserved cache line")
+ (let ((from-loc (line-location from-line))
+ (to-loc (line-location to-line)))
+ (declare (fixnum from-loc to-loc))
+ (modify-cache to-cache-vector
+ (dotimes-fixnum (i (line-size))
+ (setf (cache-vector-ref to-cache-vector
+ (+ to-loc i))
+ (cache-vector-ref from-cache-vector
+ (+ from-loc i)))))))
+ (maybe-check-cache cache)))))))
;;; Returns NIL or (values <field> <cache-vector>)
;;;
(with-local-cache-functions (cache)
(let ((ncache (get-cache-from-cache cache (nlines) (field))))
(do ((nfield (cache-field ncache)
- (next-wrapper-cache-number-index nfield)))
- ((null nfield) nil)
- (setf (cache-field ncache) nfield)
- (labels ((try-one-fill-from-line (line)
- (fill-cache-from-cache-p nil ncache cache line))
- (try-one-fill (wrappers value)
- (fill-cache-p nil ncache wrappers value)))
- (if (and (dotimes-fixnum (i (nlines) t)
- (when (and (null (line-reserved-p i))
- (line-valid-p i wrappers))
- (unless (try-one-fill-from-line i) (return nil))))
- (dolist (wrappers+value (cache-overflow cache) t)
- (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
- (return nil)))
- (try-one-fill wrappers value))
- (return (maybe-check-cache ncache))
- (flush-cache-vector-internal (cache-vector ncache))))))))
+ (next-wrapper-cache-number-index nfield)))
+ ((null nfield) nil)
+ (setf (cache-field ncache) nfield)
+ (labels ((try-one-fill-from-line (line)
+ (fill-cache-from-cache-p nil ncache cache line))
+ (try-one-fill (wrappers value)
+ (fill-cache-p nil ncache wrappers value)))
+ (if (and (dotimes-fixnum (i (nlines) t)
+ (when (and (null (line-reserved-p i))
+ (line-valid-p i wrappers))
+ (unless (try-one-fill-from-line i) (return nil))))
+ (dolist (wrappers+value (cache-overflow cache) t)
+ (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
+ (return nil)))
+ (try-one-fill wrappers value))
+ (return (maybe-check-cache ncache))
+ (flush-cache-vector-internal (cache-vector ncache))))))))
;;; returns: (values <cache>)
(defun expand-cache (cache wrappers value)
(with-local-cache-functions (cache)
(let ((ncache (get-cache-from-cache cache (* (nlines) 2))))
(labels ((do-one-fill-from-line (line)
- (unless (fill-cache-from-cache-p nil ncache cache line)
- (do-one-fill (line-wrappers line) (line-value line))))
- (do-one-fill (wrappers value)
- (setq ncache (or (adjust-cache ncache wrappers value)
- (fill-cache-p t ncache wrappers value))))
- (try-one-fill (wrappers value)
- (fill-cache-p nil ncache wrappers value)))
- (dotimes-fixnum (i (nlines))
- (when (and (null (line-reserved-p i))
- (line-valid-p i wrappers))
- (do-one-fill-from-line i)))
- (dolist (wrappers+value (cache-overflow cache))
- (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
- (do-one-fill (car wrappers+value) (cdr wrappers+value))))
- (unless (try-one-fill wrappers value)
- (do-one-fill wrappers value))
- (maybe-check-cache ncache)))))
+ (unless (fill-cache-from-cache-p nil ncache cache line)
+ (do-one-fill (line-wrappers line) (line-value line))))
+ (do-one-fill (wrappers value)
+ (setq ncache (or (adjust-cache ncache wrappers value)
+ (fill-cache-p t ncache wrappers value))))
+ (try-one-fill (wrappers value)
+ (fill-cache-p nil ncache wrappers value)))
+ (dotimes-fixnum (i (nlines))
+ (when (and (null (line-reserved-p i))
+ (line-valid-p i wrappers))
+ (do-one-fill-from-line i)))
+ (dolist (wrappers+value (cache-overflow cache))
+ (unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
+ (do-one-fill (car wrappers+value) (cdr wrappers+value))))
+ (unless (try-one-fill wrappers value)
+ (do-one-fill wrappers value))
+ (maybe-check-cache ncache)))))
\f
+(defvar *pcl-misc-random-state* (make-random-state))
+
;;; This is the heart of the cache filling mechanism. It implements
;;; the decisions about where entries are placed.
;;;
;;; Find a line in the cache at which a new entry can be inserted.
;;;
;;; <line>
-;;; <empty?> is <line> in fact empty?
+;;; <empty?> is <line> in fact empty?
(defun find-free-cache-line (primary cache &optional wrappers)
;;(declare (values line empty?))
(declare (fixnum primary))
(with-local-cache-functions (cache)
(when (line-reserved-p primary) (setq primary (next-line primary)))
(let ((limit (funcall (limit-fn) (nlines)))
- (wrappedp nil)
- (lines nil)
- (p primary) (s primary))
+ (wrappedp nil)
+ (lines nil)
+ (p primary) (s primary))
(declare (fixnum p s limit))
(block find-free
- (loop
- ;; Try to find a free line starting at <s>. <p> is the
- ;; primary line of the entry we are finding a free
- ;; line for, it is used to compute the separations.
- (do* ((line s (next-line line))
- (nsep (line-separation p s) (1+ nsep)))
- (())
- (declare (fixnum line nsep))
- (when (null (line-valid-p line wrappers)) ;If this line is empty or
- (push line lines) ;invalid, just use it.
- (return-from find-free))
- (when (and wrappedp (>= line primary))
- ;; have gone all the way around the cache, time to quit
- (return-from find-free-cache-line (values primary nil)))
- (let ((osep (line-separation (line-primary line) line)))
- (when (>= osep limit)
- (return-from find-free-cache-line (values primary nil)))
- (when (cond ((= nsep limit) t)
- ((= nsep osep) (zerop (random 2)))
- ((> nsep osep) t)
- (t nil))
- ;; See whether we can displace what is in this line so that we
- ;; can use the line.
- (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))
- (setq p (line-primary line))
- (setq s (next-line line))
- (push line lines)
- (return nil)))
- (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)))))
+ (loop
+ ;; Try to find a free line starting at <s>. <p> is the
+ ;; primary line of the entry we are finding a free
+ ;; line for, it is used to compute the separations.
+ (do* ((line s (next-line line))
+ (nsep (line-separation p s) (1+ nsep)))
+ (())
+ (declare (fixnum line nsep))
+ (when (null (line-valid-p line wrappers)) ;If this line is empty or
+ (push line lines) ;invalid, just use it.
+ (return-from find-free))
+ (when (and wrappedp (>= line primary))
+ ;; have gone all the way around the cache, time to quit
+ (return-from find-free-cache-line (values primary nil)))
+ (let ((osep (line-separation (line-primary line) line)))
+ (when (>= osep limit)
+ (return-from find-free-cache-line (values primary nil)))
+ (when (cond ((= nsep limit) t)
+ ((= nsep osep)
+ (zerop (random 2 *pcl-misc-random-state*)))
+ ((> nsep osep) t)
+ (t nil))
+ ;; See whether we can displace what is in this line so that we
+ ;; can use the line.
+ (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t))
+ (setq p (line-primary line))
+ (setq s (next-line line))
+ (push line lines)
+ (return nil)))
+ (when (= line (the fixnum (1- (nlines)))) (setq wrappedp t)))))
;; Do all the displacing.
(loop
(when (null (cdr lines)) (return nil))
(let ((dline (pop lines))
- (line (car lines)))
- (declare (fixnum dline line))
- ;;Copy from line to dline (dline is known to be free).
- (let ((from-loc (line-location line))
- (to-loc (line-location dline))
- (cache-vector (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))))))
+ (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)
((8 16) 4)
(otherwise 6)))
-(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms
projects / sbcl.git / blobdiff