From: Nikodemus Siivola Date: Tue, 17 Jul 2007 18:36:33 +0000 (+0000) Subject: 1.0.7.26: asymptotically faster FIND-SLOT-DEFINITION X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=0ee1135a83da462e6de2a98bb2eff837b278f926;p=sbcl.git 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. --- diff --git a/NEWS b/NEWS index 0609e7f..56332d4 100644 --- a/NEWS +++ b/NEWS @@ -9,6 +9,8 @@ changes in sbcl-1.0.8 relative to sbcl-1.0.7: and x86-64. * performance bug fix: GETHASH and (SETF GETHASH) are once again non-consing. + * optimization: slot definition lookup is now O(1). This speeds up + eg. SLOT-VALUE and (SETF SLOT-VALUE) with variable slot names. * optimization: STRING-TO-OCTETS is now up to 60% faster for UTF-8. * optimization: MEMBER can now be open-coded for all combinations of keyword arguments when second argument is constant, and in other diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp index 9258e7f..8fae87c 100644 --- a/src/compiler/seqtran.lisp +++ b/src/compiler/seqtran.lisp @@ -304,7 +304,7 @@ (cond ((csubtypep key-type null-type) (values nil nil)) ((csubtypep null-type key-type) - (values key '(if key + (values key '(if key (%coerce-callable-to-fun key) #'identity))) (t diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 8f3a2da..7b6fb1a 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -343,13 +343,13 @@ bootstrapping. (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)) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 7b00490..5fcad4d 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -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 diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 703a7b5..9a718ab 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -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 diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp index 83e9721..b7b4f21 100644 --- a/src/pcl/fixup.lisp +++ b/src/pcl/fixup.lisp @@ -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))))))) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index b9ee309..266a085 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -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) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 9f2b8c1..b63d660 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -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 - "~@~@:>" - 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) diff --git a/version.lisp-expr b/version.lisp-expr index a0068ef..910b093 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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.7.25" +"1.0.7.26"