X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=64b53a963b462657e1dea849a5fd8a9f98e2636e;hb=4d50265fe5a3dd4ea5b35c8ec12fe2b88721d22c;hp=1f4af309b557ef2d9a8eb3be1cdd6fa086148ab9;hpb=ed7ba4dad8a79726fdfeba5aa12e276ea852c540;p=sbcl.git diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 1f4af30..64b53a9 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -268,18 +268,18 @@ ;;; 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 +;;; 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))) @@ -297,7 +297,7 @@ (setf (sb-kernel:layout-invalid wrapper) (if (eq new-value t) nil - new-value))) + new-value))) (defmacro wrapper-instance-slots-layout (wrapper) `(%wrapper-instance-slots-layout ,wrapper)) @@ -364,29 +364,37 @@ (aver layout) layout)))) -;;; FIXME: The immediately following macros could become inline functions. - -(defmacro first-wrapper-cache-number-index () - 0) +(defconstant +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))) +(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)) -(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) + (find-structure-class + (cl:class-name (sb-kernel:layout-class wrapper))))) ;;; The wrapper cache machinery provides general mechanism for ;;; trapping on the next access to any instance of a given class. This @@ -401,9 +409,9 @@ ;;; 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) + (neq (wrapper-state wrapper) t)) (defvar *previous-nwrappers* (make-hash-table)) @@ -420,8 +428,8 @@ ;; 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)) + (when (eq state :obsolete) + (setf (car previous) :obsolete)) (setf (cadr previous) nwrapper) (push previous new-previous)) @@ -435,16 +443,16 @@ (gethash nwrapper *previous-nwrappers*) new-previous))))) (defun check-wrapper-validity (instance) - (let* ((owrapper (wrapper-of instance)) - (state (wrapper-state owrapper))) - (if (eq state t) + (let* ((owrapper (wrapper-of instance))) + (if (not (invalid-wrapper-p owrapper)) owrapper - (let ((nwrapper + (let* ((state (wrapper-state owrapper)) + (nwrapper (ecase (car state) (:flush - (flush-cache-trap owrapper (cadr state) instance)) + (flush-cache-trap owrapper (cadr state) instance)) (:obsolete - (obsolete-instance-trap owrapper (cadr state) instance))))) + (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 @@ -460,13 +468,6 @@ ((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)))) (defvar *free-caches* nil) @@ -479,7 +480,7 @@ (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 @@ -493,7 +494,7 @@ 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*)) @@ -816,25 +817,23 @@ `(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)))) + (let ((required (let ((reversed-required nil)) + (dotimes (i (length metatypes)) + (push (dfun-arg-symbol i) reversed-required)) + (nreverse reversed-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))) ;;;; a comment from some PCL implementor: ;;;; Its too bad Common Lisp compilers freak out when you have a @@ -1353,19 +1352,11 @@ ;;; 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))) + (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))