(in-package "SB-PCL")
\f
-;;; FIXME: SB-PCL should probably USE-PACKAGE SB-KERNEL, since SB-PCL
-;;; is built on SB-KERNEL, and in the absence of USE-PACKAGE, it ends
-;;; up using a thundering herd of explicit prefixes to get to
-;;; SB-KERNEL symbols. Using the SB-INT and SB-EXT packages as well
-;;; would help reduce prefixing and make it more natural to reuse
-;;; things (ONCE-ONLY, *KEYWORD-PACKAGE*..) used in the main body of
-;;; the system. However, that would cause a conflict between the
-;;; SB-ITERATE:ITERATE macro and the SB-INT:ITERATE macro. (This could
-;;; be resolved by renaming SB-INT:ITERATE to SB-INT:NAMED-LET, or
-;;; with more gruntwork by punting the SB-ITERATE package and
-;;; replacing calls to SB-ITERATE:ITERATE with calls to CL:LOOP.
-;;; So perhaps:
-;;; * Do some sort of automated check for overlap of symbols to make
-;;; sure there wouldn't be any other clashes.
-;;; * Rename SB-INT:ITERATE to SB-INT:NAMED-LET.
-;;; * Make SB-PCL use SB-INT and SB-EXT.
-;;; * Grep for SB-INT: and SB-EXT: prefixes in the pcl/ directory
-;;; and delete them.
-
;;; The caching algorithm implemented:
;;;
;;; << put a paper here >>
#+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))
(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
(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)
;;; 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)))
invalid))))
(defun (setf wrapper-state) (new-value wrapper)
(setf (sb-kernel:layout-invalid wrapper)
- (if (eq new-value 't)
+ (if (eq new-value t)
nil
- new-value)))
+ new-value)))
(defmacro wrapper-instance-slots-layout (wrapper)
`(%wrapper-instance-slots-layout ,wrapper))
(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)
(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))))
(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
;;; 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))
;; 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))
(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
((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))))
\f
(defvar *free-caches* nil)
(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
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*))
(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
(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))))))
\f
;;; the various implementations of computing a primary cache location from
;;; wrappers. Because some implementations of this must run fast there are
;;; 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)
(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
(wrapper nil)
,@(when wrappers
`((class *the-class-t*)
- (type 't))))
- (unless (eq mt 't)
+ (type t))))
+ (unless (eq mt t)
(setq wrapper (wrapper-of arg))
(when (invalid-wrapper-p wrapper)
(setq ,invalid-wrapper-p t)
(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))))
\f
(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)
(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)))
\f
;;;; a comment from some PCL implementor:
;;;; Its too bad Common Lisp compilers freak out when you have a
(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)))
(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))))))
;;; 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))