X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fcache.lisp;h=7fa0dd51d2b84551a53316a16033fb8c1a794663;hb=e8b69b1dd5564a4237b1bdc1060820c3b820cde2;hp=b41ab589903140a3ceb27fa31ef6b8ca4885adad;hpb=0b5610d8a220a4b20cbeac958953ca4d67c00038;p=sbcl.git diff --git a/src/pcl/cache.lisp b/src/pcl/cache.lisp index b41ab58..7fa0dd5 100644 --- a/src/pcl/cache.lisp +++ b/src/pcl/cache.lisp @@ -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,27 +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) - (:copier nil)) - (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) @@ -335,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) @@ -370,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)))) @@ -381,8 +360,8 @@ (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. @@ -579,7 +558,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 @@ -592,7 +571,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 @@ -604,8 +583,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) @@ -634,8 +611,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 @@ -782,32 +757,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) @@ -815,36 +807,34 @@ (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 nil)) + (dotimes (i (length metatypes)) + (push (dfun-arg-symbol i) required)) + (nreverse 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 ((lambda-list nil)) + (push '.pv-cell. lambda-list) + (push '.next-method-call. lambda-list) + (dotimes (i (length metatypes)) + (push (dfun-arg-symbol i) lambda-list)) (when applyp - (gather1 '.dfun-rest-arg.)))) + (push '.dfun-rest-arg. lambda-list)) + (nreverse lambda-list))) + ;;;; a comment from some PCL implementor: ;;;; Its too bad Common Lisp compilers freak out when you have a @@ -1093,7 +1083,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))))))