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
(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
(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))
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
: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
(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)))))))
(t
(error "unrecognized instance type")))))
\f
-(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)
(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
(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)))
(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)
;;; 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"
projects / sbcl.git / commitdiff