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
"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"
(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.
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
: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
;;; 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)))
(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)
(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
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
((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)
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)
(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))))
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)
((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)
(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)))
(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
(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)))
(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)
(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
(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))
\f
;;; NIL: means nothing so far, no actual arg info has NILs in the
;;; metatype.
(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
;;; 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"
projects / sbcl.git / commitdiff