`(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)))
(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
(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)
;;; 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
- :classoid
- (let ((owrap (class-wrapper class)))
- (cond (owrap
- (layout-classoid owrap))
- ((*subtypep (class-of class)
- *the-class-standard-class*)
- (cond ((and *pcl-class-boot*
- (eq (slot-value class 'name) *pcl-class-boot*))
- (let ((found (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))))
+ ((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)
(defun check-wrapper-validity (instance)
(let* ((owrapper (wrapper-of instance))
(state (layout-invalid owrapper)))
- (if (null state)
- owrapper
- (ecase (car state)
- (:flush
- (flush-cache-trap owrapper (cadr state) instance))
- (:obsolete
- (obsolete-instance-trap owrapper (cadr state) instance))))))
+ (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)
&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))
;;; 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))
(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
projects / sbcl.git / blobdiff