1.0.9.54: clean up old pv updating code

* Since the vectors that are updated are referred to by stale
  wrappers, this seems to be quite useless: if an instance has an
  invalid wrapper it will still have the old layout as well.

diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index f22b2b0..f8e62f9 100644 (file)
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -106,9 +106,7 @@
             (get-accessor-method-function gf type class slotd)
             (get-optimized-std-accessor-method-function class slotd type))
       (setf (slot-accessor-std-p slotd type) std-p)
-      (setf (slot-accessor-function slotd type) function))
-    (when (and old-slotd (not (eq old-std-p (slot-accessor-std-p slotd 'all))))
-      (push (cons class name) *pv-table-cache-update-info*))))
+      (setf (slot-accessor-function slotd type) function))))
 
 (defmethod slot-definition-allocation ((slotd structure-slot-definition))
   :instance)
@@ -550,7 +548,7 @@
   ;; remove slot accessors but never put them back.  I've added a
   ;; REINITIALIZE-INSTANCE :AFTER (CONDITION-CLASS) method, but what
   ;; was meant to happen?  -- CSR, 2005-11-18
-  (update-pv-table-cache-info class))
+  )
 
 (defmethod direct-slot-definition-class ((class condition-class)
                                          &rest initargs)
@@ -724,7 +722,6 @@
         (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)))
 
 (defmethod direct-slot-definition-class ((class structure-class) &rest initargs)
@@ -921,7 +918,6 @@
                      :test #'string= :key #'car))))
       (setf (slot-value class 'finalized-p) t)
       (unless (eq owrapper nwrapper)
-        (update-pv-table-cache-info class)
         (maybe-update-standard-class-locations class)))))
 
 (defun compute-class-slots (eslotds)

diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index 4a20240..63299b9 100644 (file)
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -55,9 +55,6 @@
 ;;; used.
 (defvar *pv-tables* (make-hash-table :test 'equal))
 
-;;; Indexes PV-TABLES by indivisual slot names used.
-(defvar *pv-tables-by-slots* (make-hash-table :test 'equal))
-
 ;;; ...and one lock to rule them. Spinlock because for certain (rare)
 ;;; cases this lock might be grabbed in the course of method dispatch
 ;;; -- and mostly this is already under the *big-compiler-lock*.
@@ -65,32 +62,23 @@
   (sb-thread::make-spinlock :name "pv table index lock"))
 
 (defun intern-pv-table (&key slot-name-lists)
-  (let ((new-p nil))
-    (flet ((intern-slot-names (slot-names)
-             (or (gethash slot-names *slot-name-lists*)
-                 (setf (gethash slot-names *slot-name-lists*) slot-names)))
-           (%intern-pv-table (snl)
-             (or (gethash snl *pv-tables*)
-                 (setf (gethash snl *pv-tables*)
-                       (progn
-                         (setq new-p t)
-                         (make-pv-table :slot-name-lists snl))))))
-      (sb-thread::with-spinlock (*pv-lock*)
-        (let ((pv-table
-               (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists))))
-          (when new-p
-            (let ((pv-index 0))
-              (dolist (slot-name-list slot-name-lists)
-                (dolist (slot-name (cdr slot-name-list))
-                  (pushnew pv-table (gethash slot-name *pv-tables-by-slots*))
-                  (incf pv-index)))
-              (setf (pv-table-pv-size pv-table) pv-index)))
-          pv-table)))))
-
-(defun map-pv-table-references-of (slot-name function)
-  (dolist (table (sb-thread::with-spinlock (*pv-lock*)
-                   (gethash slot-name *pv-tables-by-slots*)))
-    (funcall function table)))
+  (flet ((intern-slot-names (slot-names)
+           ;; FIXME: NIL at the head of the list is a remnant from
+           ;; old purged code, that hasn't been quite cleaned up yet.
+           ;; ...but as long as we assume it is there, we may as well
+           ;; assert it.
+           (aver (not (car slot-names)))
+           (or (gethash slot-names *slot-name-lists*)
+               (setf (gethash slot-names *slot-name-lists*) slot-names)))
+         (%intern-pv-table (snl)
+           (or (gethash snl *pv-tables*)
+               (setf (gethash snl *pv-tables*)
+                     (make-pv-table :slot-name-lists snl
+                                    :pv-size (reduce #'+ snl
+                                                     :key (lambda (slots)
+                                                            (length (cdr slots)))))))))
+    (sb-thread::with-spinlock (*pv-lock*)
+      (%intern-pv-table (mapcar #'intern-slot-names slot-name-lists)))))
 \f
 (defun optimize-slot-value-by-class-p (class slot-name type)
   (or (not (eq *boot-state* 'complete))
@@ -143,73 +131,6 @@
 
 (defun make-pv-type-declaration (var)
   `(type simple-vector ,var))
-
-(defvar *pv-table-cache-update-info* nil)
-
-(defun update-pv-table-cache-info (class)
-  (let ((slot-names-for-pv-table-update nil)
-        (new-icui nil))
-    (dolist (icu *pv-table-cache-update-info*)
-      (if (eq (car icu) class)
-          (pushnew (cdr icu) slot-names-for-pv-table-update)
-          (push icu new-icui)))
-    (setq *pv-table-cache-update-info* new-icui)
-    (when slot-names-for-pv-table-update
-      (update-all-pv-table-caches class slot-names-for-pv-table-update))))
-
-(defun update-all-pv-table-caches (class slot-names)
-  (let* ((cwrapper (class-wrapper class))
-         (std-p (typep cwrapper 'wrapper))
-         (new-values
-          (mapcar
-           (lambda (slot-name)
-             (cons slot-name
-                   (if std-p
-                       (compute-pv-slot slot-name cwrapper class)
-                       nil)))
-           slot-names))
-         (pv-tables nil))
-    (dolist (slot-name slot-names)
-      (map-pv-table-references-of
-       slot-name
-       (lambda (pv-table)
-         (pushnew pv-table pv-tables))))
-    (dolist (pv-table pv-tables)
-      (let* ((cache (pv-table-cache pv-table))
-             (slot-name-lists (pv-table-slot-name-lists pv-table))
-             (pv-size (pv-table-pv-size pv-table))
-             (pv-map (make-array pv-size :initial-element nil)))
-        (let ((map-index 0) (param-index 0))
-          (dolist (slot-name-list slot-name-lists)
-            (dolist (slot-name (cdr slot-name-list))
-              (let ((a (assoc slot-name new-values)))
-                (setf (svref pv-map map-index)
-                      (and a (cons param-index (cdr a)))))
-              (incf map-index))
-            (incf param-index)))
-        (when cache
-          (map-cache (lambda (wrappers pv)
-                       (update-slots-in-pv wrappers pv
-                                           cwrapper pv-size pv-map))
-                     cache))))))
-
-(defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
-  (if (atom wrappers)
-      (when (eq cwrapper wrappers)
-        (dotimes-fixnum (i pv-size)
-          (let ((map (svref pv-map i)))
-            (when map
-              (aver (= (car map) 0))
-              (setf (svref pv i) (cdr map))))))
-      (when (memq cwrapper wrappers)
-        (let ((param 0))
-          (dolist (wrapper wrappers)
-            (when (eq wrapper cwrapper)
-              (dotimes-fixnum (i pv-size)
-                (let ((map (svref pv-map i)))
-                  (when (and map (= (car map) param))
-                    (setf (svref pv i) (cdr map))))))
-            (incf param))))))
 \f
 (defun can-optimize-access (form required-parameters env)
   (destructuring-bind (op var-form slot-name-form &optional new-value) form
@@ -927,7 +848,8 @@
         collect (valid-wrapper-of arg)))
 
 (defun pv-wrappers-from-all-args (pv-table args)
-  (loop for snl in (pv-table-slot-name-lists pv-table) and arg in args
+  (loop for snl in (pv-table-slot-name-lists pv-table)
+        and arg in args
         when snl
         collect (valid-wrapper-of arg)))
 

diff --git a/version.lisp-expr b/version.lisp-expr
index fff1f21..f58656f 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.53"
+"1.0.9.54"