- (overflow nil :type list))
-
-#-sb-fluid (declaim (sb-ext:freeze-type cache))
-
-(defmacro cache-lock-count (cache)
- `(cache-vector-lock-count (cache-vector ,cache)))
-\f
-;;; some facilities for allocation and freeing caches as they are needed
-
-;;; This is done on the assumption that a better port of PCL will
-;;; arrange to cons these all in the same static area. Given that, the
-;;; fact that PCL tries to reuse them should be a win.
-
-(defvar *free-cache-vectors* (make-hash-table :size 16 :test 'eql))
-
-;;; Return a cache that has had FLUSH-CACHE-VECTOR-INTERNAL called on
-;;; it. This returns a cache of exactly the size requested, it won't
-;;; ever return a larger cache.
-(defun get-cache-vector (size)
- (let ((entry (gethash size *free-cache-vectors*)))
- (sb-sys:without-interrupts
- (cond ((null entry)
- (setf (gethash size *free-cache-vectors*) (cons 0 nil))
- (get-cache-vector size))
- ((null (cdr entry))
- (incf (car entry))
- (flush-cache-vector-internal (allocate-cache-vector size)))
- (t
- (let ((cache (cdr entry)))
- (setf (cdr entry) (cache-vector-ref cache 0))
- (flush-cache-vector-internal cache)))))))
-
-(defun free-cache-vector (cache-vector)
- (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
- (sb-sys:without-interrupts
- (if (null entry)
- (error
- "attempt to free a cache-vector not allocated by GET-CACHE-VECTOR")
- (let ((thread (cdr entry)))
- (loop (unless thread (return))
- (when (eq thread cache-vector)
- (error "freeing a cache twice"))
- (setq thread (cache-vector-ref thread 0)))
- (flush-cache-vector-internal cache-vector) ; to help the GC
- (setf (cache-vector-ref cache-vector 0) (cdr entry))
- (setf (cdr entry) cache-vector)
- nil)))))
-
-;;; This is just for debugging and analysis. It shows the state of the
-;;; free cache resource.
-#+sb-show
-(defun show-free-cache-vectors ()
- (let ((elements ()))
- (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))
- (entry (cadr e))
- (allocated (car entry))
- (head (cdr entry))
- (free 0))
- (loop (when (null head) (return t))
- (setq head (cache-vector-ref head 0))
- (incf free))
- (format t
- "~&There ~4D are caches of size ~4D. (~D free ~3D%)"
- allocated
- size
- free
- (floor (* 100 (/ free (float allocated)))))))))
-\f
-;;;; wrapper cache numbers
-
-;;; The constant WRAPPER-CACHE-NUMBER-ADDS-OK controls the number of
-;;; non-zero bits wrapper cache numbers will have.
-;;;
-;;; The value of this constant is the number of wrapper cache numbers
-;;; which can be added and still be certain the result will be a
-;;; fixnum. This is used by all the code that computes primary cache
-;;; locations from multiple wrappers.
-;;;
-;;; The value of this constant is used to derive the next two which
-;;; are the forms of this constant which it is more convenient for the
-;;; runtime code to use.
-(defconstant wrapper-cache-number-length
- (integer-length sb-kernel:layout-clos-hash-max))
-(defconstant wrapper-cache-number-mask sb-kernel:layout-clos-hash-max)
-(defconstant wrapper-cache-number-adds-ok
- (truncate most-positive-fixnum sb-kernel:layout-clos-hash-max))
-\f
-;;;; wrappers themselves
-
-;;; This caching algorithm requires that wrappers have more than one
-;;; wrapper cache number. You should think of these multiple numbers
-;;; as being in columns. That is, for a given cache, the same column
-;;; of wrapper cache numbers will be used.
-;;;
-;;; If at some point the cache distribution of a cache gets bad, the
-;;; cache can be rehashed by switching to a different column.
-;;;
-;;; The columns are referred to by field number which is that number
-;;; which, when used as a second argument to wrapper-ref, will return
-;;; that column of wrapper cache number.
-;;;
-;;; This code is written to allow flexibility as to how many wrapper
-;;; cache numbers will be in each wrapper, and where they will be
-;;; located. It is also set up to allow port specific modifications to
-;;; `pack' the wrapper cache numbers on machines where the addressing
-;;; modes make that a good idea.
-
-;;; In SBCL, as in CMU CL, we want to do type checking as early as
-;;; possible; structures help this. The structures are hard-wired to
-;;; have a fixed number of cache hash values, and that number must
-;;; correspond to the number of cache lines we use.
-(defconstant wrapper-cache-number-vector-length
- sb-kernel:layout-clos-hash-length)
-
-(unless (boundp '*the-class-t*)
- (setq *the-class-t* nil))
-
-(defmacro wrapper-class (wrapper)
- `(sb-kernel:class-pcl-class (sb-kernel:layout-class ,wrapper)))
-(defmacro wrapper-no-of-instance-slots (wrapper)
- `(sb-kernel:layout-length ,wrapper))
-
-;;; WRAPPER-STATE returns T (not generalized boolean, but T exactly)
-;;; iff the wrapper is valid. Any other return value denotes some
-;;; invalid state. Special conventions have been set up for certain
-;;; invalid states, e.g. obsoleteness or flushedness, but I (WHN
-;;; 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
-#-sb-fluid (declaim (inline wrapper-state (setf wrapper-state)))
-(defun wrapper-state (wrapper)
- (let ((invalid (sb-kernel:layout-invalid wrapper)))
- (cond ((null invalid)
- t)
- ((atom invalid)
- ;; some non-PCL object. INVALID is probably :INVALID. We
- ;; should arguably compute the new wrapper here instead of
- ;; returning NIL, but we don't bother, since
- ;; OBSOLETE-INSTANCE-TRAP can't use it.
- '(:obsolete nil))
- (t
- invalid))))
-(defun (setf wrapper-state) (new-value wrapper)
- (setf (sb-kernel:layout-invalid wrapper)
- (if (eq new-value t)
- nil
- new-value)))
-
-(defmacro wrapper-instance-slots-layout (wrapper)
- `(%wrapper-instance-slots-layout ,wrapper))
-(defmacro wrapper-class-slots (wrapper)
- `(%wrapper-class-slots ,wrapper))
-(defmacro wrapper-cache-number-vector (x) x)
-
-;;; This is called in BRAID when we are making wrappers for classes
-;;; whose slots are not initialized yet, and which may be built-in
-;;; classes. We pass in the class name in addition to the class.
-(defun boot-make-wrapper (length name &optional class)
- (let ((found (cl:find-class name nil)))
- (cond
- (found
- (unless (sb-kernel:class-pcl-class found)
- (setf (sb-kernel:class-pcl-class found) class))
- (aver (eq (sb-kernel:class-pcl-class found) class))
- (let ((layout (sb-kernel:class-layout found)))
- (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
-;;; 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
-;;; 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.
-(defun make-wrapper (length class)
- (cond
- ((typep class 'std-class)
- (make-wrapper-internal
- :length length
- :class
- (let ((owrap (class-wrapper class)))
- (cond (owrap
- (sb-kernel:layout-class owrap))
- ((*subtypep (class-of class)
- *the-class-standard-class*)
- (cond ((and *pcl-class-boot*
- (eq (slot-value class 'name) *pcl-class-boot*))
- (let ((found (cl:find-class (slot-value class 'name))))
- (unless (sb-kernel:class-pcl-class found)
- (setf (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))))
- (t
- (sb-kernel:make-random-pcl-class :pcl-class class))))))
- (t
- (let* ((found (cl:find-class (slot-value class 'name)))
- (layout (sb-kernel:class-layout found)))
- (unless (sb-kernel:class-pcl-class found)
- (setf (sb-kernel:class-pcl-class found) class))
- (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)
-
-(defmacro next-wrapper-cache-number-index (field-number)
- `(and (< ,field-number #.(1- wrapper-cache-number-vector-length))
- (1+ ,field-number)))
-
-(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))))))
-
-;;; The wrapper cache machinery provides general mechanism for
-;;; trapping on the next access to any instance of a given class. This
-;;; mechanism is used to implement the updating of instances when the
-;;; class is redefined (MAKE-INSTANCES-OBSOLETE). The same mechanism
-;;; is also used to update generic function caches when there is a
-;;; change to the superclasses of a class.
-;;;
-;;; Basically, a given wrapper can be valid or invalid. If it is
-;;; invalid, it means that any attempt to do a wrapper cache lookup
-;;; using the wrapper should trap. Also, methods on
-;;; 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))
-
-(defvar *previous-nwrappers* (make-hash-table))
-
-(defun invalidate-wrapper (owrapper state nwrapper)
- (ecase state
- ((:flush :obsolete)
- (let ((new-previous ()))
- ;; First off, a previous call to INVALIDATE-WRAPPER may have
- ;; recorded OWRAPPER as an NWRAPPER to update to. Since
- ;; OWRAPPER is about to be invalid, it no longer makes sense to
- ;; update to it.
- ;;
- ;; We go back and change the previously invalidated wrappers so
- ;; 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))
- (setf (cadr previous) nwrapper)
- (push previous new-previous))
-
- (let ((ocnv (wrapper-cache-number-vector owrapper)))
- (dotimes (i sb-kernel:layout-clos-hash-length)
- (setf (cache-number-vector-ref ocnv i) 0)))
- (push (setf (wrapper-state owrapper) (list state nwrapper))
- new-previous)
-
- (setf (gethash owrapper *previous-nwrappers*) ()
- (gethash nwrapper *previous-nwrappers*) new-previous)))))
-
-(defun check-wrapper-validity (instance)
- (let* ((owrapper (wrapper-of instance))
- (state (wrapper-state owrapper)))
- (if (eq state t)
- owrapper
- (let ((nwrapper
- (ecase (car state)
- (:flush
- (flush-cache-trap owrapper (cadr state) instance))
- (:obsolete
- (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
- ;; internal PCL code, and is not a user, this should be
- ;; needless. Also, since this directly slows down instance
- ;; update and generic function cache refilling, feel free to
- ;; take it out sometime soon.
- ;;
- ;; FIXME: We probably need to add a #+SB-PARANOID feature to
- ;; make stuff like this optional. Until then, it stays in.
- (cond ((neq nwrapper (wrapper-of instance))
- (error "wrapper returned from trap not wrapper of instance"))
- ((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)
-
-(defun get-cache (nkeys valuep limit-fn nlines)
- (let ((cache (or (sb-sys:without-interrupts (pop *free-caches*))
- (make-cache))))
- (declare (type cache cache))
- (multiple-value-bind (cache-mask actual-size line-size nlines)
- (compute-cache-parameters nkeys valuep nlines)
- (setf (cache-nkeys cache) nkeys
- (cache-valuep cache) valuep
- (cache-nlines cache) nlines
- (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-line-size cache) line-size
- (cache-max-location cache) (let ((line (1- nlines)))
- (if (= nkeys 1)
- (* line line-size)
- (1+ (* line line-size))))
- (cache-vector cache) (get-cache-vector actual-size)
- (cache-overflow cache) nil)
- cache)))
-
-(defun get-cache-from-cache (old-cache new-nlines
- &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*))
- (make-cache))))
- (declare (type cache cache))
- (multiple-value-bind (cache-mask actual-size line-size nlines)
- (if (= new-nlines (cache-nlines old-cache))
- (values (cache-mask old-cache) (cache-size old-cache)
- (cache-line-size old-cache) (cache-nlines old-cache))
- (compute-cache-parameters nkeys valuep new-nlines))
- (setf (cache-owner cache) (cache-owner old-cache)
- (cache-nkeys cache) nkeys
- (cache-valuep cache) valuep
- (cache-nlines cache) nlines
- (cache-field cache) new-field
- (cache-limit-fn cache) (cache-limit-fn old-cache)
- (cache-mask cache) cache-mask
- (cache-size cache) actual-size
- (cache-line-size cache) line-size
- (cache-max-location cache) (let ((line (1- nlines)))
- (if (= nkeys 1)
- (* line line-size)
- (1+ (* line line-size))))
- (cache-vector cache) (get-cache-vector actual-size)
- (cache-overflow cache) nil)
- cache)))
-
-(defun copy-cache (old-cache)
- (let* ((new-cache (copy-cache-internal old-cache))
- (size (cache-size old-cache))
- (old-vector (cache-vector old-cache))
- (new-vector (get-cache-vector size)))
- (declare (simple-vector old-vector new-vector))
- (dotimes-fixnum (i size)
- (setf (svref new-vector i) (svref old-vector i)))
- (setf (cache-vector new-cache) new-vector)
- new-cache))
-
-(defun free-cache (cache)
- (free-cache-vector (cache-vector cache))
- (setf (cache-vector cache) #())
- (setf (cache-owner cache) nil)
- (push cache *free-caches*)
- nil)
-
-(defun compute-line-size (x)
- (power-of-two-ceiling x))
-
-(defun compute-cache-parameters (nkeys valuep nlines-or-cache-vector)
- ;;(declare (values cache-mask actual-size line-size nlines))
- (declare (fixnum nkeys))
- (if (= nkeys 1)
- (let* ((line-size (if valuep 2 1))
- (cache-size (if (typep nlines-or-cache-vector 'fixnum)
- (the fixnum
- (* line-size
- (the fixnum
- (power-of-two-ceiling
- nlines-or-cache-vector))))
- (cache-vector-size nlines-or-cache-vector))))
- (declare (fixnum line-size cache-size))
- (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
- 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
- (* line-size
- (the fixnum
- (power-of-two-ceiling
- nlines-or-cache-vector))))
- (1- (cache-vector-size nlines-or-cache-vector)))))
- (declare (fixnum line-size cache-size))
- (values (logxor (the fixnum (1- cache-size)) (the fixnum (1- line-size)))
- (the fixnum (1+ 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
-;;; several implementations of the same algorithm.
-;;;
-;;; The algorithm is:
-;;;
-;;; SUM over the wrapper cache numbers,
-;;; ENSURING that the result is a fixnum
-;;; MASK the result against the mask argument.
-
-;;; 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)
-
- (declare (type field-type field) (fixnum mask))
- (if (not (listp wrappers))
- (logand mask
- (the fixnum (wrapper-cache-number-vector-ref wrappers field)))
- (let ((location 0) (i 0))
- (declare (fixnum location i))
- (dolist (wrapper wrappers)
- ;; First add the cache number of this wrapper to location.
- (let ((wrapper-cache-number (wrapper-cache-number-vector-ref wrapper
- field)))
- (declare (fixnum wrapper-cache-number))
- (if (zerop wrapper-cache-number)
- (return-from compute-primary-cache-location 0)
- (setq location
- (the fixnum (+ location wrapper-cache-number)))))
- ;; Then, if we are working with lots of wrappers, deal with
- ;; the wrapper-cache-number-mask stuff.
- (when (and (not (zerop i))
- (zerop (mod i wrapper-cache-number-adds-ok)))
- (setq location
- (logand location wrapper-cache-number-mask)))
- (incf i))
- (the fixnum (1+ (logand mask 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
-;;; is appropriate to displace a given cache entry.
-;;;
-;;; If this comes across a wrapper whose CACHE-NO is 0, it returns the
-;;; symbol invalid to suggest to its caller that it would be provident
-;;; to blow away the cache line in question.
-(defun compute-primary-cache-location-from-location (to-cache
- from-location
- &optional
- (from-cache to-cache))
- (declare (type cache to-cache from-cache) (fixnum from-location))
- (let ((result 0)
- (cache-vector (cache-vector from-cache))
- (field (cache-field to-cache))
- (mask (cache-mask to-cache))
- (nkeys (cache-nkeys to-cache)))
- (declare (type field-type field) (fixnum result mask nkeys)
- (simple-vector cache-vector))
- (dotimes-fixnum (i nkeys)
- (let* ((wrapper (cache-vector-ref cache-vector (+ i from-location)))
- (wcn (wrapper-cache-number-vector-ref wrapper field)))
- (declare (fixnum wcn))
- (setq result (+ result wcn)))
- (when (and (not (zerop i))
- (zerop (mod i wrapper-cache-number-adds-ok)))
- (setq result (logand result wrapper-cache-number-mask))))
- (if (= nkeys 1)
- (logand mask result)
- (the fixnum (1+ (logand mask result))))))
-\f
-;;; NIL means nothing so far, no actual arg info has NILs
-;;; in the metatype
-;;; CLASS seen all sorts of metaclasses
-;;; (specifically, more than one of the next 4 values)
-;;; T means everything so far is the class T
-;;; STANDARD-CLASS seen only standard classes
-;;; BUILT-IN-CLASS seen only built in classes
-;;; STRUCTURE-CLASS seen only structure classes
-(defun raise-metatype (metatype new-specializer)
- (let ((slot (find-class 'slot-class))
- (std (find-class 'std-class))
- (standard (find-class 'standard-class))
- (fsc (find-class 'funcallable-standard-class))
- (structure (find-class 'structure-class))
- (built-in (find-class 'built-in-class)))
- (flet ((specializer->metatype (x)
- (let ((meta-specializer
- (if (eq *boot-state* 'complete)
- (class-of (specializer-class x))
- (class-of x))))
- (cond ((eq x *the-class-t*) t)
- ((*subtypep meta-specializer std)
- 'standard-instance)
- ((*subtypep meta-specializer standard)
- 'standard-instance)
- ((*subtypep meta-specializer fsc)
- 'standard-instance)
- ((*subtypep meta-specializer structure)
- 'structure-instance)
- ((*subtypep meta-specializer built-in)
- 'built-in-instance)
- ((*subtypep meta-specializer slot)
- 'slot-instance)
- (t (error "PCL cannot handle the specializer ~S (meta-specializer ~S)."
- new-specializer
- meta-specializer))))))
- ;; We implement the following table. The notation is
- ;; that X and Y are distinct meta specializer names.
- ;;
- ;; NIL <anything> ===> <anything>
- ;; X X ===> X
- ;; X Y ===> CLASS
- (let ((new-metatype (specializer->metatype new-specializer)))
- (cond ((eq new-metatype 'slot-instance) 'class)
- ((null metatype) new-metatype)
- ((eq metatype new-metatype) new-metatype)
- (t 'class))))))
-
-(defmacro with-dfun-wrappers ((args metatypes)
- (dfun-wrappers invalid-wrapper-p
- &optional wrappers classes types)
- invalid-arguments-form
- &body body)
- `(let* ((args-tail ,args) (,invalid-wrapper-p nil) (invalid-arguments-p nil)
- (,dfun-wrappers nil) (dfun-wrappers-tail nil)
- ,@(when wrappers
- `((wrappers-rev nil) (types-rev nil) (classes-rev nil))))
- (dolist (mt ,metatypes)
- (unless args-tail
- (setq invalid-arguments-p t)
- (return nil))
- (let* ((arg (pop args-tail))
- (wrapper nil)
- ,@(when wrappers
- `((class *the-class-t*)
- (type t))))
- (unless (eq mt t)
- (setq wrapper (wrapper-of arg))
- (when (invalid-wrapper-p wrapper)
- (setq ,invalid-wrapper-p t)
- (setq wrapper (check-wrapper-validity arg)))
- (cond ((null ,dfun-wrappers)
- (setq ,dfun-wrappers wrapper))
- ((not (consp ,dfun-wrappers))
- (setq dfun-wrappers-tail (list wrapper))
- (setq ,dfun-wrappers (cons ,dfun-wrappers dfun-wrappers-tail)))
- (t
- (let ((new-dfun-wrappers-tail (list wrapper)))
- (setf (cdr dfun-wrappers-tail) new-dfun-wrappers-tail)
- (setf dfun-wrappers-tail new-dfun-wrappers-tail))))
- ,@(when wrappers
- `((setq class (wrapper-class* wrapper))
- (setq type `(class-eq ,class)))))
- ,@(when wrappers
- `((push wrapper wrappers-rev)
- (push class classes-rev)
- (push type types-rev)))))
- (if invalid-arguments-p
- ,invalid-arguments-form
- (let* (,@(when wrappers
- `((,wrappers (nreverse wrappers-rev))
- (,classes (nreverse classes-rev))
- (,types (mapcar #'(lambda (class)
- `(class-eq ,class))
- ,classes)))))
- ,@body))))
-\f
-;;;; some support stuff for getting a hold of symbols that we need when
-;;;; building the discriminator codes. It's OK for these to be interned
-;;;; symbols because we don't capture any user code in the scope in which
-;;;; these symbols are bound.
-
-(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
-
-(defun dfun-arg-symbol (arg-number)
- (or (nth arg-number (the list *dfun-arg-symbols*))
- (intern (format nil ".ARG~A." arg-number) *pcl-package*)))
-
-(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
-
-(defun slot-vector-symbol (arg-number)
- (or (nth arg-number (the list *slot-vector-symbols*))
- (intern (format nil ".SLOTS~A." arg-number) *pcl-package*)))
-
-(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)))
- (when applyp
- (gather1 '&rest)
- (gather1 '.dfun-rest-arg.))))
-
-(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)))
- (when applyp
- (gather1 '&rest))))
-
-(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))))))
- `(,(if (eq emf-type 'fast-method-call)
- 'invoke-effective-method-function-fast
- 'invoke-effective-method-function)
- ,fn-variable ,applyp ,@required ,@(when applyp `(.dfun-rest-arg.)))))
-
-(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))))))
- (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))))))
- (if applyp
- `(list* ,@required .dfun-rest-arg.)
- `(list ,@required))))