X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=64b53a963b462657e1dea849a5fd8a9f98e2636e;hb=4d50265fe5a3dd4ea5b35c8ec12fe2b88721d22c;hp=f8f0f354095e0efe8eeb99cc45e853de167338b2;hpb=8eb6f7d3da3960c827b704e23b5a47008274be7d;p=sbcl.git diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index f8f0f35..64b53a9 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -189,7 +189,7 @@ #+sb-show (defun show-free-cache-vectors () (let ((elements ())) - (maphash #'(lambda (s e) (push (list s e) elements)) *free-cache-vectors*) + (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)) @@ -201,7 +201,7 @@ (setq head (cache-vector-ref head 0)) (incf free)) (format t - "~&There ~4D are caches of size ~4D. (~D free ~3D%)" + "~&There are ~4D caches of size ~4D. (~D free ~3D%)" allocated size free @@ -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*)) @@ -735,8 +736,8 @@ (let* (,@(when wrappers `((,wrappers (nreverse wrappers-rev)) (,classes (nreverse classes-rev)) - (,types (mapcar #'(lambda (class) - `(class-eq ,class)) + (,types (mapcar (lambda (class) + `(class-eq ,class)) ,classes))))) ,@body)))) @@ -757,32 +758,49 @@ (or (nth arg-number (the list *slot-vector-symbols*)) (intern (format nil ".SLOTS~A." arg-number) *pcl-package*))) +;; 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 +;; declare inline or something. --njf 2001-12-20 (defun make-dfun-lambda-list (metatypes applyp) - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i))) + (let ((lambda-list nil)) + (dotimes (i (length metatypes)) + (push (dfun-arg-symbol i) lambda-list)) (when applyp - (gather1 '&rest) - (gather1 '.dfun-rest-arg.)))) + (push '&rest lambda-list) + (push '.dfun-rest-arg. lambda-list)) + (nreverse lambda-list))) (defun make-dlap-lambda-list (metatypes applyp) - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i))) + (let ((lambda-list nil)) + (dotimes (i (length metatypes)) + (push (dfun-arg-symbol i) lambda-list)) + ;; FIXME: This is translated directly from the old PCL code. + ;; It didn't have a (PUSH '.DFUN-REST-ARG. LAMBDA-LIST) or + ;; something similar, so we don't either. It's hard to see how + ;; this could be correct, since &REST wants an argument after + ;; it. This function works correctly because the caller + ;; magically tacks on something after &REST. The calling functions + ;; (in dlisp.lisp) should be fixed and this function rewritten. + ;; --njf 2001-12-20 (when applyp - (gather1 '&rest)))) - + (push '&rest lambda-list)) + (nreverse lambda-list))) + +;; FIXME: The next four 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 +;; fix these too. --njf 2001-12-20 (defun make-emf-call (metatypes applyp fn-variable &optional emf-type) (let ((required - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i)))))) + (let ((required nil)) + (dotimes (i (length metatypes)) + (push (dfun-arg-symbol i) required)) + (nreverse required)))) `(,(if (eq emf-type 'fast-method-call) 'invoke-effective-method-function-fast 'invoke-effective-method-function) @@ -790,36 +808,32 @@ (defun make-dfun-call (metatypes applyp fn-variable) (let ((required - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i)))))) + (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 - (gathering1 (collecting) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i)))))) + (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) - (gathering1 (collecting) - (gather1 '.pv-cell.) - (gather1 '.next-method-call.) - (iterate ((i (interval :from 0)) - (s (list-elements metatypes))) - (progn s) - (gather1 (dfun-arg-symbol i))) + (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) reversed-lambda-list)) (when applyp - (gather1 '.dfun-rest-arg.)))) + (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 @@ -1003,12 +1017,12 @@ (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)))) + (macrolet ,(mapcar (lambda (fn) + `(,(car fn) ,(cadr fn) + `(let (,,@(mapcar (lambda (var) + ``(,',var ,,var)) + (cadr fn))) + ,@',(cddr fn)))) *local-cache-functions*) ,@body))) @@ -1068,7 +1082,7 @@ (sep (when home (line-separation home i)))) (when (and sep (> sep limit)) (error "bad cache ~S ~@ - value at location ~D: ~D lines from its home. The limit is ~D." + value at location ~W: ~W lines from its home. The limit is ~W." cache location sep limit)))) (setq location (next-location location)))))) @@ -1338,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))