'(.dfun-more-context. .dfun-more-count.)))))
(defun make-fast-method-call-lambda-list (nargs applyp)
- (list* '.pv-cell. '.next-method-call. (make-dfun-lambda-list nargs applyp)))
+ (list* '.pv. '.next-method-call. (make-dfun-lambda-list nargs applyp)))
\f
;;; Emitting various accessors.
;;; 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 (length metatypes) applyp)
(generating-lisp '(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 ())
(: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)
(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 (length metatypes) applyp)
(generating-lisp
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))))
,miss-tag
(return ,miss-form))))
-;;; 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-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-tag))))
+ ;; 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 (error "can't do a slot reg for this metatype"))
+ (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.
projects / sbcl.git / blobdiff