;;;; specification.
(in-package "SB-PCL")
-\f
-;;; This file is (almost) functionally equivalent to dlap.lisp, but
-;;; easier to read.
-;;; Might generate faster code, too, depending on the compiler and
-;;; whether an implementation-specific lap assembler was used.
+
+;;;; 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.
+
+(declaim (list *dfun-arg-symbols*))
+(defvar *dfun-arg-symbols* '(.ARG0. .ARG1. .ARG2. .ARG3.))
+
+(defun dfun-arg-symbol (arg-number)
+ (or (nth arg-number *dfun-arg-symbols*)
+ (format-symbol *pcl-package* ".ARG~A." arg-number)))
+
+(declaim (list *slot-vector-symbols*))
+(defvar *slot-vector-symbols* '(.SLOTS0. .SLOTS1. .SLOTS2. .SLOTS3.))
+
+(defun slot-vector-symbol (arg-number)
+ (or (nth arg-number *slot-vector-symbols*)
+ (format-symbol *pcl-package* ".SLOTS~A." arg-number)))
+
+(declaim (inline make-dfun-required-args))
+(defun make-dfun-required-args (count)
+ (declare (type index count))
+ (let (result)
+ (dotimes (i count (nreverse result))
+ (push (dfun-arg-symbol i) result))))
+
+(defun make-dfun-lambda-list (nargs applyp)
+ (let ((required (make-dfun-required-args nargs)))
+ (if applyp
+ (nconc required
+ ;; Use &MORE arguments to avoid consing up an &REST list
+ ;; that we might not need at all. See MAKE-EMF-CALL and
+ ;; INVOKE-EFFECTIVE-METHOD-FUNCTION for the other
+ ;; pieces.
+ '(&more .dfun-more-context. .dfun-more-count.))
+ required)))
+
+(defun make-dlap-lambda-list (nargs applyp)
+ (let* ((required (make-dfun-required-args nargs))
+ (lambda-list (if applyp
+ (append required '(&more .more-context. .more-count.))
+ required)))
+ ;; Return the full lambda list, the required arguments, a form
+ ;; that will generate a rest-list, and a list of the &MORE
+ ;; parameters used.
+ (values lambda-list
+ required
+ (when applyp
+ '((sb-c::%listify-rest-args
+ .more-context.
+ (the (and unsigned-byte fixnum)
+ .more-count.))))
+ (when applyp
+ '(.more-context. .more-count.)))))
+
+(defun make-emf-call (nargs applyp fn-variable &optional emf-type)
+ (let ((required (make-dfun-required-args nargs)))
+ `(,(if (eq emf-type 'fast-method-call)
+ 'invoke-effective-method-function-fast
+ 'invoke-effective-method-function)
+ ,fn-variable
+ ,applyp
+ :required-args ,required
+ ;; INVOKE-EFFECTIVE-METHOD-FUNCTION will decide whether to use
+ ;; the :REST-ARG version or the :MORE-ARG version depending on
+ ;; the type of the EMF.
+ :rest-arg ,(if applyp
+ ;; Creates a list from the &MORE arguments.
+ '((sb-c::%listify-rest-args
+ .dfun-more-context.
+ (the (and unsigned-byte fixnum)
+ .dfun-more-count.)))
+ nil)
+ :more-arg ,(when applyp
+ '(.dfun-more-context. .dfun-more-count.)))))
+
+(defun make-fast-method-call-lambda-list (nargs applyp)
+ (list* '.pv. '.next-method-call. (make-dfun-lambda-list nargs applyp)))
+\f
+;;; Emitting various accessors.
(defun emit-one-class-reader (class-slot-p)
(emit-reader/writer :reader 1 class-slot-p))
;;; FIXME: What do these variables mean?
(defvar *precompiling-lap* nil)
-(defvar *emit-function-p* t)
-
-;;; FIXME: This variable is motivated by Gerd Moellman's observation,
-;;; in <867kga1wra.fsf@gerd.free-bsd.org> on cmucl-imp 2002-10-22,
-;;; that the functions returned from EMIT-xxx-FUNCTION can cause an
-;;; order-of-magnitude slowdown. We include this variable for now,
-;;; but maybe its effect should rather be controlled by compilation
-;;; policy if there is a noticeable space difference between the
-;;; branches, or else maybe the EMIT-xxx-FUNCTION branches should be
-;;; deleted. It's not clear to me how all of this works, though, so
-;;; until proper benchmarks are done it's probably safest simply to
-;;; have this pseudo-constant to hide code. -- CSR, 2003-02-14
-(defvar *optimize-cache-functions-p* t)
(defun emit-default-only (metatypes applyp)
- (unless *optimize-cache-functions-p*
- (when (and (null *precompiling-lap*) *emit-function-p*)
- (return-from emit-default-only
- (emit-default-only-function metatypes applyp))))
(multiple-value-bind (lambda-list args rest-arg more-arg)
- (make-dlap-lambda-list metatypes applyp)
+ (make-dlap-lambda-list (length metatypes) applyp)
(generating-lisp '(emf)
lambda-list
`(invoke-effective-method-function emf
;;; FSC-INSTANCE-P returns true on funcallable structures as well as
;;; PCL fins.
(defun emit-reader/writer (reader/writer 1-or-2-class class-slot-p)
- (unless *optimize-cache-functions-p*
- (when (and (null *precompiling-lap*) *emit-function-p*)
- (return-from emit-reader/writer
- (emit-reader/writer-function
- reader/writer 1-or-2-class class-slot-p))))
(let ((instance nil)
(arglist ())
(closure-variables ())
- (field +first-wrapper-cache-number-index+)
(read-form (emit-slot-read-form class-slot-p 'index 'slots)))
- ;;we need some field to do the fast obsolete check
(ecase reader/writer
((:reader :boundp)
(setq instance (dfun-arg-symbol 0)
(fsc-instance-wrapper ,instance)))))
(block access
(when (and wrapper
- (/= (wrapper-cache-number-vector-ref wrapper ,field) 0)
+ (not (zerop (layout-clos-hash wrapper)))
,@(if (eql 1 1-or-2-class)
`((eq wrapper wrapper-0))
`((or (eq wrapper wrapper-0)
(return-from access value)))))
(:boundp
`((let ((value ,read-form))
- (return-from access (not (eq value +slot-unbound+))))))
+ (return-from access (not (eq value +slot-unbound+))))))
(:writer
`((return-from access (setf ,read-form ,(car arglist)))))))
(funcall miss-fn ,@arglist))))))
(:writer `(setf ,read-form ,(car arglist))))))
(defmacro emit-reader/writer-macro (reader/writer 1-or-2-class class-slot-p)
- (let ((*emit-function-p* nil)
- (*precompiling-lap* t))
+ (let ((*precompiling-lap* t))
(values
(emit-reader/writer reader/writer 1-or-2-class class-slot-p))))
(defun emit-one-or-n-index-reader/writer (reader/writer
cached-index-p
class-slot-p)
- (unless *optimize-cache-functions-p*
- (when (and (null *precompiling-lap*) *emit-function-p*)
- (return-from emit-one-or-n-index-reader/writer
- (emit-one-or-n-index-reader/writer-function
- reader/writer cached-index-p class-slot-p))))
(multiple-value-bind (arglist metatypes)
(ecase reader/writer
((:reader :boundp)
arglist
`(let (,@(unless class-slot-p '(slots))
,@(when cached-index-p '(index)))
- ,(emit-dlap arglist metatypes
+ ,(emit-dlap 'cache arglist metatypes
(emit-slot-access reader/writer class-slot-p
'slots 'index 'miss-fn arglist)
`(funcall miss-fn ,@arglist)
(defmacro emit-one-or-n-index-reader/writer-macro
(reader/writer cached-index-p class-slot-p)
- (let ((*emit-function-p* nil)
- (*precompiling-lap* t))
+ (let ((*precompiling-lap* t))
(values
(emit-one-or-n-index-reader/writer reader/writer
cached-index-p
`(funcall ,miss-fn ,@args)))
(defun emit-checking-or-caching (cached-emf-p return-value-p metatypes applyp)
- (unless *optimize-cache-functions-p*
- (when (and (null *precompiling-lap*) *emit-function-p*)
- (return-from emit-checking-or-caching
- (emit-checking-or-caching-function
- cached-emf-p return-value-p metatypes applyp))))
(multiple-value-bind (lambda-list args rest-arg more-arg)
- (make-dlap-lambda-list metatypes applyp)
+ (make-dlap-lambda-list (length metatypes) applyp)
(generating-lisp
`(cache ,@(unless cached-emf-p '(emf)) miss-fn)
lambda-list
`(let (,@(when cached-emf-p '(emf)))
- ,(emit-dlap args
- metatypes
+ ,(emit-dlap 'cache args metatypes
(if return-value-p
(if cached-emf-p 'emf t)
`(invoke-effective-method-function
return-value-p
metatypes
applyp)
- (let ((*emit-function-p* nil)
- (*precompiling-lap* t))
+ (let ((*precompiling-lap* t))
(values
(emit-checking-or-caching cached-emf-p return-value-p metatypes applyp))))
-(defun emit-dlap (args metatypes hit miss value-reg &optional slot-regs)
+(defun emit-dlap (cache-var args metatypes hit-form miss-form value-var
+ &optional slot-vars)
(let* ((index -1)
+ (miss-tag (gensym "MISSED"))
(wrapper-bindings (mapcan (lambda (arg mt)
(unless (eq mt t)
(incf index)
"WRAPPER-~D"
index)
,(emit-fetch-wrapper
- mt arg 'miss (pop slot-regs))))))
+ mt arg miss-tag (pop slot-vars))))))
args metatypes))
- (wrappers (mapcar #'car wrapper-bindings)))
+ (wrapper-vars (mapcar #'car wrapper-bindings)))
(declare (fixnum index))
- (unless wrappers (error "Every metatype is T."))
- `(block dfun
- (tagbody
- (let ((field (cache-field cache))
- (cache-vector (cache-vector cache))
- (mask (cache-mask cache))
- (size (cache-size cache))
- (overflow (cache-overflow cache))
- ,@wrapper-bindings)
- (declare (fixnum size field mask))
- ,(cond ((cdr wrappers)
- (emit-greater-than-1-dlap wrappers 'miss value-reg))
- (value-reg
- (emit-1-t-dlap (car wrappers) 'miss value-reg))
- (t
- (emit-1-nil-dlap (car wrappers) 'miss)))
- (return-from dfun ,hit))
- miss
- (return-from dfun ,miss)))))
-
-(defun emit-1-nil-dlap (wrapper miss-label)
- `(let* ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
- miss-label))
- (location primary))
- (declare (fixnum primary location))
- (block search
- (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
- (return-from search nil))
- (setq location (the fixnum (+ location 1)))
- (when (= location size)
- (setq location 0))
- (when (= location primary)
- (dolist (entry overflow)
- (when (eq (car entry) ,wrapper)
- (return-from search nil)))
- (go ,miss-label))))))
-
-(defmacro get-cache-vector-lock-count (cache-vector)
- `(let ((lock-count (cache-vector-lock-count ,cache-vector)))
- (unless (typep lock-count 'fixnum)
- (error "My cache got freed somehow."))
- (the fixnum lock-count)))
-
-(defun emit-1-t-dlap (wrapper miss-label value)
- `(let ((primary ,(emit-1-wrapper-compute-primary-cache-location wrapper
- miss-label))
- (initial-lock-count (get-cache-vector-lock-count cache-vector)))
- (declare (fixnum primary initial-lock-count))
- (let ((location primary))
- (declare (fixnum location))
- (block search
- (loop (when (eq ,wrapper (cache-vector-ref cache-vector location))
- (setq ,value (cache-vector-ref cache-vector (1+ location)))
- (return-from search nil))
- (setq location (the fixnum (+ location 2)))
- (when (= location size)
- (setq location 0))
- (when (= location primary)
- (dolist (entry overflow)
- (when (eq (car entry) ,wrapper)
- (setq ,value (cdr entry))
- (return-from search nil)))
- (go ,miss-label))))
- (unless (= initial-lock-count
- (get-cache-vector-lock-count cache-vector))
- (go ,miss-label)))))
-
-(defun emit-greater-than-1-dlap (wrappers miss-label value)
- (declare (type list wrappers))
- (let ((cache-line-size (compute-line-size (+ (length wrappers)
- (if value 1 0)))))
- `(let ((primary 0)
- (size-1 (the fixnum (- size 1))))
- (declare (fixnum primary size-1))
- ,(emit-n-wrapper-compute-primary-cache-location wrappers miss-label)
- (let ((initial-lock-count (get-cache-vector-lock-count cache-vector)))
- (declare (fixnum initial-lock-count))
- (let ((location primary)
- (next-location 0))
- (declare (fixnum location next-location))
- (block search
- (loop (setq next-location
- (the fixnum (+ location ,cache-line-size)))
- (when (and ,@(mapcar
- (lambda (wrapper)
- `(eq ,wrapper
- (cache-vector-ref
- cache-vector
- (setq location
- (the fixnum (+ location 1))))))
- wrappers))
- ,@(when value
- `((setq location (the fixnum (+ location 1)))
- (setq ,value (cache-vector-ref cache-vector
- location))))
- (return-from search nil))
- (setq location next-location)
- (when (= location size-1)
- (setq location 0))
- (when (= location primary)
- (dolist (entry overflow)
- (let ((entry-wrappers (car entry)))
- (when (and ,@(mapcar (lambda (wrapper)
- `(eq ,wrapper
- (pop entry-wrappers)))
- wrappers))
- ,@(when value
- `((setq ,value (cdr entry))))
- (return-from search nil))))
- (go ,miss-label))))
- (unless (= initial-lock-count
- (get-cache-vector-lock-count cache-vector))
- (go ,miss-label)))))))
-
-(defun emit-1-wrapper-compute-primary-cache-location (wrapper miss-label)
- `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref ,wrapper field)))
- (declare (fixnum wrapper-cache-no))
- (when (zerop wrapper-cache-no) (go ,miss-label))
- ,(let ((form `(logand mask wrapper-cache-no)))
- `(the fixnum ,form))))
-
-(defun emit-n-wrapper-compute-primary-cache-location (wrappers miss-label)
- (declare (type list wrappers))
- ;; This returns 1 less that the actual location.
- `(progn
- ,@(let ((adds 0) (len (length wrappers)))
- (declare (fixnum adds len))
- (mapcar (lambda (wrapper)
- `(let ((wrapper-cache-no (wrapper-cache-number-vector-ref
- ,wrapper field)))
- (declare (fixnum wrapper-cache-no))
- (when (zerop wrapper-cache-no) (go ,miss-label))
- (setq primary (the fixnum (+ primary wrapper-cache-no)))
- ,@(progn
- (incf adds)
- (when (or (zerop (mod adds
- wrapper-cache-number-adds-ok))
- (eql adds len))
- `((setq primary
- ,(let ((form `(logand primary mask)))
- `(the fixnum ,form))))))))
- wrappers))))
-
-;;; CMU17 (and SBCL) note: Since STD-INSTANCE-P is weakened in the
-;;; CMU/SBCL approach of using funcallable instances, that branch may
-;;; run on non-pcl instances (structures). The result will be the
-;;; non-wrapper layout for the structure, which will cause a miss. The
-;;; "slots" will be whatever the first slot is, but will be ignored.
-;;; Similarly, FSC-INSTANCE-P returns true on funcallable structures
-;;; as well as PCL fins.
-(defun emit-fetch-wrapper (metatype argument miss-label &optional slot)
+ (unless wrapper-vars
+ (error "Every metatype is T."))
+ `(prog ()
+ (return
+ (let ,wrapper-bindings
+ ,(emit-cache-lookup cache-var wrapper-vars miss-tag value-var)
+ ,hit-form))
+ ,miss-tag
+ (return ,miss-form))))
+
+(defun emit-fetch-wrapper (metatype argument miss-tag &optional slot)
(ecase metatype
((standard-instance)
- `(cond ((std-instance-p ,argument)
- ,@(when slot `((setq ,slot (std-instance-slots ,argument))))
- (std-instance-wrapper ,argument))
- ((fsc-instance-p ,argument)
- ,@(when slot `((setq ,slot (fsc-instance-slots ,argument))))
- (fsc-instance-wrapper ,argument))
- (t
- (go ,miss-label))))
- (class
- (when slot (error "can't do a slot reg for this metatype"))
- `(wrapper-of-macro ,argument))
- ((built-in-instance structure-instance)
- (when slot (error "can't do a slot reg for this metatype"))
- `(built-in-or-structure-wrapper
- ,argument))))
-
+ ;; This branch may run on non-pcl instances (structures). The
+ ;; result will be the non-wrapper layout for the structure, which
+ ;; will cause a miss. Since refencing the structure is rather iffy
+ ;; if it should have no slots, or only raw slots, we use FOR-STD-CLASS-P
+ ;; to ensure that we have a wrapper.
+ ;;
+ ;; FIXME: If we unify layouts and wrappers we can use
+ ;; instance-slots-layout instead of for-std-class-p, as if there
+ ;; are no layouts there are no slots to worry about.
+ (with-unique-names (wrapper)
+ `(cond
+ ((std-instance-p ,argument)
+ (let ((,wrapper (std-instance-wrapper ,argument)))
+ ,@(when slot
+ `((when (layout-for-std-class-p ,wrapper)
+ (setq ,slot (std-instance-slots ,argument)))))
+ ,wrapper))
+ ((fsc-instance-p ,argument)
+ (let ((,wrapper (fsc-instance-wrapper ,argument)))
+ ,@(when slot
+ `((when (layout-for-std-class-p ,wrapper)
+ (setq ,slot (fsc-instance-slots ,argument)))))
+ ,wrapper))
+ (t (go ,miss-tag)))))
+ ;; Sep92 PCL used to distinguish between some of these cases (and
+ ;; spuriously exclude others). Since in SBCL
+ ;; WRAPPER-OF/LAYOUT-OF/BUILT-IN-OR-STRUCTURE-WRAPPER are all
+ ;; equivalent and inlined to each other, we can collapse some
+ ;; spurious differences.
+ ((class built-in-instance structure-instance condition-instance)
+ (when slot
+ (bug "SLOT requested for metatype ~S, but it isnt' going to happen."
+ metatype))
+ `(wrapper-of ,argument))
+ ;; a metatype of NIL should never be seen here, as NIL is only in
+ ;; the metatypes before a generic function is fully initialized.
+ ;; T should never be seen because we never need to get a wrapper
+ ;; to do dispatch if all methods have T as the respective
+ ;; specializer.
+ ((t nil)
+ (bug "~@<metatype ~S seen in ~S.~@:>" metatype 'emit-fetch-wrapper))))
projects / sbcl.git / blobdiff