1.0.9.46: take pv-slot value from wrapper-slot-table

* Use NIL instead of T in the CAR of the SLOT-TABLE cells to indicate
  "slot location not saved for some reason".

* Better slot location computation for SLOT-TABLES: remaining wrapper
  copies now also copy the slot-table, and bootstrapping computes the
  slot locations for rest of the interesting cases.

* Use SLOT-TABLE to obtain the slot location for permutation vectors
  instead of WRAPPER-CLASS-SLOTS and WRAPPER-INSTANCE-SLOTS-LAYOUT.
  Faster, and slowly point the way to getting rid of WRAPPER/LAYOUT
  distinction.

* We deal with slot names in permutation vectors: remove the unused
  code that computed things for non-slot-name places in them.

diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp
index fd3f49a..2e0f11a 100644 (file)
--- a/src/pcl/braid.lisp
+++ b/src/pcl/braid.lisp
@@ -219,6 +219,8 @@
                      name class slots
                      standard-effective-slot-definition-wrapper t))
 
+              (setf (layout-slot-table wrapper) (make-slot-table class slots t))
+
               (case meta
                 ((standard-class funcallable-standard-class)
                  (!bootstrap-initialize-class
@@ -310,7 +312,10 @@
                                  slot-class))
       (set-slot 'direct-slots direct-slots)
       (set-slot 'slots slots)
-      (setf (layout-slot-table wrapper) (make-slot-table class slots)))
+      (setf (layout-slot-table wrapper)
+            (make-slot-table class slots
+                             (member metaclass-name
+                                     '(standard-class funcallable-standard-class)))))
 
     ;; 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/slots-boot.lisp b/src/pcl/slots-boot.lisp
index b96dbd0..1baa572 100644 (file)
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -530,7 +530,7 @@
 ;;; chains made out of plists keyed by the slot names. This fixes
 ;;; gives O(1) performance, and avoid the GF calls.
 ;;;
-;;; MAKE-SLOT-VECTOR constructs the hashed vector out of a list of
+;;; MAKE-SLOT-TABLE constructs the hashed vector out of a list of
 ;;; effective slot definitions and the class they pertain to, and
 ;;; FIND-SLOT-DEFINITION knows how to look up slots in that vector.
 ;;;
@@ -578,25 +578,27 @@
         (when (eq key slot-name)
           (return (car plist)))))))
 
-(defun make-slot-table (class slots)
+(defun make-slot-table (class slots &optional bootstrap)
   (let* ((n (+ (length slots) 2))
          (vector (make-array n :initial-element nil))
          (save-slot-location-p
-          (when (eq 'complete *boot-state*)
-            (let ((metaclass (class-of class)))
-              (or (eq metaclass *the-class-standard-class*)
-                  (eq metaclass *the-class-funcallable-standard-class*)))))
-         (save-type-check-function-p (and save-slot-location-p (safe-p class))))
+          (or bootstrap
+              (when (eq 'complete *boot-state*)
+                (let ((metaclass (class-of class)))
+                  (or (eq metaclass *the-class-standard-class*)
+                      (eq metaclass *the-class-funcallable-standard-class*))))))
+         (save-type-check-function-p
+          (unless bootstrap
+            (and save-slot-location-p (safe-p class)))))
     (flet ((add-to-vector (name slot)
              (declare (symbol name)
                       (optimize (sb-c::insert-array-bounds-checks 0)))
              (let ((index (rem (sxhash name) n)))
                (setf (svref vector index)
-                     (list* name (list* (if save-slot-location-p
-                                            (slot-definition-location slot)
-                                            ;; T tells SLOT-VALUE & SET-SLOT-VALUE
-                                            ;; that this is a non-standard class.
-                                            t)
+                     (list* name (list* (when save-slot-location-p
+                                          (if bootstrap
+                                              (early-slot-definition-location slot)
+                                              (slot-definition-location slot)))
                                         (when save-type-check-function-p
                                           (slot-definition-type-check-function slot))
                                         slot)

diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp
index 2784334..ed6c25a 100644 (file)
--- a/src/pcl/slots.lisp
+++ b/src/pcl/slots.lisp
@@ -107,13 +107,13 @@
                      (funcallable-standard-instance-access object location)))
                 ((consp location)
                  (cdr location))
-                ((eq t location)
-                 (return-from slot-value
-                   (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))))
                 ((not cell)
                  (return-from slot-value
                    (values (slot-missing (wrapper-class* wrapper) object slot-name
                                          'slot-value))))
+                ((not location)
+                 (return-from slot-value
+                   (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))))
                 (t
                  (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
     (if (eq +slot-unbound+ value)
@@ -141,11 +141,11 @@
                      new-value)))
           ((consp location)
            (setf (cdr location) new-value))
-          ((eq t location)
-           (setf (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))
-                 new-value))
           ((not cell)
            (slot-missing (wrapper-class* wrapper) object slot-name 'setf new-value))
+          ((not location)
+           (setf (slot-value-using-class (wrapper-class* wrapper) object (cddr cell))
+                 new-value))
           (t
            (bug "Bogus slot-cell in SET-SLOT-VALUE: ~S" cell))))
   new-value)
@@ -181,14 +181,14 @@
                      (funcallable-standard-instance-access object location)))
                 ((consp location)
                  (cdr location))
-                ((eq t location)
-                 (return-from slot-boundp
-                   (slot-boundp-using-class (wrapper-class* wrapper) object (cddr cell))))
                 ((not cell)
                  (return-from slot-boundp
                    (and (slot-missing (wrapper-class* wrapper) object slot-name
                                       'slot-boundp)
                         t)))
+                ((not location)
+                 (return-from slot-boundp
+                   (slot-boundp-using-class (wrapper-class* wrapper) object (cddr cell))))
                 (t
                  (bug "Bogus slot cell in SLOT-VALUE: ~S" cell)))))
     (not (eq +slot-unbound+ value))))
@@ -211,10 +211,10 @@
                      +slot-unbound+)))
           ((consp location)
            (setf (cdr location) +slot-unbound+))
-          ((eq t location)
-           (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell)))
           ((not cell)
            (slot-missing (wrapper-class* wrapper) object slot-name 'slot-makunbound))
+          ((not location)
+           (slot-makunbound-using-class (wrapper-class* wrapper) object (cddr cell)))
           (t
            (bug "Bogus slot-cell in SLOT-MAKUNBOUND: ~S" cell))))
   object)

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index 04cdc98..f22b2b0 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -896,10 +896,10 @@
 
       (update-lisp-class-layout class nwrapper)
       (setf (slot-value class 'slots) eslotds
-            (layout-slot-table nwrapper) (make-slot-table class eslotds)
+            (wrapper-slot-table nwrapper) (make-slot-table class eslotds)
             (wrapper-instance-slots-layout nwrapper) nlayout
             (wrapper-class-slots nwrapper) nwrapper-class-slots
-            (layout-length nwrapper) nslots
+            (wrapper-length nwrapper) nslots
             (slot-value class 'wrapper) nwrapper)
       (do* ((slots (slot-value class 'slots) (cdr slots))
             (dupes nil))
@@ -1312,6 +1312,8 @@
           (wrapper-instance-slots-layout owrapper))
     (setf (wrapper-class-slots nwrapper)
           (wrapper-class-slots owrapper))
+    (setf (wrapper-slot-table nwrapper)
+          (wrapper-slot-table owrapper))
     (with-pcl-lock
         (update-lisp-class-layout class nwrapper)
       (setf (slot-value class 'wrapper) nwrapper)

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 9aef26d..27e6bfe 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -37,14 +37,6 @@
 ;;;; to each such (GF . ARGS) tuple inside a method body, and use this
 ;;;; to cache effective method functions.
 \f
-(defmacro instance-slot-index (wrapper slot-name)
-  `(let ((pos 0))
-     (declare (fixnum pos))
-     (block loop
-       (dolist (sn (wrapper-instance-slots-layout ,wrapper))
-         (when (eq ,slot-name sn) (return-from loop pos))
-         (incf pos)))))
-\f
 (declaim (inline make-pv-table))
 (defstruct (pv-table (:predicate pv-tablep)
                      (:copier nil))
@@ -106,20 +98,9 @@
         (and slotd
              (slot-accessor-std-p slotd type)))))
 
-(defun compute-pv-slot (slot-name wrapper class class-slots)
-  (if (symbolp slot-name)
-      (when (optimize-slot-value-by-class-p class slot-name 'all)
-        (or (instance-slot-index wrapper slot-name)
-            (assq slot-name class-slots)))
-      (when (consp slot-name)
-        (case (first slot-name)
-          ((reader writer)
-           (when (eq *boot-state* 'complete)
-             (let ((gf (gdefinition (second slot-name))))
-               (when (generic-function-p gf)
-                 (accessor-values1 gf (first slot-name) class)))))
-          (t (bug "Don't know how to deal with ~S in ~S"
-                  slot-name 'compute-pv-slots))))))
+(defun compute-pv-slot (slot-name wrapper class)
+  (when (optimize-slot-value-by-class-p class slot-name 'all)
+    (car (find-slot-cell wrapper slot-name))))
 
 (defun compute-pv (slot-name-lists wrappers)
   (unless (listp wrappers)
@@ -129,11 +110,10 @@
       (when slot-names
         (let* ((wrapper (pop wrappers))
                (std-p (typep wrapper 'wrapper))
-               (class (wrapper-class* wrapper))
-               (class-slots (and std-p (wrapper-class-slots wrapper))))
+               (class (wrapper-class* wrapper)))
           (dolist (slot-name (cdr slot-names))
             (push (if std-p
-                      (compute-pv-slot slot-name wrapper class class-slots)
+                      (compute-pv-slot slot-name wrapper class)
                       nil)
                   elements)))))
     (let* ((n (length elements))
@@ -180,13 +160,12 @@
 (defun update-all-pv-table-caches (class slot-names)
   (let* ((cwrapper (class-wrapper class))
          (std-p (typep cwrapper 'wrapper))
-         (class-slots (and std-p (wrapper-class-slots cwrapper)))
          (new-values
           (mapcar
            (lambda (slot-name)
              (cons slot-name
                    (if std-p
-                       (compute-pv-slot slot-name cwrapper class class-slots)
+                       (compute-pv-slot slot-name cwrapper class)
                        nil)))
            slot-names))
          (pv-tables nil))

diff --git a/version.lisp-expr b/version.lisp-expr
index 6729757..b1458fb 100644 (file)
--- 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.45"
+"1.0.9.46"