Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv25927/src/pcl
Modified Files:
braid.lisp defs.lisp slots-boot.lisp slots.lisp std-class.lisp
wrapper.lisp
Log Message:
1.0.9.11: even faster SLOT-VALUE &co
* Move the SLOT-TABLE data to layout, so that it can be accessed
faster, giving ~40% more speed to SLOT-VALUE &co using variable slot
names. Speedup is due to one less level of indirection, and avoiding
a GF call when fetching the table.
* FIND-SLOT-DEFINITION goes back to using the linear search, as in
some cases where we use it the class wrapper may already be invalid.
This will be re-addressed later.
Index: braid.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v
retrieving revision 1.67
retrieving revision 1.68
diff -u -d -r1.67 -r1.68
--- braid.lisp 29 Aug 2007 15:23:01 -0000 1.67
+++ braid.lisp 29 Aug 2007 16:02:37 -0000 1.68
@@ -310,7 +310,7 @@
slot-class))
(set-slot 'direct-slots direct-slots)
(set-slot 'slots slots)
- (set-slot 'slot-table (make-slot-table class slots)))
+ (setf (layout-slot-table wrapper) (make-slot-table class slots)))
;; For all direct superclasses SUPER of CLASS, make sure CLASS is
;; a direct subclass of SUPER. Note that METACLASS-NAME doesn't
Index: defs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defs.lisp,v
retrieving revision 1.62
retrieving revision 1.63
diff -u -d -r1.62 -r1.63
--- defs.lisp 29 Aug 2007 15:23:03 -0000 1.62
+++ defs.lisp 29 Aug 2007 16:02:37 -0000 1.63
@@ -660,10 +660,7 @@
:reader class-direct-slots)
(slots
:initform ()
- :reader class-slots)
- (slot-table
- :initform #(nil)
- :reader class-slot-table)))
+ :reader class-slots)))
;;; The class STD-CLASS is an implementation-specific common
;;; superclass of the classes STANDARD-CLASS and
Index: slots-boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots-boot.lisp,v
retrieving revision 1.37
retrieving revision 1.38
diff -u -d -r1.37 -r1.38
--- slots-boot.lisp 29 Aug 2007 15:23:03 -0000 1.37
+++ slots-boot.lisp 29 Aug 2007 16:02:37 -0000 1.38
@@ -565,21 +565,13 @@
;;; FUNCALLABLE-STANDARD-CLASS.
(defun find-slot-definition (class slot-name)
- (declare (symbol slot-name))
- (let* ((vector (class-slot-table 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 (cddar plist)))))))
+ (dolist (slotd (class-slots class))
+ (when (eq slot-name (slot-definition-name slotd))
+ (return slotd))))
-(defun find-slot-cell (class slot-name)
+(defun find-slot-cell (wrapper slot-name)
(declare (symbol slot-name))
- (let* ((vector (class-slot-table class))
+ (let* ((vector (layout-slot-table wrapper))
(index (rem (sxhash slot-name) (length vector))))
(declare (simple-vector vector) (index index)
(optimize (sb-c::insert-array-bounds-checks 0)))
Index: slots.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots.lisp,v
retrieving revision 1.31
retrieving revision 1.32
diff -u -d -r1.31 -r1.32
--- slots.lisp 27 Aug 2007 15:13:28 -0000 1.31
+++ slots.lisp 29 Aug 2007 16:02:37 -0000 1.32
@@ -97,8 +97,8 @@
(declaim (ftype (sfunction (t symbol) t) slot-value))
(defun slot-value (object slot-name)
- (let* ((class (check-obsolete-instance/class-of object))
- (cell (find-slot-cell class slot-name))
+ (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+ (cell (find-slot-cell wrapper slot-name))
(location (car cell))
(value
(cond ((fixnump location)
@@ -109,14 +109,15 @@
(cdr location))
((eq t location)
(return-from slot-value
- (slot-value-using-class class object (cddr cell))))
+ (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))))
((not cell)
(return-from slot-value
- (values (slot-missing class object slot-name 'slot-value))))
+ (values (slot-missing (wrapper-class* wrapper) 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)
+ (slot-unbound (wrapper-class* wrapper) object slot-name)
value)))
(define-compiler-macro slot-value (&whole form object slot-name
@@ -127,8 +128,8 @@
form))
(defun set-slot-value (object slot-name new-value)
- (let* ((class (check-obsolete-instance/class-of object))
- (cell (find-slot-cell class slot-name))
+ (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+ (cell (find-slot-cell wrapper slot-name))
(location (car cell))
(type-check-function (cadr cell)))
(when type-check-function
@@ -141,9 +142,10 @@
((consp location)
(setf (cdr location) new-value))
((eq t location)
- (setf (slot-value-using-class class object (cddr cell)) new-value))
+ (setf (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))
+ new-value))
((not cell)
- (slot-missing class object slot-name 'setf new-value))
+ (slot-missing (wrapper-class* wrapper) object slot-name 'setf new-value))
(t
(bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
new-value)
@@ -169,8 +171,8 @@
form))
(defun slot-boundp (object slot-name)
- (let* ((class (check-obsolete-instance/class-of object))
- (cell (find-slot-cell class slot-name))
+ (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+ (cell (find-slot-cell wrapper slot-name))
(location (car cell))
(value
(cond ((fixnump location)
@@ -181,10 +183,12 @@
(cdr location))
((eq t location)
(return-from slot-boundp
- (slot-boundp-using-class class object (cddr cell))))
+ (slot-boundp-using-class (wrapper-class* wrapper) object (cddr cell))))
((not cell)
(return-from slot-boundp
- (and (slot-missing class object slot-name 'slot-boundp) t)))
+ (and (slot-missing (wrapper-class* wrapper) object slot-name
+ 'slot-boundp)
+ t)))
(t
(bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
(not (eq +slot-unbound+ value))))
@@ -197,8 +201,8 @@
form))
(defun slot-makunbound (object slot-name)
- (let* ((class (check-obsolete-instance/class-of object))
- (cell (find-slot-cell class slot-name))
+ (let* ((wrapper (check-obsolete-instance/wrapper-of object))
+ (cell (find-slot-cell wrapper slot-name))
(location (car cell)))
(cond ((fixnump location)
(if (std-instance-p object)
@@ -208,9 +212,9 @@
((consp location)
(setf (cdr location) +slot-unbound+))
((eq t location)
- (slot-makunbound-using-class class object (cddr cell)))
+ (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell)))
((not cell)
- (slot-missing class object slot-name 'slot-makunbound))
+ (slot-missing (wrapper-class* wrapper) object slot-name 'slot-makunbound))
(t
(bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell))))
object)
@@ -372,6 +376,8 @@
(let* ((function (slot-definition-internal-reader-function slotd))
(value (funcall function object)))
(declare (type function function))
+ ;; FIXME: Is this really necessary? Structure slots should surely
+ ;; never be unbound!
(if (eq value +slot-unbound+)
(values (slot-unbound class object (slot-definition-name slotd)))
value)))
Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.115
retrieving revision 1.116
diff -u -d -r1.115 -r1.116
--- std-class.lisp 29 Aug 2007 15:23:03 -0000 1.115
+++ std-class.lisp 29 Aug 2007 16:02:37 -0000 1.116
@@ -535,8 +535,8 @@
(setq cpl-available-p t)
(add-direct-subclasses class direct-superclasses)
(let ((slots (compute-slots class)))
- (setf (slot-value class 'slots) slots
- (slot-value class 'slot-table) (make-slot-table class slots)))))
+ (setf (slot-value class 'slots) slots)
+ (setf (layout-slot-table wrapper) (make-slot-table class slots)))))
;; Comment from Gerd's PCL, 2003-05-15:
;;
;; We don't ADD-SLOT-ACCESSORS here because we don't want to
@@ -717,11 +717,12 @@
(compute-class-precedence-list class))
(setf (slot-value class 'cpl-available-p) t)
(let ((slots (compute-slots class)))
- (setf (slot-value class 'slots) slots
- (slot-value class 'slot-table) (make-slot-table class slots)))
- (let ((lclass (find-classoid (class-name class))))
- (setf (classoid-pcl-class lclass) class)
- (setf (slot-value class 'wrapper) (classoid-layout lclass)))
+ (setf (slot-value class 'slots) slots)
+ (let* ((lclass (find-classoid (class-name class)))
+ (layout (classoid-layout lclass)))
+ (setf (classoid-pcl-class lclass) class)
+ (setf (slot-value class 'wrapper) layout)
+ (setf (layout-slot-table layout) (make-slot-table class slots))))
(setf (slot-value class 'finalized-p) t)
(update-pv-table-cache-info class)
(add-slot-accessors class direct-slots)))
@@ -895,11 +896,11 @@
(update-lisp-class-layout class nwrapper)
(setf (slot-value class 'slots) eslotds
- (slot-value class 'slot-table) (make-slot-table class eslotds)
(wrapper-instance-slots-layout nwrapper) nlayout
(wrapper-class-slots nwrapper) nwrapper-class-slots
(layout-length nwrapper) nslots
(slot-value class 'wrapper) nwrapper)
+ (setf (layout-slot-table nwrapper) (make-slot-table class eslotds))
(do* ((slots (slot-value class 'slots) (cdr slots))
(dupes nil))
((null slots)
@@ -1557,11 +1558,6 @@
(def class-direct-default-initargs)
(def class-default-initargs))
-(defmethod class-slot-table (class)
- ;; Default method to cause FIND-SLOT-DEFINITION return NIL for all
- ;; non SLOT-CLASS classes.
- #(nil))
-
(defmethod validate-superclass ((c class) (s built-in-class))
(or (eq s *the-class-t*) (eq s *the-class-stream*)
;; FIXME: bad things happen if someone tries to mix in both
Index: wrapper.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/wrapper.lisp,v
retrieving revision 1.5
retrieving revision 1.6
diff -u -d -r1.5 -r1.6
--- wrapper.lisp 27 Aug 2007 15:13:28 -0000 1.5
+++ wrapper.lisp 29 Aug 2007 16:02:38 -0000 1.6
@@ -188,11 +188,11 @@
(when (invalid-wrapper-p (layout-of instance))
(check-wrapper-validity instance)))
-(defun check-obsolete-instance/class-of (instance)
+(defun check-obsolete-instance/wrapper-of (instance)
(let ((wrapper (wrapper-of instance)))
(when (invalid-wrapper-p wrapper)
(check-wrapper-validity instance))
- (wrapper-class* wrapper)))
+ wrapper))
;;; NIL: means nothing so far, no actual arg info has NILs in the
;;; metatype.
|