X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=3ed4110da915480eec8f22e69fd5cc11d3232962;hb=94ac5b7c3ff37850210b6fc9a7593cf1c5752993;hp=49641bcc60f4cde8fcccad873ccc20d2e41c38fc;hpb=13bb6d7a14d408cbf545968107fae797cd1cce77;p=sbcl.git diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index 49641bc..3ed4110 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 @@ -256,26 +256,6 @@ (unless (boundp '*the-class-t*) (setq *the-class-t* nil)) -;;; Note that for SBCL, as for CMU CL, the WRAPPER of a built-in or -;;; structure class will be some other kind of SB-KERNEL:LAYOUT, but -;;; this shouldn't matter, since the only two slots that WRAPPER adds -;;; are meaningless in those cases. -(defstruct (wrapper - (:include sb-kernel:layout - ;; KLUDGE: In CMU CL, the initialization default - ;; for LAYOUT-INVALID was NIL. In SBCL, that has - ;; changed to :UNINITIALIZED, but PCL code might - ;; still expect NIL for the initialization - ;; default of WRAPPER-INVALID. Instead of trying - ;; to find out, I just overrode the LAYOUT - ;; default here. -- WHN 19991204 - (invalid nil)) - (:conc-name %wrapper-) - (:constructor make-wrapper-internal)) - (instance-slots-layout nil :type list) - (class-slots nil :type list)) -#-sb-fluid (declaim (sb-ext:freeze-type wrapper)) - (defmacro wrapper-class (wrapper) `(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper))) (defmacro wrapper-no-of-instance-slots (wrapper) @@ -288,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))) @@ -317,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)) @@ -334,25 +314,25 @@ (found (unless (sb-kernel:class-pcl-class found) (setf (sb-kernel:class-pcl-class found) class)) - (assert (eq (sb-kernel:class-pcl-class found) class)) + (aver (eq (sb-kernel:class-pcl-class found) class)) (let ((layout (sb-kernel:class-layout found))) - (assert layout) + (aver layout) layout)) (t (make-wrapper-internal :length length :class (sb-kernel:make-standard-class :name name :pcl-class class)))))) -;;; The following variable may be set to a standard-class that has +;;; 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 -;;; by PCL. This allows standard-classes to be defined and used for +;;; by PCL. This allows STANDARD-CLASSes to be defined and used for ;;; type testing and dispatch before PCL is loaded. (defvar *pcl-class-boot* nil) ;;; 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 PCL::CLASS objects. (defun make-wrapper (length class) (cond ((typep class 'std-class) @@ -369,7 +349,7 @@ (let ((found (cl:find-class (slot-value class 'name)))) (unless (sb-kernel:class-pcl-class found) (setf (sb-kernel:class-pcl-class found) class)) - (assert (eq (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)))) @@ -380,33 +360,41 @@ (layout (sb-kernel:class-layout found))) (unless (sb-kernel:class-pcl-class found) (setf (sb-kernel:class-pcl-class found) class)) - (assert (eq (sb-kernel:class-pcl-class found) class)) - (assert layout) + (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) +(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 @@ -421,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)) @@ -440,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)) @@ -455,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 @@ -499,7 +487,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 @@ -513,7 +501,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*)) @@ -578,7 +566,7 @@ (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) cache-size line-size - (the fixnum (floor cache-size line-size)))) + (the (values fixnum t) (floor cache-size line-size)))) (let* ((line-size (power-of-two-ceiling (if valuep (1+ nkeys) nkeys))) (cache-size (if (typep nlines-or-cache-vector 'fixnum) (the fixnum @@ -591,7 +579,7 @@ (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size))) (the fixnum (1+ cache-size)) line-size - (the fixnum (floor cache-size line-size)))))) + (the (values fixnum t) (floor cache-size line-size)))))) ;;; the various implementations of computing a primary cache location from ;;; wrappers. Because some implementations of this must run fast there are @@ -603,8 +591,6 @@ ;;; ENSURING that the result is a fixnum ;;; MASK the result against the mask argument. -;;; COMPUTE-PRIMARY-CACHE-LOCATION -;;; ;;; The basic functional version. This is used by the cache miss code to ;;; compute the primary location of an entry. (defun compute-primary-cache-location (field mask wrappers) @@ -633,8 +619,6 @@ (incf i)) (the fixnum (1+ (logand mask location)))))) -;;; COMPUTE-PRIMARY-CACHE-LOCATION-FROM-LOCATION -;;; ;;; This version is called on a cache line. It fetches the wrappers ;;; from the cache line and determines the primary location. Various ;;; parts of the cache filling code call this to determine whether it @@ -759,8 +743,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)))) @@ -781,32 +765,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) @@ -814,36 +815,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 @@ -1027,12 +1024,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))) @@ -1092,7 +1089,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)))))) @@ -1362,19 +1359,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))