Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs8.sourceforge.net:/tmp/cvs-serv12788/src/pcl
Modified Files:
boot.lisp braid.lisp defs.lisp fixup.lisp slots.lisp
std-class.lisp
Log Message:
1.0.7.26: asymptotically faster FIND-SLOT-DEFINITION
* Add a SLOT-VECTOR slot the SLOT-CLASS. The SLOT-VECTOR contains
plists of slot definition objects hashed on the slot name, allowing
O(1) lookups based on the slot name, instead of the old O(N)
lookups -- where N is the number of slots in a class.
Makes everything requiring slot definition lookups faster, simple
tests showing SLOT-VALUE with variable name on a 5-slot class to be
roughly 50% faster.
Index: boot.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/boot.lisp,v
retrieving revision 1.137
retrieving revision 1.138
diff -u -d -r1.137 -r1.138
--- boot.lisp 17 Jul 2007 11:24:30 -0000 1.137
+++ boot.lisp 17 Jul 2007 18:36:33 -0000 1.138
@@ -343,13 +343,13 @@
(eval-when (:execute)
(%defmethod-expander ,name ,qualifiers ,lambda-list ,body)))))
-(defmacro %defmethod-expander
+(defmacro %defmethod-expander
(name qualifiers lambda-list body &environment env)
(multiple-value-bind (proto-gf proto-method)
(prototypes-for-make-method-lambda name)
(expand-defmethod name proto-gf proto-method qualifiers
lambda-list body env)))
-
+
(defun prototypes-for-make-method-lambda (name)
(if (not (eq *boot-state* 'complete))
Index: braid.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v
retrieving revision 1.64
retrieving revision 1.65
diff -u -d -r1.64 -r1.65
--- braid.lisp 7 Dec 2006 12:51:27 -0000 1.64
+++ braid.lisp 17 Jul 2007 18:36:34 -0000 1.65
@@ -309,7 +309,8 @@
structure-class condition-class
slot-class))
(set-slot 'direct-slots direct-slots)
- (set-slot 'slots slots))
+ (set-slot 'slots slots)
+ (set-slot 'slot-vector (make-slot-vector 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.59
retrieving revision 1.60
diff -u -d -r1.59 -r1.60
--- defs.lisp 11 Jun 2007 13:47:39 -0000 1.59
+++ defs.lisp 17 Jul 2007 18:36:34 -0000 1.60
@@ -660,7 +660,32 @@
:accessor class-direct-slots)
(slots
:initform ()
- :accessor class-slots)))
+ :accessor class-slots)
+ (slot-vector
+ :initform #(nil)
+ :reader class-slot-vector)))
+
+;;; Make the slot-vector accessed by the after-fixup FIND-SLOT-DEFINITION.
+;;; The slot vector is a simple-vector containing plists of slot-definitions
+;;; keyd by their names. Slot definitions are put in the position indicated
+;;; by (REM (SXHASH SLOT-NAME) (LENGTH SLOT-VECTOR)).
+;;;
+;;; We make the vector slightly longer then the number of slots both
+;;; to reduce collisions (but we're not too picky, really) and to
+;;; allow FIND-SLOT-DEFINTIONS work on slotless classes without
+;;; needing to check for zero-length vectors.
+(defun make-slot-vector (slots)
+ (let* ((n (+ (length slots) 2))
+ (vector (make-array n :initial-element nil)))
+ (flet ((add-to-vector (name slot)
+ (setf (svref vector (rem (sxhash name) n))
+ (list* name slot (svref vector (rem (sxhash name) n))))))
+ (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))))
+ vector))
;;; The class STD-CLASS is an implementation-specific common
;;; superclass of the classes STANDARD-CLASS and
Index: fixup.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/fixup.lisp,v
retrieving revision 1.6
retrieving revision 1.7
diff -u -d -r1.6 -r1.7
--- fixup.lisp 2 Jun 2007 09:04:16 -0000 1.6
+++ fixup.lisp 17 Jul 2007 18:36:34 -0000 1.7
@@ -34,3 +34,16 @@
(defun print-std-instance (instance stream depth)
(declare (ignore depth))
(print-object instance stream))
+
+;;; Access the slot-vector created by MAKE-SLOT-VECTOR.
+(defun find-slot-definition (class slot-name)
+ (declare (symbol slot-name) (inline getf))
+ (let* ((vector (class-slot-vector class))
+ (index (rem (sxhash slot-name) (length vector))))
+ (declare (simple-vector vector) (index index))
+ (do ((plist (svref vector index) (cdr plist)))
+ ((not plist))
+ (let ((key (car plist)))
+ (setf plist (cdr plist))
+ (when (eq key slot-name)
+ (return (car plist)))))))
Index: slots.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/slots.lisp,v
retrieving revision 1.27
retrieving revision 1.28
diff -u -d -r1.27 -r1.28
--- slots.lisp 12 Jul 2007 17:28:40 -0000 1.27
+++ slots.lisp 17 Jul 2007 18:36:34 -0000 1.28
@@ -75,10 +75,11 @@
(t
(error "unrecognized instance type")))))
-(defun find-slot-definition (class slot-name)
+(defun early-find-slot-definition (class slot-name)
(dolist (slot (class-slots class) nil)
(when (eql slot-name (slot-definition-name slot))
(return slot))))
+(setf (fdefinition 'find-slot-definition) #'early-find-slot-definition)
(declaim (ftype (sfunction (t symbol) t) slot-value))
(defun slot-value (object slot-name)
Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.111
retrieving revision 1.112
diff -u -d -r1.111 -r1.112
--- std-class.lisp 1 Jul 2007 16:35:05 -0000 1.111
+++ std-class.lisp 17 Jul 2007 18:36:34 -0000 1.112
@@ -534,7 +534,9 @@
(setq %class-precedence-list (compute-class-precedence-list class))
(setq cpl-available-p t)
(add-direct-subclasses class direct-superclasses)
- (setf (slot-value class 'slots) (compute-slots class))))
+ (let ((slots (compute-slots class)))
+ (setf (slot-value class 'slots) slots
+ (slot-value class 'slot-vector) (make-slot-vector slots)))))
;; Comment from Gerd's PCL, 2003-05-15:
;;
;; We don't ADD-SLOT-ACCESSORS here because we don't want to
@@ -714,7 +716,9 @@
(setf (slot-value class '%class-precedence-list)
(compute-class-precedence-list class))
(setf (slot-value class 'cpl-available-p) t)
- (setf (slot-value class 'slots) (compute-slots class))
+ (let ((slots (compute-slots class)))
+ (setf (slot-value class 'slots) slots
+ (slot-value class 'slot-vector) (make-slot-vector slots)))
(let ((lclass (find-classoid (class-name class))))
(setf (classoid-pcl-class lclass) class)
(setf (slot-value class 'wrapper) (classoid-layout lclass)))
@@ -889,31 +893,31 @@
(make-instances-obsolete class)
(class-wrapper class)))))
- (with-slots (wrapper slots) class
- (update-lisp-class-layout class nwrapper)
- (setf slots eslotds
- (wrapper-instance-slots-layout nwrapper) nlayout
- (wrapper-class-slots nwrapper) nwrapper-class-slots
- (layout-length nwrapper) nslots
- wrapper nwrapper)
- (do* ((slots (slot-value class 'slots) (cdr slots))
- (dupes nil))
- ((null slots)
- (when dupes
- (style-warn
- "~@<slot names with the same SYMBOL-NAME but ~
+ (update-lisp-class-layout class nwrapper)
+ (setf (slot-value class 'slots) eslotds
+ (slot-value class 'slot-vector) (make-slot-vector eslotds)
+ (wrapper-instance-slots-layout nwrapper) nlayout
+ (wrapper-class-slots nwrapper) nwrapper-class-slots
+ (layout-length nwrapper) nslots
+ (slot-value class 'wrapper) nwrapper)
+ (do* ((slots (slot-value class 'slots) (cdr slots))
+ (dupes nil))
+ ((null slots)
+ (when dupes
+ (style-warn
+ "~@<slot names with the same SYMBOL-NAME but ~
different SYMBOL-PACKAGE (possible package problem) ~
for class ~S:~4I~@:_~<~@{~S~^~:@_~}~:>~@:>"
- class dupes)))
- (let* ((slot (car slots))
- (oslots (remove (slot-definition-name slot) (cdr slots)
- :test #'string/=
- :key #'slot-definition-name)))
- (when oslots
- (pushnew (cons (slot-definition-name slot)
- (mapcar #'slot-definition-name oslots))
- dupes
- :test #'string= :key #'car)))))
+ class dupes)))
+ (let* ((slot (car slots))
+ (oslots (remove (slot-definition-name slot) (cdr slots)
+ :test #'string/=
+ :key #'slot-definition-name)))
+ (when oslots
+ (pushnew (cons (slot-definition-name slot)
+ (mapcar #'slot-definition-name oslots))
+ dupes
+ :test #'string= :key #'car))))
(setf (slot-value class 'finalized-p) t)
(unless (eq owrapper nwrapper)
(update-pv-table-cache-info class)
|