From: Nikodemus Siivola Date: Wed, 29 Aug 2007 16:02:35 +0000 (+0000) Subject: 1.0.9.11: even faster SLOT-VALUE &co X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=119d1c157e519573074720b7897a9fa918329ac5;p=sbcl.git 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. --- diff --git a/NEWS b/NEWS index 86c3dcf..d8e0a31 100644 --- a/NEWS +++ b/NEWS @@ -4,10 +4,10 @@ changes in sbcl-1.0.10 relative to sbcl-1.0.9: associates .lisp and .fasl files with the installed SBCL. * minor incompatible change: :UNIX is no longer present in *FEATURES* on Windows. (thanks to Luis Oliviera) - * 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: SLOT-VALUE &co are now ~50% faster for variable slot + names, when the class of the instance is a direct instance + STANDARD-CLASS or FUNCALLABLE-STANDARD-CLASS (making them only 3x + as slow as the constant slot-name case.) * optimization: member type construction is now O(N) instead of O(N^2). * optimization: UNION and NUNION are now O(N+M) for large diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 5797c73..95b0c48 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1316,6 +1316,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "KEY-INFO-NAME" "KEY-INFO-P" "KEY-INFO-TYPE" "LAYOUT-DEPTHOID" "LAYOUT-INVALID-ERROR" "LAYOUT-N-UNTAGGED-SLOTS" "LAYOUT-FOR-STD-CLASS-P" + "LAYOUT-SLOT-TABLE" #!+(or x86-64 x86) "%LEA" "LEXENV" "LEXENV-DESIGNATOR" "LINE-LENGTH" "ANSI-STREAM" "ANSI-STREAM-BIN" "ANSI-STREAM-BOUT" "ANSI-STREAM-CLOSE" diff --git a/src/code/class.lisp b/src/code/class.lisp index b7ada1f..6f8b8ca 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -186,6 +186,9 @@ (n-untagged-slots 0 :type index) ;; Definition location (source-location nil) + ;; Information about slots in the class to PCL: this provides fast + ;; access to slot-definitions and locations by name, etc. + (slot-table #(nil) :type simple-vector) ;; True IFF the layout belongs to a standand-instance or a ;; standard-funcallable-instance -- that is, true only if the layout ;; is really a wrapper. diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 46b7a6c..fd3f49a 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -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 diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index dff7856..068b49f 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -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 diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 5e181fd..fce40c0 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -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))) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 7fa3013..2784334 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -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))) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index de6b643..847d389 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -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 diff --git a/src/pcl/wrapper.lisp b/src/pcl/wrapper.lisp index ae181da..49738e5 100644 --- a/src/pcl/wrapper.lisp +++ b/src/pcl/wrapper.lisp @@ -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. diff --git a/tests/stream.impure.lisp b/tests/stream.impure.lisp index bc069b7..2db6606 100644 --- a/tests/stream.impure.lisp +++ b/tests/stream.impure.lisp @@ -415,7 +415,7 @@ (assert (= (type-error-datum condition) -1)) (assert (subtypep (type-error-expected-type condition) '(unsigned-byte 8)))))) - + (delete-file pathname)) ;;; writing looong lines. takes way too long and way too much space diff --git a/version.lisp-expr b/version.lisp-expr index e91bf0f..050f6db 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.9.10" +"1.0.9.11"