X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=fc923260bb79a35028bdd21d5f3bd1b3ecd6e2a2;hb=dc86450e18fb7b90bf6be7d8df8b8ebcb0d090f9;hp=006728f1ec17c0f1c7a7dcb019543a829b576ac6;hpb=9d04ed71f1631c18f863fdf52fe3f9a97cff6a96;p=sbcl.git diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 006728f..fc92326 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -96,13 +96,13 @@ `(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))) @@ -112,7 +112,7 @@ 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) @@ -143,69 +143,12 @@ (defmacro cache-lock-count (cache) `(cache-vector-lock-count (cache-vector ,cache))) -;;; 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))) + ;;;; wrapper cache numbers @@ -221,10 +164,10 @@ ;;; 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)) ;;;; wrappers themselves @@ -251,53 +194,15 @@ ;;; 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: We have removed the persistent use of this function throughout -;;; the PCL codebase, instead opting to use INVALID-WRAPPER-P, which -;;; abstractly tests the return result of this function for invalidness. -;;; However, part of the original comment that is still applicable follows. -;;; --njf, 2002-05-02 -;;; -;;; FIXME: 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)) (defmacro wrapper-instance-slots-layout (wrapper) `(%wrapper-instance-slots-layout ,wrapper)) @@ -309,19 +214,20 @@ ;;; whose slots are not initialized yet, and which may be built-in ;;; classes. We pass in the class name in addition to the class. (defun boot-make-wrapper (length name &optional class) - (let ((found (cl:find-class name nil))) + (let ((found (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 @@ -332,35 +238,36 @@ ;;; In SBCL, as in CMU CL, the layouts (a.k.a wrappers) for built-in ;;; and structure classes already exist when PCL is initialized, so we ;;; don't necessarily always make a wrapper. Also, we help maintain -;;; the mapping between CL:CLASS and PCL::CLASS objects. +;;; the mapping between CL:CLASS and SB-KERNEL:CLASSOID objects. (defun make-wrapper (length class) (cond ((typep class 'std-class) (make-wrapper-internal :length length - :class + :classoid (let ((owrap (class-wrapper class))) (cond (owrap - (sb-kernel:layout-class owrap)) + (layout-classoid owrap)) ((*subtypep (class-of class) *the-class-standard-class*) (cond ((and *pcl-class-boot* (eq (slot-value class 'name) *pcl-class-boot*)) - (let ((found (cl:find-class (slot-value class 'name)))) - (unless (sb-kernel:class-pcl-class found) - (setf (sb-kernel:class-pcl-class found) class)) - (aver (eq (sb-kernel:class-pcl-class found) class)) + (let ((found (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 - (sb-kernel:make-standard-class :pcl-class class)))) + (make-standard-classoid :pcl-class class)))) (t - (sb-kernel:make-random-pcl-class :pcl-class class)))))) + (make-random-pcl-classoid :pcl-class class)))))) (t - (let* ((found (cl:find-class (slot-value class 'name))) - (layout (sb-kernel:class-layout found))) - (unless (sb-kernel:class-pcl-class found) - (setf (sb-kernel:class-pcl-class found) class)) - (aver (eq (sb-kernel:class-pcl-class found) class)) + (let* ((found (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)))) @@ -388,13 +295,13 @@ (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)) (declaim (inline wrapper-class*)) (defun wrapper-class* (wrapper) (or (wrapper-class wrapper) - (find-structure-class - (cl:class-name (sb-kernel:layout-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 @@ -411,69 +318,56 @@ (declaim (inline invalid-wrapper-p)) (defun invalid-wrapper-p (wrapper) - (neq (wrapper-state wrapper) t)) + (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))) - (if (not (invalid-wrapper-p owrapper)) + (let* ((owrapper (wrapper-of instance)) + (state (layout-invalid owrapper))) + (if (null state) owrapper - (let* ((state (wrapper-state owrapper)) - (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)))) + (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))) -(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) @@ -497,8 +391,7 @@ &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)) @@ -533,13 +426,6 @@ (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)) @@ -657,6 +543,7 @@ (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) @@ -664,22 +551,19 @@ (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 "~@" + new-specializer + meta-specializer)))))) ;; We implement the following table. The notation is ;; that X and Y are distinct meta specializer names. ;; @@ -1035,19 +919,17 @@ ;;; 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) @@ -1206,11 +1088,12 @@ ;;; 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)) @@ -1224,12 +1107,11 @@ (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 ) -(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)))) @@ -1237,7 +1119,7 @@ (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))) @@ -1250,7 +1132,6 @@ (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))))) ;;; This is the heart of the cache filling mechanism. It implements