`(cache-vector-ref ,cache-vector 0))
(defun flush-cache-vector-internal (cache-vector)
- (sb-sys:without-interrupts
+ (with-pcl-lock
(fill (the simple-vector cache-vector) nil)
(setf (cache-vector-lock-count cache-vector) 0))
cache-vector)
(defmacro modify-cache (cache-vector &body body)
- `(sb-sys:without-interrupts
+ `(with-pcl-lock
(multiple-value-prog1
(progn ,@body)
(let ((old-count (cache-vector-lock-count ,cache-vector)))
1 (the fixnum (1+ old-count))))))))
(deftype field-type ()
- '(mod #.sb-kernel:layout-clos-hash-length))
+ '(mod #.layout-clos-hash-length))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defun power-of-two-ceiling (x)
(defmacro cache-lock-count (cache)
`(cache-vector-lock-count (cache-vector ,cache)))
\f
-;;; some facilities for allocation and freeing caches as they are needed
-
-;;; This is done on the assumption that a better port of PCL will
-;;; arrange to cons these all in the same static area. Given that, the
-;;; fact that PCL tries to reuse them should be a win.
-
-(defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql))
-
;;; Return a cache that has had FLUSH-CACHE-VECTOR-INTERNAL called on
;;; it. This returns a cache of exactly the size requested, it won't
;;; ever return a larger cache.
(defun get-cache-vector (size)
- (let ((entry (gethash size *free-cache-vectors*)))
- (sb-sys:without-interrupts
- (cond ((null entry)
- (setf (gethash size *free-cache-vectors*) (cons 0 nil))
- (get-cache-vector size))
- ((null (cdr entry))
- (incf (car entry))
- (flush-cache-vector-internal (allocate-cache-vector size)))
- (t
- (let ((cache (cdr entry)))
- (setf (cdr entry) (cache-vector-ref cache 0))
- (flush-cache-vector-internal cache)))))))
-
-(defun free-cache-vector (cache-vector)
- (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
- (sb-sys:without-interrupts
- (if (null entry)
- (error
- "attempt to free a cache-vector not allocated by GET-CACHE-VECTOR")
- (let ((thread (cdr entry)))
- (loop (unless thread (return))
- (when (eq thread cache-vector)
- (error "freeing a cache twice"))
- (setq thread (cache-vector-ref thread 0)))
- (flush-cache-vector-internal cache-vector) ; to help the GC
- (setf (cache-vector-ref cache-vector 0) (cdr entry))
- (setf (cdr entry) cache-vector)
- nil)))))
-
-;;; This is just for debugging and analysis. It shows the state of the
-;;; free cache resource.
-#+sb-show
-(defun show-free-cache-vectors ()
- (let ((elements ()))
- (maphash (lambda (s e) (push (list s e) elements)) *free-cache-vectors*)
- (setq elements (sort elements #'< :key #'car))
- (dolist (e elements)
- (let* ((size (car e))
- (entry (cadr e))
- (allocated (car entry))
- (head (cdr entry))
- (free 0))
- (loop (when (null head) (return t))
- (setq head (cache-vector-ref head 0))
- (incf free))
- (format t
- "~&There are ~4D caches of size ~4D. (~D free ~3D%)"
- allocated
- size
- free
- (floor (* 100 (/ free (float allocated)))))))))
+ (flush-cache-vector-internal (make-array size)))
+
\f
;;;; wrapper cache numbers
;;; are the forms of this constant which it is more convenient for the
;;; runtime code to use.
(defconstant wrapper-cache-number-length
- (integer-length sb-kernel:layout-clos-hash-max))
-(defconstant wrapper-cache-number-mask sb-kernel:layout-clos-hash-max)
+ (integer-length layout-clos-hash-max))
+(defconstant wrapper-cache-number-mask layout-clos-hash-max)
(defconstant wrapper-cache-number-adds-ok
- (truncate most-positive-fixnum sb-kernel:layout-clos-hash-max))
+ (truncate most-positive-fixnum layout-clos-hash-max))
\f
;;;; wrappers themselves
;;; have a fixed number of cache hash values, and that number must
;;; correspond to the number of cache lines we use.
(defconstant wrapper-cache-number-vector-length
- sb-kernel:layout-clos-hash-length)
+ layout-clos-hash-length)
(unless (boundp '*the-class-t*)
(setq *the-class-t* nil))
(defmacro wrapper-class (wrapper)
- `(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper)))
+ `(classoid-pcl-class (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)))
+ `(layout-length ,wrapper))
+;;; FIXME: Why are these macros?
(defmacro wrapper-instance-slots-layout (wrapper)
`(%wrapper-instance-slots-layout ,wrapper))
(defmacro wrapper-class-slots (wrapper)
;;; 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 (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 (classoid-pcl-class found)
+ (setf (classoid-pcl-class found) class))
+ (aver (eq (classoid-pcl-class found) class))
+ (let ((layout (classoid-layout found)))
(aver layout)
layout))
(t
(make-wrapper-internal
:length length
- :class (sb-kernel:make-standard-class :name name :pcl-class class))))))
+ :classoid (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
;;; 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
- (let ((owrap (class-wrapper class)))
- (cond (owrap
- (sb-kernel:layout-class owrap))
- ((*subtypep (class-of class)
- *the-class-standard-class*)
- (cond ((and *pcl-class-boot*
- (eq (slot-value class 'name) *pcl-class-boot*))
- (let ((found (cl:find-class (slot-value class 'name))))
- (unless (sb-kernel:class-pcl-class found)
- (setf (sb-kernel:class-pcl-class found) class))
- (aver (eq (sb-kernel:class-pcl-class found) class))
- found))
- (t
- (sb-kernel:make-standard-class :pcl-class class))))
- (t
- (sb-kernel:make-random-pcl-class :pcl-class class))))))
- (t
- (let* ((found (cl:find-class (slot-value class 'name)))
- (layout (sb-kernel:class-layout found)))
- (unless (sb-kernel:class-pcl-class found)
- (setf (sb-kernel:class-pcl-class found) class))
- (aver (eq (sb-kernel:class-pcl-class found) class))
- (aver layout)
- layout))))
-
-;;; FIXME: The immediately following macros could become inline functions.
-
-(defmacro 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)))
-
+ ((or (typep class 'std-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))))))
+ (t
+ (let* ((found (find-classoid (slot-value class 'name)))
+ (layout (classoid-layout found)))
+ (unless (classoid-pcl-class found)
+ (setf (classoid-pcl-class found) class))
+ (aver (eq (classoid-pcl-class found) class))
+ (aver layout)
+ layout))))
+
+(defconstant +first-wrapper-cache-number-index+ 0)
+
+(declaim (inline next-wrapper-cache-number-index))
+(defun next-wrapper-cache-number-index (field-number)
+ (and (< field-number #.(1- wrapper-cache-number-vector-length))
+ (1+ field-number)))
+
+;;; FIXME: Why are there two layers here, with one operator trivially
+;;; defined in terms of the other? It'd be nice either to have a
+;;; comment explaining why the separation is valuable, or to collapse
+;;; it into a single layer.
+;;;
+;;; FIXME (?): These are logically inline functions, but they need to
+;;; be SETFable, and for now it seems not worth the trouble to DEFUN
+;;; both inline FOO and inline (SETF FOO) for each one instead of a
+;;; single macro. Perhaps the best thing would be to make them
+;;; immutable (since it seems sort of surprising and gross to be able
+;;; to modify hash values) so that they can become inline functions
+;;; with no muss or fuss. I (WHN) didn't do this only because I didn't
+;;; know whether any code anywhere depends on the values being
+;;; modified.
(defmacro cache-number-vector-ref (cnv n)
`(wrapper-cache-number-vector-ref ,cnv ,n))
-
(defmacro wrapper-cache-number-vector-ref (wrapper n)
- `(sb-kernel:layout-clos-hash ,wrapper ,n))
+ `(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)
+ (ensure-non-standard-class
+ (classoid-name (layout-classoid wrapper)))))
;;; The wrapper cache machinery provides general mechanism for
;;; trapping on the next access to any instance of a given class. This
;;; 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 (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 layout-clos-hash-length)
+ (setf (cache-number-vector-ref ocnv i) 0)))
+
+ (push (setf (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)
- 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))))
+ (state (layout-invalid owrapper)))
+ (aver (not (eq state :uninitialized)))
+ (etypecase state
+ (null owrapper)
+ ;; FIXME: I can't help thinking that, while this does cure the
+ ;; symptoms observed from some class redefinitions, this isn't
+ ;; the place to be doing this flushing. Nevertheless... --
+ ;; CSR, 2003-05-31
+ ;;
+ ;; CMUCL comment:
+ ;; We assume in this case, that the :INVALID is from a
+ ;; previous call to REGISTER-LAYOUT for a superclass of
+ ;; INSTANCE's class. See also the comment above
+ ;; FORCE-CACHE-FLUSHES. Paul Dietz has test cases for this.
+ ((member t)
+ (force-cache-flushes (class-of instance))
+ (check-wrapper-validity instance))
+ (cons
+ (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 (layout-of instance))
+ (check-wrapper-validity instance)))
\f
-(defvar *free-caches* nil)
(defun get-cache (nkeys valuep limit-fn nlines)
- (let ((cache (or (sb-sys:without-interrupts (pop *free-caches*))
- (make-cache))))
+ (let ((cache (make-cache)))
(declare (type cache cache))
(multiple-value-bind (cache-mask actual-size line-size nlines)
(compute-cache-parameters nkeys valuep nlines)
(setf (cache-nkeys cache) nkeys
(cache-valuep cache) valuep
(cache-nlines cache) nlines
- (cache-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
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*))
- (make-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))
(setf (cache-vector new-cache) new-vector)
new-cache))
-(defun free-cache (cache)
- (free-cache-vector (cache-vector cache))
- (setf (cache-vector cache) #())
- (setf (cache-owner cache) nil)
- (push cache *free-caches*)
- nil)
-
(defun compute-line-size (x)
(power-of-two-ceiling x))
(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)))
(flet ((specializer->metatype (x)
(if (eq *boot-state* 'complete)
(class-of (specializer-class x))
(class-of x))))
- (cond ((eq x *the-class-t*) t)
- ((*subtypep meta-specializer std)
- 'standard-instance)
- ((*subtypep meta-specializer standard)
- 'standard-instance)
- ((*subtypep meta-specializer fsc)
- 'standard-instance)
- ((*subtypep meta-specializer structure)
- 'structure-instance)
- ((*subtypep meta-specializer built-in)
- 'built-in-instance)
- ((*subtypep meta-specializer slot)
- 'slot-instance)
- (t (error "PCL cannot handle the specializer ~S (meta-specializer ~S)."
- new-specializer
- meta-specializer))))))
+ (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 ~
+ (meta-specializer ~S).~@:>"
+ new-specializer
+ meta-specializer))))))
;; We implement the following table. The notation is
;; that X and Y are distinct meta specializer names.
;;
(defun dfun-arg-symbol (arg-number)
(or (nth arg-number (the list *dfun-arg-symbols*))
- (intern (format nil ".ARG~A." arg-number) *pcl-package*)))
+ (format-symbol *pcl-package* ".ARG~A." arg-number)))
(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
(defun slot-vector-symbol (arg-number)
(or (nth arg-number (the list *slot-vector-symbols*))
- (intern (format nil ".SLOTS~A." arg-number) *pcl-package*)))
+ (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 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))
(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
'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)))
\f
-;;;; 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
\f
;;; Here is where we actually fill, recache and expand caches.
;;;
;;; nice property of throwing out any entries that are invalid.
(defvar *cache-expand-threshold* 1.25)
-(defun fill-cache (cache wrappers value &optional free-cache-p)
-
+(defun fill-cache (cache wrappers value)
;; FILL-CACHE won't return if WRAPPERS is nil, might as well check..
- (unless wrappers
- (error "fill-cache: WRAPPERS arg is NIL!"))
+ (assert wrappers)
(or (fill-cache-p nil cache wrappers value)
- (and (< (ceiling (* (cache-count cache) 1.25))
+ (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 free-cache-p))
- (expand-cache cache wrappers value free-cache-p)))
+ (adjust-cache cache wrappers value))
+ (expand-cache cache wrappers value)))
(defvar *check-cache-p* nil)
;;; If this returns NIL, it means that it wasn't possible to find a
;;; wrapper field for which all of the entries could be put in the
;;; cache (within the limit).
-(defun adjust-cache (cache wrappers value free-old-cache-p)
+(defun adjust-cache (cache wrappers value)
(with-local-cache-functions (cache)
(let ((ncache (get-cache-from-cache cache (nlines) (field))))
- (do ((nfield (cache-field ncache) (next-wrapper-cache-number-index nfield)))
- ((null nfield) (free-cache ncache) nil)
+ (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))
(unless (try-one-fill (car wrappers+value) (cdr wrappers+value))
(return nil)))
(try-one-fill wrappers value))
- (progn (when free-old-cache-p (free-cache cache))
- (return (maybe-check-cache ncache)))
+ (return (maybe-check-cache ncache))
(flush-cache-vector-internal (cache-vector ncache))))))))
;;; returns: (values <cache>)
-(defun expand-cache (cache wrappers value free-old-cache-p)
+(defun expand-cache (cache wrappers value)
;;(declare (values cache))
(with-local-cache-functions (cache)
(let ((ncache (get-cache-from-cache cache (* (nlines) 2))))
(unless (fill-cache-from-cache-p nil ncache cache line)
(do-one-fill (line-wrappers line) (line-value line))))
(do-one-fill (wrappers value)
- (setq ncache (or (adjust-cache ncache wrappers value t)
+ (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)))
(do-one-fill (car wrappers+value) (cdr wrappers+value))))
(unless (try-one-fill wrappers value)
(do-one-fill wrappers value))
- (when free-old-cache-p (free-cache cache))
(maybe-check-cache ncache)))))
\f
;;; This is the heart of the cache filling mechanism. It implements
(otherwise 6)))
(defvar *empty-cache* (make-cache)) ; for defstruct slot initial value forms
-\f
-;;; 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))