;;;; -*- coding: utf-8; -*-
changes in sbcl-1.0.10 relative to sbcl-1.0.9:
+ * optimization: SLOT-VALUE and (SETF SLOT-VALUE) are now >20% faster
+ for variable slot names, when the class of the instance is
+ an instance of STANDARD-CLASS or FUNCALLABLE-STANDARD-CLASS, and not
+ any of their subclasses.
* optimization: member type construction is now O(N) instead
of O(N^2).
* optimization: UNION and NUNION are now O(N+M) for large
slot-class))
(set-slot 'direct-slots direct-slots)
(set-slot 'slots slots)
- (set-slot 'slot-vector (make-slot-vector slots)))
+ (set-slot 'slot-vector (make-slot-vector class slots)))
;; For all direct superclasses SUPER of CLASS, make sure CLASS is
;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
;;; requires a GF call (for SLOT-DEFINITION-NAME) for each slot in
;;; list up to the desired one.
;;;
-;;; As of 1.0.7.26 SBCL hashes the effective slot definitions into a
-;;; simple-vector, with bucket chains made out of plists keyed by the
-;;; slot names. This fixes gives O(1) performance, and avoid the GF
-;;; calls.
+;;; Current SBCL hashes the effective slot definitions, and some
+;;; information pulled out from them into a simple-vector, with bucket
+;;; chains made out of plists keyed by the slot names. This fixes
+;;; gives O(1) performance, and avoid the GF calls.
;;;
;;; MAKE-SLOT-VECTOR constructs the hashed vector out of a list of
-;;; effective slot definitions, and FIND-SLOT-DEFINITION knows how to
-;;; look up slots in that vector.
+;;; effective slot definitions and the class they pertain to, and
+;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
;;;
;;; The only bit of cleverness in the implementation is to make the
;;; vectors fairly tight, but always longer then 0 elements:
;;; -- As long as the vector always has a length > 0
;;; FIND-SLOT-DEFINITION doesn't need to handle the rare case of an
;;; empty vector separately: it just returns a NIL.
+;;;
+;;; In addition to the slot-definition we also store the slot-location
+;;; and type-check function for instances of standard metaclasses, so
+;;; that SLOT-VALUE &co using variable slot names can get at them
+;;; without additional GF calls.
+;;;
+;;; Notes:
+;;; It would be probably better to store the vector in wrapper
+;;; instead: one less memory indirection, one less CLOS slot
+;;; access to get at it.
+;;;
+;;; It would also be nice to have STANDARD-INSTANCE-STRUCTURE-P
+;;; generic instead of checking versus STANDARD-CLASS and
+;;; FUNCALLABLE-STANDARD-CLASS.
(defun find-slot-definition (class slot-name)
(declare (symbol slot-name))
(let ((key (car plist)))
(setf plist (cdr plist))
(when (eq key slot-name)
+ (return (cddar plist)))))))
+
+(defun find-slot-cell (class slot-name)
+ (declare (symbol slot-name))
+ (let* ((vector (class-slot-vector class))
+ (index (rem (sxhash slot-name) (length vector))))
+ (declare (simple-vector vector) (index index)
+ (optimize (sb-c::insert-array-bounds-checks 0)))
+ (do ((plist (the list (svref vector index)) (cdr plist)))
+ ((not (consp plist)))
+ (let ((key (car plist)))
+ (setf plist (cdr plist))
+ (when (eq key slot-name)
(return (car plist)))))))
-(defun make-slot-vector (slots)
+(defun make-slot-vector (class slots)
(let* ((n (+ (length slots) 2))
- (vector (make-array n :initial-element nil)))
+ (vector (make-array n :initial-element nil))
+ (save-slot-location-p
+ (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 (and save-slot-location-p (safe-p class))))
(flet ((add-to-vector (name slot)
(declare (symbol name)
(optimize (sb-c::insert-array-bounds-checks 0)))
- (setf (svref vector (rem (sxhash name) n))
- (list* name slot (svref vector (rem (sxhash name) n))))))
+ (let ((index (rem (sxhash name) n)))
+ (setf (svref vector index)
+ (list* name (list* (if save-slot-location-p
+ (slot-definition-location slot)
+ ;; T tells SLOT-VALUE & SET-SLOT-VALUE
+ ;; that this is a non-standard class.
+ t)
+ (when save-type-check-function-p
+ (slot-definition-type-check-function slot))
+ slot)
+ (svref vector index))))))
(if (eq 'complete *boot-state*)
(dolist (slot slots)
(add-to-vector (slot-definition-name slot) slot))
(t
(error "unrecognized instance type")))))
\f
-;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP
+;;;; STANDARD-INSTANCE-ACCESS
+
+(declaim (inline standard-instance-access (setf standard-instance-access)
+ funcallable-standard-instance-access
+ (setf funcallable-standard-instance-access)))
+
+(defun standard-instance-access (instance location)
+ (clos-slots-ref (std-instance-slots instance) location))
+
+(defun (setf standard-instance-access) (new-value instance location)
+ (setf (clos-slots-ref (std-instance-slots instance) location) new-value))
+
+(defun funcallable-standard-instance-access (instance location)
+ (clos-slots-ref (fsc-instance-slots instance) location))
+
+(defun (setf funcallable-standard-instance-access) (new-value instance location)
+ (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value))
+\f
+;;;; SLOT-VALUE, (SETF SLOT-VALUE), SLOT-BOUNDP, SLOT-MAKUNBOUND
(declaim (ftype (sfunction (t symbol) t) slot-value))
(defun slot-value (object slot-name)
- (let* ((class (class-of object))
- (slot-definition (find-slot-definition class slot-name)))
- (if (null slot-definition)
- (values (slot-missing class object slot-name 'slot-value))
- (slot-value-using-class class object slot-definition))))
+ (let* ((class (check-obsolete-instance/class-of object))
+ (cell (find-slot-cell class slot-name))
+ (location (car cell))
+ (value
+ (cond ((fixnump location)
+ (if (std-instance-p object)
+ (standard-instance-access object location)
+ (funcallable-standard-instance-access object location)))
+ ((consp location)
+ (cdr location))
+ ((eq t location)
+ (return-from slot-value
+ (slot-value-using-class class object (cddr cell))))
+ ((not cell)
+ (return-from slot-value
+ (values (slot-missing class object slot-name 'slot-value))))
+ (t
+ (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
+ (if (eq +slot-unbound+ value)
+ (slot-unbound class object slot-name)
+ value)))
(define-compiler-macro slot-value (&whole form object slot-name
&environment env)
form))
(defun set-slot-value (object slot-name new-value)
- (let* ((class (class-of object))
- (slot-definition (find-slot-definition class slot-name)))
- (if (null slot-definition)
- (progn (slot-missing class object slot-name 'setf new-value)
- new-value)
- (setf (slot-value-using-class class object slot-definition)
- new-value))))
+ (let* ((class (check-obsolete-instance/class-of object))
+ (cell (find-slot-cell class slot-name))
+ (location (car cell))
+ (type-check-function (cadr cell)))
+ (when type-check-function
+ (funcall (the function type-check-function) new-value))
+ (cond ((fixnump location)
+ (if (std-instance-p object)
+ (setf (standard-instance-access object location) new-value)
+ (setf (funcallable-standard-instance-access object location)
+ new-value)))
+ ((consp location)
+ (setf (cdr location) new-value))
+ ((eq t location)
+ (setf (slot-value-using-class class object (cddr cell)) new-value))
+ ((not cell)
+ (slot-missing class object slot-name 'setf new-value))
+ (t
+ (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
+ new-value)
;;; A version of SET-SLOT-VALUE for use in safe code, where we want to
;;; check types when writing to slots:
form))
(defun slot-boundp (object slot-name)
- (let* ((class (class-of object))
- (slot-definition (find-slot-definition class slot-name)))
- (if (null slot-definition)
- (not (not (slot-missing class object slot-name 'slot-boundp)))
- (slot-boundp-using-class class object slot-definition))))
-
-(setf (gdefinition 'slot-boundp-normal) #'slot-boundp)
+ (let* ((class (check-obsolete-instance/class-of object))
+ (cell (find-slot-cell class slot-name))
+ (location (car cell))
+ (value
+ (cond ((fixnump location)
+ (if (std-instance-p object)
+ (standard-instance-access object location)
+ (funcallable-standard-instance-access object location)))
+ ((consp location)
+ (cdr location))
+ ((eq t location)
+ (return-from slot-boundp
+ (slot-boundp-using-class class object (cddr cell))))
+ ((not cell)
+ (return-from slot-boundp
+ (and (slot-missing class object slot-name 'slot-boundp) t)))
+ (t
+ (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
+ (not (eq +slot-unbound+ value))))
(define-compiler-macro slot-boundp (&whole form object slot-name
&environment env)
form))
(defun slot-makunbound (object slot-name)
- (let* ((class (class-of object))
- (slot-definition (find-slot-definition class slot-name)))
- (if (null slot-definition)
- (slot-missing class object slot-name 'slot-makunbound)
- (slot-makunbound-using-class class object slot-definition))
- object))
+ (let* ((class (check-obsolete-instance/class-of object))
+ (cell (find-slot-cell class slot-name))
+ (location (car cell)))
+ (cond ((fixnump location)
+ (if (std-instance-p object)
+ (setf (standard-instance-access object location) +slot-unbound+)
+ (setf (funcallable-standard-instance-access object location)
+ +slot-unbound+)))
+ ((consp location)
+ (setf (cdr location) +slot-unbound+))
+ ((eq t location)
+ (slot-makunbound-using-class class object (cddr cell)))
+ ((not cell)
+ (slot-missing class object slot-name 'slot-makunbound))
+ (t
+ (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell))))
+ object)
(defun slot-exists-p (object slot-name)
(let ((class (class-of object)))
(if (slot-boundp object slot-name)
(slot-value object slot-name)
default))
-\f
-(declaim (inline standard-instance-access (setf standard-instance-access)
- funcallable-standard-instance-access
- (setf funcallable-standard-instance-access)))
-
-(defun standard-instance-access (instance location)
- (clos-slots-ref (std-instance-slots instance) location))
-
-(defun (setf standard-instance-access) (new-value instance location)
- (setf (clos-slots-ref (std-instance-slots instance) location) new-value))
-
-(defun funcallable-standard-instance-access (instance location)
- (clos-slots-ref (fsc-instance-slots instance) location))
-
-(defun (setf funcallable-standard-instance-access) (new-value instance location)
- (setf (clos-slots-ref (fsc-instance-slots instance) location) new-value))
(defmethod slot-value-using-class ((class std-class)
(object standard-object)
(slotd standard-effective-slot-definition))
+ ;; FIXME: Do we need this? SLOT-VALUE checks for obsolete
+ ;; instances. Are users allowed to call this directly?
(check-obsolete-instance object)
(let* ((location (slot-definition-location slotd))
(value
(new-value (class std-class)
(object standard-object)
(slotd standard-effective-slot-definition))
+ ;; 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
((class std-class)
(object standard-object)
(slotd standard-effective-slot-definition))
+ ;; FIXME: Do we need this? SLOT-BOUNDP checks for obsolete
+ ;; instances. Are users allowed to call this directly?
(check-obsolete-instance object)
(let* ((location (slot-definition-location slotd))
(value
(add-direct-subclasses class direct-superclasses)
(let ((slots (compute-slots class)))
(setf (slot-value class 'slots) slots
- (slot-value class 'slot-vector) (make-slot-vector slots)))))
+ (slot-value class 'slot-vector) (make-slot-vector class slots)))))
;; Comment from Gerd's PCL, 2003-05-15:
;;
;; We don't ADD-SLOT-ACCESSORS here because we don't want to
(setf (slot-value class 'cpl-available-p) t)
(let ((slots (compute-slots class)))
(setf (slot-value class 'slots) slots
- (slot-value class 'slot-vector) (make-slot-vector slots)))
+ (slot-value class 'slot-vector) (make-slot-vector class slots)))
(let ((lclass (find-classoid (class-name class))))
(setf (classoid-pcl-class lclass) class)
(setf (slot-value class 'wrapper) (classoid-layout lclass)))
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'slots) eslotds
- (slot-value class 'slot-vector) (make-slot-vector eslotds)
+ (slot-value class 'slot-vector) (make-slot-vector class eslotds)
(wrapper-instance-slots-layout nwrapper) nlayout
(wrapper-class-slots nwrapper) nwrapper-class-slots
(layout-length nwrapper) nslots
(defun check-obsolete-instance (instance)
(when (invalid-wrapper-p (layout-of instance))
(check-wrapper-validity instance)))
+
+(defun check-obsolete-instance/class-of (instance)
+ (let ((wrapper (wrapper-of instance)))
+ (when (invalid-wrapper-p wrapper)
+ (check-wrapper-validity instance))
+ (wrapper-class* wrapper)))
\f
;;; NIL: means nothing so far, no actual arg info has NILs in the
;;; metatype.
(assert (= (slot-value *yao-super* 'obs) 3))
(assert (= (slot-value *yao-sub* 'obs) 3))
+;;; one more MIO test: variable slot names
+(defclass mio () ((x :initform 42)))
+(defvar *mio-slot* 'x)
+(defparameter *mio-counter* 0)
+(defmethod update-instance-for-redefined-class ((instance mio) new old plist &key)
+ (incf *mio-counter*))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (slot-value x *mio-slot*))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (setf (slot-value x *mio-slot*) 13))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (slot-boundp x *mio-slot*))
+
+(let ((x (make-instance 'mio)))
+ (make-instances-obsolete 'mio)
+ (slot-makunbound x *mio-slot*))
+
+(assert (= 4 *mio-counter*))
+
;;; shared -> local slot transfers of inherited slots, reported by
;;; Bruno Haible
(let (i)
;;; 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.9.1"
+"1.0.9.2"
projects / sbcl.git / commitdiff