* enhancement: redefinition warnings for macros from different files. (lp#434657)
* enhancement: better MACHINE-VERSION on Darwin x86 and x86-64. (lp#668332)
* enhancement: (FORMAT "foo" ...) and similar signal a compile-time warning. (lp#327223)
+ * optimization: SLOT-VALUE &co are faster in the presence of SLOT-VALUE-USING-CLASS
+ and its compatriots.
* bug fix: SB-DEBUG:BACKTRACE-AS-LIST guards against potentially leaking
stack-allocated values out of their dynamic-extent. (lp#310175)
* bug fix: attempts to use SB-SPROF for wallclock profiling on threaded
(when (typep wrapper 'wrapper)
(setf (wrapper-instance-slots-layout wrapper)
- (mapcar #'canonical-slot-name slots))
+ (mapcar (lambda (slotd)
+ ;; T is the slot-definition-type.
+ (cons (canonical-slot-name slotd) t))
+ slots))
(setf (wrapper-class-slots wrapper)
()))
(set-val 'writers (get-val :writers))
(set-val 'allocation :instance)
(set-val '%type (or (get-val :type) t))
- (set-val '%type-check-function (get-val 'type-check-function))
(set-val '%documentation (or (get-val :documentation) ""))
(set-val '%class class)
(when effective-p
(set-val 'location index)
- (let ((fsc-p nil))
- (set-val 'reader-function (make-optimized-std-reader-method-function
- fsc-p nil slot-name index))
- (set-val 'writer-function (make-optimized-std-writer-method-function
- fsc-p nil slot-name index))
- (set-val 'boundp-function (make-optimized-std-boundp-method-function
- fsc-p nil slot-name index)))
- (set-val 'accessor-flags 7))
+ (set-val 'accessor-flags 7)
+ (set-val
+ 'info
+ (make-slot-info
+ :reader
+ (make-optimized-std-reader-method-function nil nil slot-name index)
+ :writer
+ (make-optimized-std-writer-method-function nil nil slot-name index)
+ :boundp
+ (make-optimized-std-boundp-method-function nil nil slot-name index))))
(when (and (eq name 'standard-class)
(eq slot-name 'slots) effective-p)
(setq *the-eslotd-standard-class-slots* slotd))
(let ((accessor (structure-slotd-accessor-symbol slotd)))
`(:name ,(structure-slotd-name slotd)
:defstruct-accessor-symbol ,accessor
- ,@(when (fboundp accessor)
- `(:internal-reader-function
- ,(structure-slotd-reader-function slotd)
- :internal-writer-function
- ,(structure-slotd-writer-function name slotd)))
+ :internal-reader-function ,(structure-slotd-reader-function slotd)
+ :internal-writer-function ,(structure-slotd-writer-function name slotd)
:type ,(or (structure-slotd-type slotd) t)
:initform ,(structure-slotd-init-form slotd)
:initfunction ,(eval-form (structure-slotd-init-form slotd)))))
((null head))
(unless (cdr (second head))
(setf (second head) (car (second head)))))
- (let* ((type-check-function
- (if (eq type t)
- nil
- `('type-check-function
- (named-lambda (slot-typecheck ,class-name ,name) (value)
- (declare (type ,type value)
- (optimize (sb-c:store-coverage-data 0)))
- value))))
- (canon `(:name ',name :readers ',readers :writers ',writers
- :initargs ',initargs
- ,@type-check-function
- ',others)))
+ (let ((canon `(:name ',name :readers ',readers :writers ',writers
+ :initargs ',initargs ',others)))
(push (if (eq initform unsupplied)
`(list* ,@canon)
`(list* :initfunction ,(make-initfunction initform)
(defun early-slot-definition-location (slotd)
(!bootstrap-get-slot 'standard-effective-slot-definition slotd 'location))
+(defun early-slot-definition-info (slotd)
+ (!bootstrap-get-slot 'standard-effective-slot-definition slotd 'info))
+
(defun early-accessor-method-slot-name (method)
(!bootstrap-get-slot 'standard-accessor-method method 'slot-name))
:initarg :initargs
:accessor slot-definition-initargs)
(%type :initform t :initarg :type :accessor slot-definition-type)
- (%type-check-function :initform nil
- :initarg type-check-function
- :accessor slot-definition-type-check-function)
(%documentation
:initform nil :initarg :documentation
;; KLUDGE: we need a reader for bootstrapping purposes, in
())
(defclass effective-slot-definition (slot-definition)
- ((reader-function ; (lambda (object) ...)
- :accessor slot-definition-reader-function)
- (writer-function ; (lambda (new-value object) ...)
- :accessor slot-definition-writer-function)
- (boundp-function ; (lambda (object) ...)
- :accessor slot-definition-boundp-function)
- (accessor-flags
- :initform 0)))
+ ((accessor-flags
+ :initform 0)
+ (info
+ :accessor slot-definition-info)))
+
+;;; We use a structure here, because fast slot-accesses to this information
+;;; are critical to making SLOT-VALUE-USING-CLASS &co fast: places that need
+;;; these functions can access the SLOT-INFO directly, avoiding the overhead
+;;; of accessing a standard-instance.
+(defstruct (slot-info (:constructor make-slot-info
+ (&key slotd
+ typecheck
+ (type t)
+ (reader
+ (uninitialized-accessor-function :reader slotd))
+ (writer
+ (uninitialized-accessor-function :writer slotd))
+ (boundp
+ (uninitialized-accessor-function :boundp slotd)))))
+ (typecheck nil :type (or null function))
+ (reader (missing-arg) :type function)
+ (writer (missing-arg) :type function)
+ (boundp (missing-arg) :type function))
(defclass standard-direct-slot-definition (standard-slot-definition
direct-slot-definition)
(defgeneric short-combination-operator (short-method-combination))
-(defgeneric slot-definition-boundp-function (effective-slot-definition))
-
(defgeneric slot-definition-class (slot-definition))
(defgeneric slot-definition-defstruct-accessor-symbol
(defgeneric slot-definition-name (slot-definition))
-(defgeneric slot-definition-reader-function (effective-slot-definition))
+(defgeneric slot-definition-info (effective-slot-definition))
(defgeneric slot-definition-readers (slot-definition))
(defgeneric slot-definition-type (slot-definition))
-(defgeneric slot-definition-writer-function (effective-slot-definition))
-
(defgeneric slot-definition-writers (slot-definition))
(defgeneric specializer-object (class-eq-specializer))
(defgeneric (setf slot-definition-allocation) (new-value
standard-slot-definition))
-(defgeneric (setf slot-definition-boundp-function)
- (new-value effective-slot-definition))
-
(defgeneric (setf slot-definition-class) (new-value slot-definition))
(defgeneric (setf slot-definition-defstruct-accessor-symbol)
(defgeneric (setf slot-definition-name) (new-value slot-definition))
-(defgeneric (setf slot-definition-reader-function) (new-value
- effective-slot-definition))
+(defgeneric (setf slot-definition-info) (new-value effective-slot-definition))
(defgeneric (setf slot-definition-readers) (new-value slot-definition))
(apply #'shared-initialize instance nil initargs)
instance)
+(defglobal **typecheck-cache** (make-hash-table :test #'equal))
+
+(defun generate-slotd-typecheck (slotd)
+ (let ((type (slot-definition-type slotd)))
+ (values
+ (when (and (neq t type) (safe-p (slot-definition-class slotd)))
+ (with-locked-hash-table (**typecheck-cache**)
+ (or (gethash type **typecheck-cache**)
+ (setf (gethash type **typecheck-cache**)
+ (handler-bind (((or style-warning compiler-note)
+ #'muffle-warning))
+ (funcall (compile
+ nil
+ `(lambda ()
+ (declare (optimize (sb-c:store-coverage-data 0)
+ (sb-c::type-check 3)
+ (sb-c::verify-arg-count 0)))
+ (named-lambda (slot-typecheck ,type) (value)
+ (the ,type value))))))))))
+ type)))
+
+(defmethod initialize-instance :after ((slotd effective-slot-definition) &key)
+ (setf (slot-definition-info slotd)
+ (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
+ (make-slot-info :slotd slotd
+ :typecheck typecheck))))
+
+;;; FIXME: Do we need (SETF SLOT-DEFINITION-TYPE) at all?
+(defmethod (setf slot-definition-type) :after (new-type (slotd effective-slot-definition))
+ (multiple-value-bind (typecheck type) (generate-slotd-typecheck slotd)
+ (setf (slot-info-typecheck (slot-definition-info slotd)) typecheck)))
+
(defmethod update-instance-for-different-class
((previous standard-object) (current standard-object) &rest initargs)
;; First we must compute the newly added slots. The spec defines
(member (dsd-name included-slot) slot-overrides :test #'eq))
collect slot)))))
+(defun uninitialized-accessor-function (type slotd)
+ (lambda (&rest args)
+ (declare (ignore args))
+ (error "~:(~A~) function~@[ for ~S ~] not yet initialized."
+ type slotd)))
+
(defun structure-slotd-name (slotd)
(dsd-name slotd))
(dsd-accessor-name slotd))
(defun structure-slotd-reader-function (slotd)
- (fdefinition (dsd-accessor-name slotd)))
+ (let ((name (dsd-accessor-name slotd)))
+ (if (fboundp name)
+ (fdefinition name)
+ (uninitialized-accessor-function :reader slotd))))
(defun structure-slotd-writer-function (type slotd)
(if (dsd-read-only slotd)
(let ((dd (find-defstruct-description type)))
(coerce (slot-setter-lambda-form dd slotd) 'function))
- (fdefinition `(setf ,(dsd-accessor-name slotd)))))
+ (let ((name `(setf ,(dsd-accessor-name slotd))))
+ (if (fboundp name)
+ (fdefinition name)
+ (uninitialized-accessor-function :writer slotd)))))
(defun structure-slotd-type (slotd)
(dsd-type slotd))
(warn "~@<Invalid qualifiers for ~S method combination ~
in method ~S:~2I~_~S.~@:>"
mc-name method qualifiers))))))
-
(unless skip-dfun-update-p
(update-ctors 'add-method
:generic-function generic-function
(defun slot-value-using-class-dfun (class object slotd)
(declare (ignore class))
- (function-funcall (slot-definition-reader-function slotd) object))
+ (funcall (slot-info-reader (slot-definition-info slotd)) object))
(defun setf-slot-value-using-class-dfun (new-value class object slotd)
(declare (ignore class))
- (function-funcall (slot-definition-writer-function slotd) new-value object))
+ (funcall (slot-info-writer (slot-definition-info slotd)) new-value object))
(defun slot-boundp-using-class-dfun (class object slotd)
(declare (ignore class))
- (function-funcall (slot-definition-boundp-function slotd) object))
+ (funcall (slot-info-boundp (slot-definition-info slotd)) object))
(defun special-case-for-compute-discriminating-function-p (gf)
(or (eq gf #'slot-value-using-class)
(writer (slot-definition-internal-writer-function slotd))
(boundp (make-structure-slot-boundp-function slotd))))
((condition-class-p class)
- (ecase name
- (reader (slot-definition-reader-function slotd))
- (writer (slot-definition-writer-function slotd))
- (boundp (slot-definition-boundp-function slotd))))
+ (let ((info (slot-definition-info slotd)))
+ (ecase name
+ (reader (slot-info-reader info))
+ (writer (slot-info-writer info))
+ (boundp (slot-info-boundp info)))))
(t
(let* ((fsc-p (cond ((standard-class-p class) nil)
((funcallable-standard-class-p class) t)
(instance-structure-protocol-error slotd 'slot-value-using-class))))
`(reader ,slot-name)))
-(defun make-optimized-std-writer-method-function
- (fsc-p slotd slot-name location)
+(defun make-optimized-std-writer-method-function (fsc-p slotd slot-name location)
(declare #.*optimize-speed*)
- (let* ((safe-p (and slotd
- (slot-definition-class slotd)
- (safe-p (slot-definition-class slotd))))
+ ;; The (WHEN SLOTD ...) gunk is for building early slot definitions.
+ (let* ((class (when slotd (slot-definition-class slotd)))
+ (safe-p (when slotd (safe-p class)))
+ (orig-wrapper (when safe-p (class-wrapper class)))
+ (info (when safe-p (slot-definition-info slotd)))
(writer-fun (etypecase location
+ ;; In SAFE-P case the typechecking already validated the instance.
(fixnum
(if fsc-p
+ (if safe-p
+ (lambda (nv instance)
+ (setf (clos-slots-ref (fsc-instance-slots instance)
+ location)
+ nv))
+ (lambda (nv instance)
+ (check-obsolete-instance instance)
+ (setf (clos-slots-ref (fsc-instance-slots instance)
+ location)
+ nv)))
+ (if safe-p
+ (lambda (nv instance)
+ (setf (clos-slots-ref (std-instance-slots instance)
+ location)
+ nv))
+ (lambda (nv instance)
+ (check-obsolete-instance instance)
+ (setf (clos-slots-ref (std-instance-slots instance)
+ location)
+ nv)))))
+ (cons
+ (if safe-p
(lambda (nv instance)
- (check-obsolete-instance instance)
- (setf (clos-slots-ref (fsc-instance-slots instance)
- location)
- nv))
+ (setf (cdr location) nv))
(lambda (nv instance)
(check-obsolete-instance instance)
- (setf (clos-slots-ref (std-instance-slots instance)
- location)
- nv))))
- (cons
- (lambda (nv instance)
- (check-obsolete-instance instance)
- (setf (cdr location) nv)))
+ (setf (cdr location) nv))))
(null
(lambda (nv instance)
(declare (ignore nv instance))
(instance-structure-protocol-error
slotd
'(setf slot-value-using-class))))))
- (checking-fun (lambda (new-value instance)
- ;; If we have a TYPE-CHECK-FUNCTION, call it.
- (let* (;; Note that the class of INSTANCE here is not
- ;; neccessarily the SLOT-DEFINITION-CLASS of
- ;; the SLOTD passed to M-O-S-W-M-F, since it's
- ;; e.g. possible for a subclass to define a
- ;; slot of the same name but with no accessors.
- ;; So we need to fetch the right type check function
- ;; from the wrapper instead of just closing over it.
- (wrapper (valid-wrapper-of instance))
- (type-check-function
- (cadr (find-slot-cell wrapper slot-name))))
- (declare (type (or function null) type-check-function))
- (when type-check-function
- (funcall type-check-function new-value)))
- ;; Then call the real writer.
- (funcall writer-fun new-value instance))))
+ (checking-fun (when safe-p
+ (lambda (new-value instance)
+ ;; If we have a TYPE-CHECK-FUNCTION, call it.
+ (let* (;; Note that the class of INSTANCE here is not
+ ;; neccessarily the SLOT-DEFINITION-CLASS of
+ ;; the SLOTD passed to M-O-S-W-M-F, since it's
+ ;; e.g. possible for a subclass to define a
+ ;; slot of the same name but with no
+ ;; accessors. So we may need to fetch the
+ ;; right SLOT-INFO from the wrapper instead of
+ ;; just closing over it.
+ (wrapper (valid-wrapper-of instance))
+ (typecheck
+ (slot-info-typecheck
+ (if (eq wrapper orig-wrapper)
+ info
+ (cdr (find-slot-cell wrapper slot-name))))))
+ (when typecheck
+ (funcall typecheck new-value)))
+ ;; Then call the real writer.
+ (funcall writer-fun new-value instance)))))
(set-fun-name (if safe-p
checking-fun
writer-fun)
(slot-definition-internal-writer-function slotd)))
(boundp (make-optimized-structure-slot-boundp-using-class-method-function))))
((condition-class-p class)
- (ecase name
- (reader
- (let ((fun (slot-definition-reader-function slotd)))
- (declare (type function fun))
- (lambda (class object slotd)
- (declare (ignore class slotd))
- (funcall fun object))))
- (writer
- (let ((fun (slot-definition-writer-function slotd)))
- (declare (type function fun))
- (lambda (new-value class object slotd)
- (declare (ignore class slotd))
- (funcall fun new-value object))))
- (boundp
- (let ((fun (slot-definition-boundp-function slotd)))
- (declare (type function fun))
- (lambda (class object slotd)
- (declare (ignore class slotd))
- (funcall fun object))))))
+ (let ((info (slot-definition-info slotd)))
+ (ecase name
+ (reader
+ (let ((fun (slot-info-reader info)))
+ (lambda (class object slotd)
+ (declare (ignore class slotd))
+ (funcall fun object))))
+ (writer
+ (let ((fun (slot-info-writer info)))
+ (lambda (new-value class object slotd)
+ (declare (ignore class slotd))
+ (funcall fun new-value object))))
+ (boundp
+ (let ((fun (slot-info-boundp info)))
+ (lambda (class object slotd)
+ (declare (ignore class slotd))
+ (funcall fun object)))))))
(t
(let* ((fsc-p (cond ((standard-class-p class) nil)
((funcallable-standard-class-p class) t)
(defun make-optimized-std-setf-slot-value-using-class-method-function
(fsc-p slotd)
(declare #.*optimize-speed*)
- (let ((location (slot-definition-location slotd))
- (type-check-function
- (when (and slotd
- (slot-definition-class slotd)
- (safe-p (slot-definition-class slotd)))
- (slot-definition-type-check-function slotd))))
+ (let* ((location (slot-definition-location slotd))
+ (class (slot-definition-class slotd))
+ (typecheck
+ (when (safe-p class)
+ (slot-info-typecheck (slot-definition-info slotd)))))
(macrolet ((make-mf-lambda (&body body)
`(lambda (nv class instance slotd)
(declare (ignore class slotd))
;; Having separate lambdas for the NULL / not-NULL cases of
;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead
;; for CLOS typechecking when it's not in use.
- `(if type-check-function
+ `(if typecheck
(make-mf-lambda
- (funcall (the function type-check-function) nv)
+ (funcall (the function typecheck) nv)
,@body)
(make-mf-lambda
,@body))))
(emf-funcall sdfun class instance slotd))))
`(,name ,(class-name class) ,(slot-definition-name slotd)))))
\f
+(defun maybe-class (class-or-name)
+ (when (eq **boot-state** 'complete)
+ (if (typep class-or-name 'class)
+ class-or-name
+ (find-class class-or-name nil))))
+
(defun make-std-reader-method-function (class-or-name slot-name)
(declare (ignore class-or-name))
- (let* ((initargs (copy-tree
- (make-method-function
- (lambda (instance)
- (pv-binding1 ((bug "Please report this")
- (instance) (instance-slots))
- (instance-read-internal
- .pv. instance-slots 0
- (slot-value instance slot-name))))))))
- (setf (getf (getf initargs 'plist) :slot-name-lists)
- (list (list nil slot-name)))
- initargs))
+ (ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'reader t)
+ (:standard
+ (let* ((initargs (copy-tree
+ (make-method-function
+ (lambda (instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) (instance-slots))
+ (instance-read-standard
+ .pv. instance-slots 0
+ (slot-value instance slot-name))))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list (list nil slot-name)))
+ initargs))
+ ((:custom :accessor)
+ (let* ((initargs (copy-tree
+ (make-method-function
+ (lambda (instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) nil)
+ (instance-read-custom .pv. 0 instance)))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list (list nil slot-name)))
+ initargs))))
(defun make-std-writer-method-function (class-or-name slot-name)
- (let* ((class (when (eq **boot-state** 'complete)
- (if (typep class-or-name 'class)
- class-or-name
- (find-class class-or-name nil))))
- (safe-p (and class
- (safe-p class)))
- (check-fun (lambda (new-value instance)
- (let* ((class (class-of instance))
- (slotd (find-slot-definition class slot-name))
- (type-check-function
- (when slotd
- (slot-definition-type-check-function slotd))))
- (when type-check-function
- (funcall type-check-function new-value)))))
- (initargs (copy-tree
- (if safe-p
- (make-method-function
- (lambda (nv instance)
- (funcall check-fun nv instance)
- (pv-binding1 ((bug "Please report this")
- (instance) (instance-slots))
- (instance-write-internal
- .pv. instance-slots 0 nv
- (setf (slot-value instance slot-name) nv)))))
- (make-method-function
- (lambda (nv instance)
- (pv-binding1 ((bug "Please report this")
- (instance) (instance-slots))
- (instance-write-internal
- .pv. instance-slots 0 nv
- (setf (slot-value instance slot-name) nv)))))))))
- (setf (getf (getf initargs 'plist) :slot-name-lists)
- (list nil (list nil slot-name)))
- initargs))
+ (let ((class (maybe-class class-or-name)))
+ (ecase (slot-access-strategy class slot-name 'writer t)
+ (:standard
+ (let ((initargs (copy-tree
+ (if (and class (safe-p class))
+ (make-method-function
+ (lambda (nv instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) (instance-slots))
+ (instance-write-standard
+ .pv. instance-slots 0 nv
+ (setf (slot-value instance slot-name) .good-new-value.)
+ nil t))))
+ (make-method-function
+ (lambda (nv instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) (instance-slots))
+ (instance-write-standard
+ .pv. instance-slots 0 nv
+ (setf (slot-value instance slot-name) .good-new-value.)))))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list nil (list nil slot-name)))
+ initargs))
+ ((:custom :accessor)
+ (let ((initargs (copy-tree
+ (make-method-function
+ (lambda (nv instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) nil)
+ (instance-write-custom .pv. 0 instance nv)))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list nil (list nil slot-name)))
+ initargs)))))
(defun make-std-boundp-method-function (class-or-name slot-name)
(declare (ignore class-or-name))
- (let* ((initargs (copy-tree
- (make-method-function
- (lambda (instance)
- (pv-binding1 ((bug "Please report this")
- (instance) (instance-slots))
- (instance-boundp-internal
- .pv. instance-slots 0
- (slot-boundp instance slot-name))))))))
- (setf (getf (getf initargs 'plist) :slot-name-lists)
- (list (list nil slot-name)))
- initargs))
+ (ecase (slot-access-strategy (maybe-class class-or-name) slot-name 'boundp t)
+ (:standard
+ (let ((initargs (copy-tree
+ (make-method-function
+ (lambda (instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) (instance-slots))
+ (instance-boundp-standard
+ .pv. instance-slots 0
+ (slot-boundp instance slot-name))))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list (list nil slot-name)))
+ initargs))
+ ((:custom :accessor)
+ (let ((initargs (copy-tree
+ (make-method-function
+ (lambda (instance)
+ (pv-binding1 ((bug "Please report this")
+ (instance) nil)
+ (instance-boundp-custom .pv. 0 instance)))))))
+ (setf (getf (getf initargs 'plist) :slot-name-lists)
+ (list (list nil slot-name)))
+ initargs))))
\f
;;;; FINDING SLOT DEFINITIONS
;;;
;;; generic instead of checking versus STANDARD-CLASS and
;;; FUNCALLABLE-STANDARD-CLASS.
-(defun find-slot-definition (class slot-name)
- (dolist (slotd (class-slots class))
+(defun find-slot-definition (class slot-name &optional errorp)
+ (unless (class-finalized-p class)
+ (or (try-finalize-inheritance class)
+ (if errorp
+ (error "Cannot look up slot-definition for ~S in ~S (too early to finalize.)"
+ slot-name class)
+ (return-from find-slot-definition (values nil nil)))))
+ (dolist (slotd (class-slots class)
+ (if errorp
+ (error "No slot called ~S in ~S." slot-name class)
+ (values nil t)))
(when (eq slot-name (slot-definition-name slotd))
- (return slotd))))
+ (return (values slotd t)))))
(defun find-slot-cell (wrapper slot-name)
(declare (symbol slot-name))
(defun make-slot-table (class slots &optional bootstrap)
(let* ((n (+ (length slots) 2))
- (vector (make-array n :initial-element nil))
- (save-slot-location-p
- (or bootstrap
- (when (eq 'complete **boot-state**)
- (let ((metaclass (class-of class)))
- (or (eq metaclass *the-class-standard-class*)
- (eq metaclass *the-class-funcallable-standard-class*))))))
- (save-type-check-function-p
- (unless bootstrap
- (and (eq 'complete **boot-state**) (safe-p class)))))
+ (vector (make-array n :initial-element nil)))
(flet ((add-to-vector (name slot)
(declare (symbol name)
(optimize (sb-c::insert-array-bounds-checks 0)))
(let ((index (rem (sxhash name) n)))
(setf (svref vector index)
- (list* name (list* (when save-slot-location-p
- (if bootstrap
- (early-slot-definition-location slot)
- (slot-definition-location slot)))
- (when save-type-check-function-p
- (slot-definition-type-check-function slot))
- slot)
+ (list* name
+ (cons (when (or bootstrap
+ (and (standard-class-p class)
+ (slot-accessor-std-p slot 'all)))
+ (if bootstrap
+ (early-slot-definition-location slot)
+ (slot-definition-location slot)))
+ (the slot-info
+ (if bootstrap
+ (early-slot-definition-info slot)
+ (slot-definition-info slot))))
(svref vector index))))))
(if (eq 'complete **boot-state**)
- (dolist (slot slots)
- (add-to-vector (slot-definition-name slot) slot))
- (dolist (slot slots)
- (add-to-vector (early-slot-definition-name slot) slot))))
+ (dolist (slot slots)
+ (add-to-vector (slot-definition-name slot) slot))
+ (dolist (slot slots)
+ (add-to-vector (early-slot-definition-name slot) slot))))
vector))
(declaim (ftype (sfunction (t symbol) t) slot-value))
(defun slot-value (object slot-name)
(let* ((wrapper (valid-wrapper-of object))
- (cell (find-slot-cell wrapper slot-name))
+ (cell (or (find-slot-cell wrapper slot-name)
+ (return-from slot-value
+ (values (slot-missing (wrapper-class* wrapper) object slot-name
+ 'slot-value)))))
(location (car cell))
(value
(cond ((fixnump location)
(funcallable-standard-instance-access object location)))
((consp location)
(cdr location))
- ((not cell)
- (return-from slot-value
- (values (slot-missing (wrapper-class* wrapper) object slot-name
- 'slot-value))))
((not location)
(return-from slot-value
- (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))))
+ (funcall (slot-info-reader (cdr cell)) object)))
(t
(bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
(if (eq +slot-unbound+ value)
(defun set-slot-value (object slot-name new-value)
(let* ((wrapper (valid-wrapper-of object))
- (cell (find-slot-cell wrapper slot-name))
+ (cell (or (find-slot-cell wrapper slot-name)
+ (return-from set-slot-value
+ (values (slot-missing (wrapper-class* wrapper) object slot-name
+ 'setf new-value)))))
(location (car cell))
- (type-check-function (cadr cell)))
- (when type-check-function
- (funcall (the function type-check-function) new-value))
+ (info (cdr cell))
+ (typecheck (slot-info-typecheck info)))
+ (when typecheck
+ (funcall typecheck new-value))
(cond ((fixnump location)
(if (std-instance-p object)
(setf (standard-instance-access object location) new-value)
new-value)))
((consp location)
(setf (cdr location) new-value))
- ((not cell)
- (slot-missing (wrapper-class* wrapper) object slot-name 'setf new-value))
((not location)
- (setf (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))
- new-value))
+ (funcall (slot-info-writer info) new-value object))
(t
(bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
new-value)
(defun slot-boundp (object slot-name)
(let* ((wrapper (valid-wrapper-of object))
- (cell (find-slot-cell wrapper slot-name))
+ (cell (or (find-slot-cell wrapper slot-name)
+ (return-from slot-boundp
+ (and (slot-missing (wrapper-class* wrapper) object slot-name
+ 'slot-boundp)
+ t))))
(location (car cell))
(value
(cond ((fixnump location)
(funcallable-standard-instance-access object location)))
((consp location)
(cdr location))
- ((not cell)
- (return-from slot-boundp
- (and (slot-missing (wrapper-class* wrapper) object slot-name
- 'slot-boundp)
- t)))
((not location)
(return-from slot-boundp
- (slot-boundp-using-class (wrapper-class* wrapper) object (cddr cell))))
+ (funcall (slot-info-boundp (cdr cell)) object)))
(t
(bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
(not (eq +slot-unbound+ value))))
((not cell)
(slot-missing (wrapper-class* wrapper) object slot-name 'slot-makunbound))
((not location)
- (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell)))
+ (let ((class (wrapper-class* wrapper)))
+ (slot-makunbound-using-class class object (find-slot-definition class slot-name))))
(t
(bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell))))
object)
;; FIXME: Do we need this? SET-SLOT-VALUE checks for obsolete
;; instances. Are users allowed to call this directly?
(check-obsolete-instance object)
- (let ((location (slot-definition-location slotd))
- (type-check-function
- (when (safe-p class)
- (slot-definition-type-check-function slotd))))
- (flet ((check (new-value)
- (when type-check-function
- (funcall (the function type-check-function) new-value))
- new-value))
- (typecase location
- (fixnum
- (cond ((std-instance-p object)
- (setf (clos-slots-ref (std-instance-slots object) location)
- (check new-value)))
- ((fsc-instance-p object)
- (setf (clos-slots-ref (fsc-instance-slots object) location)
- (check new-value)))
- (t (bug "unrecognized instance type in ~S"
- '(setf slot-value-using-class)))))
- (cons
- (setf (cdr location) (check new-value)))
- (t
- (instance-structure-protocol-error
- slotd '(setf slot-value-using-class)))))))
+ (let* ((info (slot-definition-info slotd))
+ (location (slot-definition-location slotd))
+ (typecheck (slot-info-typecheck info))
+ (new-value (if typecheck
+ (funcall (the function typecheck) new-value)
+ new-value)))
+ (typecase location
+ (fixnum
+ (cond ((std-instance-p object)
+ (setf (clos-slots-ref (std-instance-slots object) location)
+ new-value))
+ ((fsc-instance-p object)
+ (setf (clos-slots-ref (fsc-instance-slots object) location)
+ new-value))
+ (t (bug "unrecognized instance type in ~S"
+ '(setf slot-value-using-class)))))
+ (cons
+ (setf (cdr location) new-value))
+ (t
+ (instance-structure-protocol-error
+ slotd '(setf slot-value-using-class))))))
(defmethod slot-boundp-using-class
((class std-class)
((class condition-class)
(object condition)
(slotd condition-effective-slot-definition))
- (let ((fun (slot-definition-reader-function slotd)))
- (declare (type function fun))
+ (let ((fun (slot-info-reader (slot-definition-info slotd))))
(funcall fun object)))
(defmethod (setf slot-value-using-class)
(class condition-class)
(object condition)
(slotd condition-effective-slot-definition))
- (let ((fun (slot-definition-writer-function slotd)))
- (declare (type function fun))
+ (let ((fun (slot-info-writer (slot-definition-info slotd))))
(funcall fun new-value object)))
(defmethod slot-boundp-using-class
((class condition-class)
(object condition)
(slotd condition-effective-slot-definition))
- (let ((fun (slot-definition-boundp-function slotd)))
- (declare (type function fun))
+ (let ((fun (slot-info-boundp (slot-definition-info slotd))))
(funcall fun object)))
(defmethod slot-makunbound-using-class ((class condition-class) object slot)
instance
(etypecase position
(fixnum
- (nth position (wrapper-instance-slots-layout (wrapper-of instance))))
+ (car (nth position (wrapper-instance-slots-layout (wrapper-of instance)))))
(cons
(car position))))))
\f
(in-package "SB-PCL")
\f
(defmethod slot-accessor-function ((slotd effective-slot-definition) type)
- (ecase type
- (reader (slot-definition-reader-function slotd))
- (writer (slot-definition-writer-function slotd))
- (boundp (slot-definition-boundp-function slotd))))
+ (let ((info (slot-definition-info slotd)))
+ (ecase type
+ (reader (slot-info-reader info))
+ (writer (slot-info-writer info))
+ (boundp (slot-info-boundp info)))))
(defmethod (setf slot-accessor-function) (function
(slotd effective-slot-definition)
type)
- (ecase type
- (reader (setf (slot-definition-reader-function slotd) function))
- (writer (setf (slot-definition-writer-function slotd) function))
- (boundp (setf (slot-definition-boundp-function slotd) function))))
+ (let ((info (slot-definition-info slotd)))
+ (ecase type
+ (reader (setf (slot-info-reader info) function))
+ (writer (setf (slot-info-writer info) function))
+ (boundp (setf (slot-info-boundp info) function)))))
(defconstant +slotd-reader-function-std-p+ 1)
(defconstant +slotd-writer-function-std-p+ 2)
(null (cdr methods))))
(setf (slot-accessor-function slotd type)
(lambda (&rest args)
+ (declare (dynamic-extent args))
;; FIXME: a tiny amount of wasted SLOT-ACCESSOR-STD-P
;; work here (see KLUDGE comment above).
(let ((fun (compute-slot-accessor-info slotd type gf)))
(apply fun args))))))))
(defmethod finalize-internal-slot-functions ((slotd effective-slot-definition))
- (let* ((name (slot-value slotd 'name)))
- (dolist (type '(reader writer boundp))
- (let* ((gf-name (ecase type
- (reader 'slot-value-using-class)
- (writer '(setf slot-value-using-class))
- (boundp 'slot-boundp-using-class)))
- (gf (gdefinition gf-name)))
- (compute-slot-accessor-info slotd type gf)))))
+ (dolist (type '(reader writer boundp))
+ (let* ((gf-name (ecase type
+ (reader 'slot-value-using-class)
+ (writer '(setf slot-value-using-class))
+ (boundp 'slot-boundp-using-class)))
+ (gf (gdefinition gf-name)))
+ (compute-slot-accessor-info slotd type gf))))
;;; CMUCL (Gerd PCL 2003-04-25) comment:
;;;
(t *the-class-standard-class*))
(nreverse reversed-plist)))))
+;;; This is used to call initfunctions of :allocation :class slots.
(defun call-initfun (fun slotd safe)
(declare (function fun))
(let ((value (funcall fun)))
(when safe
- (let ((typecheck (slot-definition-type-check-function slotd)))
- (when typecheck
- (funcall (the function typecheck) value))))
+ (let ((type (slot-definition-type slotd)))
+ (unless (or (eq t type)
+ (typep value type))
+ (error 'type-error :expected-type type :datum value))))
value))
\f
(defmethod shared-initialize :after
(defmethod reinitialize-instance :before ((class slot-class) &key direct-superclasses)
(dolist (old-super (set-difference (class-direct-superclasses class) direct-superclasses))
(remove-direct-subclass old-super class))
- (remove-slot-accessors class (class-direct-slots class)))
+ (remove-slot-accessors class (class-direct-slots class)))
(defmethod reinitialize-instance :after ((class slot-class)
&rest initargs
(defmethod compute-effective-slot-definition
((class condition-class) slot-name dslotds)
- (let ((slotd (call-next-method)))
- (setf (slot-definition-reader-function slotd)
+ (let* ((slotd (call-next-method))
+ (info (slot-definition-info slotd)))
+ (setf (slot-info-reader info)
(lambda (x)
(handler-case (condition-reader-function x slot-name)
;; FIXME: FIND-SLOT-DEFAULT throws an error if the slot
;; is unbound; maybe it should be a CELL-ERROR of some
;; sort?
(error () (values (slot-unbound class x slot-name))))))
- (setf (slot-definition-writer-function slotd)
+ (setf (slot-info-writer info)
(lambda (v x)
(condition-writer-function x v slot-name)))
- (setf (slot-definition-boundp-function slotd)
+ (setf (slot-info-boundp info)
(lambda (x)
(multiple-value-bind (v c)
(ignore-errors (condition-reader-function x slot-name))
;; If there is a change in the shape of the instances then the
;; old class is now obsolete.
- (let* ((nlayout (mapcar #'slot-definition-name
+ (let* ((nlayout (mapcar (lambda (slotd)
+ (cons (slot-definition-name slotd)
+ (slot-definition-type slotd)))
(sort instance-slots #'<
:key #'slot-definition-location)))
(nslots (length nlayout))
eslotds))
(defmethod compute-effective-slot-definition ((class slot-class) name dslotds)
- (declare (ignore name))
(let* ((initargs (compute-effective-slot-definition-initargs class dslotds))
- (class (apply #'effective-slot-definition-class class initargs)))
- (apply #'make-instance class initargs)))
+ (class (apply #'effective-slot-definition-class class initargs))
+ (slotd (apply #'make-instance class initargs)))
+ slotd))
(defmethod effective-slot-definition-class ((class std-class) &rest initargs)
(declare (ignore initargs))
(allocation nil)
(allocation-class nil)
(type t)
- (type-check-function nil)
(documentation nil)
(documentationp nil)
(namep nil)
allocation-class (slot-definition-class slotd)
allocp t))
(setq initargs (append (slot-definition-initargs slotd) initargs))
- (let ((fun (slot-definition-type-check-function slotd)))
- (when fun
- (setf type-check-function
- (if type-check-function
- (let ((old-function type-check-function))
- (declare (function old-function fun))
- (lambda (value)
- (funcall old-function value)
- (funcall fun value)))
- fun))))
(let ((slotd-type (slot-definition-type slotd)))
(setq type (cond
((eq type t) slotd-type)
:allocation allocation
:allocation-class allocation-class
:type type
- 'type-check-function type-check-function
:class class
:documentation documentation)))
(defmethod compute-effective-slot-definition-initargs :around
((class structure-class) direct-slotds)
- (let ((slotd (car direct-slotds)))
- (list* :defstruct-accessor-symbol
- (slot-definition-defstruct-accessor-symbol slotd)
+ (let* ((slotd (car direct-slotds))
+ (accessor (slot-definition-defstruct-accessor-symbol slotd)))
+ (list* :defstruct-accessor-symbol accessor
:internal-reader-function
(slot-definition-internal-reader-function slotd)
:internal-writer-function
(oclass-slots (wrapper-class-slots owrapper))
(added ())
(discarded ())
- (plist ()))
+ (plist ())
+ (safe (safe-p class)))
- ;; local --> local transfer value
+ ;; local --> local transfer value, check type
;; local --> shared discard value, discard slot
;; local --> -- discard slot
- ;; shared --> local transfer value
+ ;; shared --> local transfer value, check type
;; shared --> shared -- (cf SHARED-INITIALIZE :AFTER STD-CLASS)
;; shared --> -- discard value
;; -- --> local add slot
;; -- --> shared --
- ;; Go through all the old local slots.
- (let ((opos 0))
- (dolist (name olayout)
- (let ((npos (posq name nlayout)))
- (if npos
- (setf (clos-slots-ref nslots npos)
- (clos-slots-ref oslots opos))
- (progn
- (push name discarded)
- (unless (eq (clos-slots-ref oslots opos) +slot-unbound+)
- (setf (getf plist name) (clos-slots-ref oslots opos))))))
- (incf opos)))
-
- ;; Go through all the old shared slots.
- (dolist (oclass-slot-and-val oclass-slots)
- (let ((name (car oclass-slot-and-val))
- (val (cdr oclass-slot-and-val)))
- (let ((npos (posq name nlayout)))
- (when npos
- (setf (clos-slots-ref nslots npos) val)))))
+ (flet ((set-value (value npos &optional (otype t))
+ (when safe
+ (let ((ntype (cdr (nth npos nlayout))))
+ (unless (equal ntype otype)
+ (assert (typep value ntype) (value)
+ "~@<Error updating obsolete instance. Current value in slot ~
+ ~S of an instance of ~S is ~S, which does not match the new ~
+ slot type ~S.~:@>"
+ (car (nth npos nlayout)) class value ntype))))
+ (setf (clos-slots-ref nslots npos) value)))
+ ;; Go through all the old local slots.
+ (let ((opos 0))
+ (dolist (spec olayout)
+ (destructuring-bind (name . otype) spec
+ (let ((npos (position name nlayout :key #'car)))
+ (if npos
+ (set-value (clos-slots-ref oslots opos) npos otype)
+ (progn
+ (push name discarded)
+ (unless (eq (clos-slots-ref oslots opos) +slot-unbound+)
+ (setf (getf plist name) (clos-slots-ref oslots opos)))))))
+ (incf opos)))
+
+ ;; Go through all the old shared slots.
+ (dolist (oclass-slot-and-val oclass-slots)
+ (let ((name (car oclass-slot-and-val))
+ (val (cdr oclass-slot-and-val)))
+ (let ((npos (position name nlayout :key #'car)))
+ (when npos
+ (set-value val npos))))))
;; Go through all the new local slots to compute the added slots.
- (dolist (nlocal nlayout)
- (unless (or (memq nlocal olayout)
- (assq nlocal oclass-slots))
- (push nlocal added)))
+ (dolist (spec nlayout)
+ (let ((name (car spec)))
+ (unless (or (member name olayout :key #'car)
+ (assq name oclass-slots))
+ (push name added))))
(%swap-wrappers-and-slots instance copy)
(new-layout (wrapper-instance-slots-layout new-wrapper))
(old-slots (get-slots instance))
(new-slots (get-slots copy))
- (old-class-slots (wrapper-class-slots old-wrapper)))
-
- ;; "The values of local slots specified by both the class CTO and
- ;; CFROM are retained. If such a local slot was unbound, it
- ;; remains unbound."
- (let ((new-position 0))
- (dolist (new-slot new-layout)
- (let ((old-position (posq new-slot old-layout)))
- (when old-position
- (setf (clos-slots-ref new-slots new-position)
- (clos-slots-ref old-slots old-position))))
- (incf new-position)))
-
- ;; "The values of slots specified as shared in the class CFROM and
- ;; as local in the class CTO are retained."
- (dolist (slot-and-val old-class-slots)
- (let ((position (posq (car slot-and-val) new-layout)))
- (when position
- (setf (clos-slots-ref new-slots position) (cdr slot-and-val)))))
+ (old-class-slots (wrapper-class-slots old-wrapper))
+ (safe (safe-p new-class)))
+
+ (flet ((set-value (value pos)
+ (when safe
+ (let ((spec (nth pos new-layout)))
+ (assert (typep value (cdr spec)) (value)
+ "~@<Error changing class. Current value in slot ~S ~
+ of an instance of ~S is ~S, which does not match the new ~
+ slot type ~S in class ~S.~:@>"
+ (car spec) old-class value
+ (cdr spec) new-class)))
+ (setf (clos-slots-ref new-slots pos) value)))
+ ;; "The values of local slots specified by both the class CTO and
+ ;; CFROM are retained. If such a local slot was unbound, it
+ ;; remains unbound."
+ (let ((new-position 0))
+ (dolist (new-slot new-layout)
+ (let* ((name (car new-slot))
+ (old-position (position name old-layout :key #'car)))
+ (when old-position
+ (set-value (clos-slots-ref old-slots old-position)
+ new-position)))
+ (incf new-position)))
+
+ ;; "The values of slots specified as shared in the class CFROM and
+ ;; as local in the class CTO are retained."
+ (dolist (slot-and-val old-class-slots)
+ (let ((position (position (car slot-and-val) new-layout :key #'car)))
+ (when position
+ (set-value (cdr slot-and-val) position)))))
;; Make the copy point to the old instance's storage, and make the
;; old instance point to the new storage.
(sb-thread::with-spinlock (*pv-lock*)
(%intern-pv-table (mapcar #'intern-slot-names slot-name-lists)))))
\f
-(defun optimize-slot-value-by-class-p (class slot-name type)
+(defun use-standard-slot-access-p (class slot-name type)
(or (not (eq **boot-state** 'complete))
- (let ((slotd (find-slot-definition class slot-name)))
- (and slotd
- (slot-accessor-std-p slotd type)))))
-
-(defun compute-slot-location-for-pv (slot-name wrapper class)
- (when (optimize-slot-value-by-class-p class slot-name 'all)
- (car (find-slot-cell wrapper slot-name))))
-
-(defun compute-slot-typecheckfun-for-pv (slot-name wrapper class)
- (when (optimize-slot-value-by-class-p class slot-name 'all)
- (cadr (find-slot-cell wrapper slot-name))))
+ (and (standard-class-p class)
+ (let ((slotd (find-slot-definition class slot-name)))
+ (and slotd
+ (slot-accessor-std-p slotd type))))))
+
+(defun slot-missing-info (class slot-name)
+ (flet ((missing (operation)
+ (lambda (object)
+ (slot-missing class object slot-name operation))))
+ (make-slot-info
+ :reader (missing 'slot-value)
+ :boundp (missing 'slot-boundp)
+ :writer (lambda (new-value object)
+ (slot-missing class object slot-name 'setf new-value)))))
(defun compute-pv (slot-name-lists wrappers)
(unless (listp wrappers)
(std-p (typep wrapper 'wrapper))
(class (wrapper-class* wrapper)))
(dolist (slot-name (cdr slot-names))
- (push (when std-p
- (compute-slot-location-for-pv slot-name wrapper class))
+ (let ((cell
+ (or (find-slot-cell wrapper slot-name)
+ (cons nil (slot-missing-info class slot-name)))))
+ (push (when (and std-p (use-standard-slot-access-p class slot-name 'all))
+ (car cell))
elements)
- (push (when std-p
- (compute-slot-typecheckfun-for-pv slot-name wrapper class))
- elements)))))
+ (push (or (cdr cell)
+ (bug "No SLOT-INFO for ~S in ~S" slot-name class))
+ elements))))))
(let* ((n (length elements))
(pv (make-array n)))
(loop for i from (1- n) downto 0
(defun make-pv-type-declaration (var)
`(type simple-vector ,var))
\f
+;;; Sometimes we want to finalize if we can, but it's OK if
+;;; we can't.
+(defun try-finalize-inheritance (class)
+ (unless (typep class 'forward-referenced-class)
+ (when (every (lambda (super)
+ (or (eq super class)
+ (class-finalized-p super)
+ (try-finalize-inheritance super)))
+ (class-direct-superclasses class))
+ (finalize-inheritance class)
+ t)))
+
(defun can-optimize-access (form required-parameters env)
(destructuring-bind (op var-form slot-name-form &optional new-value) form
- (let ((type (ecase op
- (slot-value 'reader)
- (set-slot-value 'writer)
- (slot-boundp 'boundp)))
- (var (extract-the var-form))
- (slot-name (constant-form-value slot-name-form env)))
- (when (and (symbolp var) (not (var-special-p var env)))
- (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
- (parameter-or-nil (car (memq (or rebound? var)
- required-parameters))))
- (when parameter-or-nil
- (let* ((class-name (caddr (var-declaration '%class
- parameter-or-nil
- env)))
- (class (find-class class-name nil)))
- (when (or (not (eq **boot-state** 'complete))
- (and class (not (class-finalized-p class))))
- (setq class nil))
- (when (and class-name (not (eq class-name t)))
- (when (or (null type)
- (not (and class
- (memq *the-class-structure-object*
- (class-precedence-list class))))
- (optimize-slot-value-by-class-p class slot-name type))
- (values (cons parameter-or-nil (or class class-name))
- slot-name
- new-value))))))))))
+ (let ((type (ecase op
+ (slot-value 'reader)
+ (set-slot-value 'writer)
+ (slot-boundp 'boundp)))
+ (var (extract-the var-form))
+ (slot-name (constant-form-value slot-name-form env)))
+ (when (and (symbolp var) (not (var-special-p var env)))
+ (let* ((rebound? (caddr (var-declaration '%variable-rebinding var env)))
+ (parameter-or-nil (car (memq (or rebound? var)
+ required-parameters))))
+ (when parameter-or-nil
+ (let* ((class-name (caddr (var-declaration '%class
+ parameter-or-nil
+ env)))
+ (class (find-class class-name nil)))
+ (cond ((not (eq **boot-state** 'complete))
+ (setq class nil))
+ ((and class (not (class-finalized-p class)))
+ ;; The class itself is never forward-referenced
+ ;; here, but its superclasses may be.
+ (unless (try-finalize-inheritance class)
+ (when (boundp 'sb-c:*lexenv*)
+ (sb-c:compiler-notify
+ "~@<Cannot optimize slot access, inheritance of ~S is not ~
+ yet finaliable due to forward-referenced superclasses:~
+ ~% ~S~:@>"
+ class form))
+ (setf class nil))))
+ (when (and class-name (not (eq class-name t)))
+ (when (not (and class
+ (memq *the-class-structure-object*
+ (class-precedence-list class))))
+ (aver type)
+ (values (cons parameter-or-nil (or class class-name))
+ slot-name
+ new-value))))))))))
;;; Check whether the binding of the named variable is modified in the
;;; method body.
(let ((optimized-form
(optimize-instance-access slots :read sparameter
slot-name nil)))
- ;; We don't return the optimized form directly, since there's
- ;; still a chance that we'll find out later on that the
- ;; optimization should not have been done, for example due to
- ;; the walker encountering a SETQ on SPARAMETER later on in
- ;; the body [ see for example clos.impure.lisp test with :name
- ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer
- ;; the decision until the compiler macroexpands
- ;; OPTIMIZED-SLOT-VALUE.
- ;;
- ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at
- ;; this point (instead of when expanding
- ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of
- ;; SLOTS. If that mutation isn't done during the walking,
- ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING
- ;; form around the body, and compilation will fail. -- JES,
- ;; 2006-09-18
- `(optimized-slot-value ,form ,(car sparameter) ,optimized-form))
- `(accessor-slot-value ,@(cdr form)))))
+ ;; We don't return the optimized form directly, since there's
+ ;; still a chance that we'll find out later on that the
+ ;; optimization should not have been done, for example due to
+ ;; the walker encountering a SETQ on SPARAMETER later on in
+ ;; the body [ see for example clos.impure.lisp test with :name
+ ;; ((:setq :method-parameter) slot-value)) ]. Instead we defer
+ ;; the decision until the compiler macroexpands
+ ;; OPTIMIZED-SLOT-VALUE.
+ ;;
+ ;; Note that we must still call OPTIMIZE-INSTANCE-ACCESS at
+ ;; this point (instead of when expanding
+ ;; OPTIMIZED-SLOT-VALUE), since it mutates the structure of
+ ;; SLOTS. If that mutation isn't done during the walking,
+ ;; MAKE-METHOD-LAMBDA-INTERNAL won't wrap a correct PV-BINDING
+ ;; form around the body, and compilation will fail. -- JES,
+ ;; 2006-09-18
+ `(optimized-slot-value ,form ,(car sparameter) ,optimized-form))
+ `(accessor-slot-value ,@(cdr form)))))
(defmacro optimized-slot-value (form parameter-name optimized-form
&environment env)
(let ((slotd (find-slot-definition class slot-name)))
(and slotd (eq :class (slot-definition-allocation slotd)))))))
-(defun skip-fast-slot-access-p (class-form slot-name-form type)
- (let ((class (and (constantp class-form) (constant-form-value class-form)))
- (slot-name (and (constantp slot-name-form)
- (constant-form-value slot-name-form))))
- (and (eq **boot-state** 'complete)
- (standard-class-p class)
- (not (eq class *the-class-t*)) ; shouldn't happen, though.
- ;; FIXME: Is this really right? "Don't skip if there is
- ;; no slot definition."
- (let ((slotd (find-slot-definition class slot-name)))
- (and slotd
- (not (slot-accessor-std-p slotd type)))))))
+(defun constant-value-or-nil (form)
+ (and (constantp form) (constant-form-value form)))
+
+(defun slot-access-strategy (class slot-name type &optional conservative)
+ ;; CONSERVATIVE means we should assume custom access pattern even if
+ ;; there are no custom accessors defined if the metaclass is non-standard.
+ ;;
+ ;; This is needed because DEFCLASS generates accessor methods before possible
+ ;; SLOT-VALUE-USING-CLASS methods are defined, which causes them to take
+ ;; the slow path unless we make the conservative assumption here.
+ (if (eq **boot-state** 'complete)
+ (let (slotd)
+ (cond ((or
+ ;; Conditions, structures, and classes for which FIND-CLASS
+ ;; doesn't return them yet.
+ ;; FIXME: surely we can get faster accesses for structures?
+ (not (standard-class-p class))
+ ;; Should not happen... (FIXME: assert instead?)
+ (eq class *the-class-t*)
+ (not (class-finalized-p class))
+ ;; Strangeness...
+ (not (setf slotd (find-slot-definition class slot-name))))
+ :accessor)
+ ((and (slot-accessor-std-p slotd type)
+ (or (not conservative) (eq *the-class-standard-class* (class-of class))))
+ ;; The best case.
+ :standard)
+ (t
+ :custom)))
+ :standard))
+
+;;;; SLOT-VALUE
-(defmacro instance-read-internal (pv slots pv-offset default &optional kind)
+(defmacro instance-read (pv-offset parameter position slot-name class)
+ (ecase (slot-access-strategy (constant-value-or-nil class)
+ (constant-value-or-nil slot-name)
+ 'reader)
+ (:standard
+ `(instance-read-standard
+ .pv. ,(slot-vector-symbol position)
+ ,pv-offset (accessor-slot-value ,parameter ,slot-name)
+ ,(if (generate-fast-class-slot-access-p class slot-name)
+ :class :instance)))
+ (:custom
+ `(instance-read-custom .pv. ,pv-offset ,parameter))
+ (:accessor
+ `(accessor-slot-value ,parameter ,slot-name))))
+
+(defmacro instance-read-standard (pv slots pv-offset default &optional kind)
(unless (member kind '(nil :instance :class))
- (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind))
+ (error "illegal kind argument to ~S: ~S" 'instance-read-standard kind))
(let* ((index (gensym))
(value index))
`(locally (declare #.*optimize-speed*)
- (let ((,index (svref ,pv ,pv-offset)))
+ (let ((,index (svref ,pv ,pv-offset))
+ (,slots (truly-the simple-vector ,slots)))
(setq ,value (typecase ,index
;; FIXME: the line marked by KLUDGE below (and
;; the analogous spot in
- ;; INSTANCE-WRITE-INTERNAL) is there purely to
+ ;; INSTANCE-WRITE-STANDARD) is there purely to
;; suppress a type mismatch warning that
;; propagates through to user code.
;; Presumably SLOTS at this point can never
;; sbcl-devel 2003-09-21) -- CSR, 2003-11-30
,@(when (or (null kind) (eq kind :instance))
`((fixnum
- (and ,slots ; KLUDGE
- (clos-slots-ref ,slots ,index)))))
+ (clos-slots-ref ,slots ,index))))
,@(when (or (null kind) (eq kind :class))
`((cons (cdr ,index))))
- (t +slot-unbound+)))
+ (t
+ +slot-unbound+)))
(if (eq ,value +slot-unbound+)
,default
,value)))))
-(defmacro instance-read (pv-offset parameter position slot-name class)
- (if (skip-fast-slot-access-p class slot-name 'reader)
- `(accessor-slot-value ,parameter ,slot-name)
- `(instance-read-internal .pv. ,(slot-vector-symbol position)
- ,pv-offset (accessor-slot-value ,parameter ,slot-name)
- ,(if (generate-fast-class-slot-access-p class slot-name)
- :class :instance))))
-
-(defmacro instance-write-internal (pv slots pv-offset new-value default
+(defmacro instance-read-custom (pv pv-offset parameter)
+ `(locally (declare #.*optimize-speed*)
+ (funcall (slot-info-reader (svref ,pv (1+ ,pv-offset))) ,parameter)))
+
+;;;; (SETF SLOT-VALUE)
+
+(defmacro instance-write (pv-offset parameter position slot-name class new-value
+ &optional check-type-p)
+ (ecase (slot-access-strategy (constant-value-or-nil class)
+ (constant-value-or-nil slot-name)
+ 'writer)
+ (:standard
+ `(instance-write-standard
+ .pv. ,(slot-vector-symbol position)
+ ,pv-offset ,new-value
+ ;; KLUDGE: .GOOD-NEW-VALUE. is type-checked by the time this form
+ ;; is executed (if it is executed).
+ (accessor-set-slot-value ,parameter ,slot-name .good-new-value.)
+ ,(if (generate-fast-class-slot-access-p class slot-name)
+ :class :instance)
+ ,check-type-p))
+ (:custom
+ `(instance-write-custom .pv. ,pv-offset ,parameter ,new-value))
+ (:accessor
+ (if check-type-p
+ ;; FIXME: We don't want this here. If it's _possible_ the fast path
+ ;; is applicable, we want to use it as well.
+ `(safe-set-slot-value ,parameter ,slot-name ,new-value)
+ `(accessor-set-slot-value ,parameter ,slot-name ,new-value)))))
+
+(defmacro instance-write-standard (pv slots pv-offset new-value default
&optional kind safep)
(unless (member kind '(nil :instance :class))
- (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind))
+ (error "illegal kind argument to ~S: ~S" 'instance-write-standard kind))
(let* ((index (gensym))
(new-value-form
(if safep
- `(let ((.typecheckfun. (svref ,pv (1+ ,pv-offset))))
+ `(let ((.typecheckfun. (slot-info-typecheck (svref ,pv (1+ ,pv-offset)))))
(declare (type (or function null) .typecheckfun.))
(if .typecheckfun.
(funcall .typecheckfun. ,new-value)
`((cons (setf (cdr ,index) .good-new-value.))))
(t ,default))))))
-(defmacro instance-write (pv-offset parameter position slot-name class new-value
- &optional check-type-p)
- (if (skip-fast-slot-access-p class slot-name 'writer)
- (if check-type-p
- ;; FIXME: We don't want this here. If it's _possible_ the fast path
- ;; is applicable, we wan to use it as well.
- `(safe-set-slot-value ,parameter ,slot-name ,new-value)
- `(accessor-set-slot-value ,parameter ,slot-name ,new-value))
- `(instance-write-internal
- .pv. ,(slot-vector-symbol position)
- ,pv-offset ,new-value
- ;; KLUDGE: .GOOD-NEW-VALUE. is type-checked by the time this form
- ;; is executed (if it is executed).
- (accessor-set-slot-value ,parameter ,slot-name .good-new-value.)
- ,(if (generate-fast-class-slot-access-p class slot-name)
- :class :instance)
- ,check-type-p)))
-
-(defmacro instance-boundp-internal (pv slots pv-offset default
+(defmacro instance-write-custom (pv pv-offset parameter new-value)
+ `(locally (declare #.*optimize-speed*)
+ (funcall (slot-info-writer (svref ,pv (1+ ,pv-offset))) ,new-value ,parameter)))
+
+;;;; SLOT-BOUNDP
+
+(defmacro instance-boundp (pv-offset parameter position slot-name class)
+ (ecase (slot-access-strategy (constant-value-or-nil class)
+ (constant-value-or-nil slot-name)
+ 'boundp)
+ (:standard
+ `(instance-boundp-standard
+ .pv. ,(slot-vector-symbol position)
+ ,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
+ ,(if (generate-fast-class-slot-access-p class slot-name)
+ :class :instance)))
+ (:custom
+ `(instance-boundp-custom .pv. ,pv-offset ,parameter))
+ (:accessor
+ `(accessor-slot-boundp ,parameter ,slot-name))))
+
+(defmacro instance-boundp-standard (pv slots pv-offset default
&optional kind)
(unless (member kind '(nil :instance :class))
- (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind))
+ (error "illegal kind argument to ~S: ~S" 'instance-boundp-standard kind))
(let* ((index (gensym)))
`(locally (declare #.*optimize-speed*)
(let ((,index (svref ,pv ,pv-offset)))
`((cons (not (eq (cdr ,index) +slot-unbound+)))))
(t ,default))))))
-(defmacro instance-boundp (pv-offset parameter position slot-name class)
- (if (skip-fast-slot-access-p class slot-name 'boundp)
- `(accessor-slot-boundp ,parameter ,slot-name)
- `(instance-boundp-internal .pv. ,(slot-vector-symbol position)
- ,pv-offset (accessor-slot-boundp ,parameter ,slot-name)
- ,(if (generate-fast-class-slot-access-p class slot-name)
- :class :instance))))
+(defmacro instance-boundp-custom (pv pv-offset parameter)
+ `(locally (declare #.*optimize-speed*)
+ (funcall (slot-info-boundp (svref ,pv (1+ ,pv-offset))) ,parameter)))
;;; This magic function has quite a job to do indeed.
;;;
(incf pv-offset)
(dolist (form (cdr slot-entry))
(setf (cadr form) pv-offset))
- ;; Count one more for the slot we use for typecheckfun.
+ ;; Count one more for the slot we use for SLOT-INFO.
(incf pv-offset)))
sorted-slots))
(defclass clos-typecheck-test ()
((slot :type fixnum)))
(setf (slot-value (make-instance 'clos-typecheck-test) 'slot) t))))
- '(((sb-pcl::slot-typecheck clos-typecheck-test slot) t)))))
+ '(((sb-pcl::slot-typecheck fixnum) t)))))
(with-test (:name :clos-emf-named)
(assert
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.46.10"
+"1.0.46.11"
projects / sbcl.git / commitdiff