[Sbcl-commits] CVS: sbcl/src/pcl braid.lisp,1.56,1.57 defs.lisp,1.50,1.51 dfun.lisp,1.45,1.46 std-class.lisp,1.93,1.94

[Juho S. <js...@us...>]

Update of /cvsroot/sbcl/sbcl/src/pcl
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv2035/src/pcl

Modified Files:
	braid.lisp defs.lisp dfun.lisp std-class.lisp 
Log Message:
0.9.10.41:
	Kill the silly *NAME->CLASS->SLOTD-TABLE* PCL cache.
        
        * Remove the code that updated the table
        * Rewrite the only user of the data stored in the table 
          (MAKE-ACCESSOR-TABLE) to recompute it from scratch each time
        * Which actually ends up being faster than using the table,
          speeding the loading of CLOS-using FASLs a bit
        * Reduce core size by a 900 kB on x86-64


Index: braid.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/braid.lisp,v
retrieving revision 1.56
retrieving revision 1.57
diff -u -d -r1.56 -r1.57
--- braid.lisp	27 Feb 2006 11:02:12 -0000	1.56
+++ braid.lisp	16 Mar 2006 18:57:18 -0000	1.57
@@ -370,11 +370,7 @@
                                      fsc-p nil slot-name index))
           (set-val 'boundp-function (make-optimized-std-boundp-method-function
                                      fsc-p nil slot-name index)))
-        (set-val 'accessor-flags 7)
-        (let ((table (or (gethash slot-name *name->class->slotd-table*)
-                         (setf (gethash slot-name *name->class->slotd-table*)
-                               (make-hash-table :test 'eq :size 5)))))
-          (setf (gethash class table) slotd)))
+        (set-val 'accessor-flags 7))
       (when (and (eq name 'standard-class)
                  (eq slot-name 'slots) effective-p)
         (setq *the-eslotd-standard-class-slots* slotd))

Index: defs.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/defs.lisp,v
retrieving revision 1.50
retrieving revision 1.51
diff -u -d -r1.50 -r1.51
--- defs.lisp	27 Feb 2006 11:02:12 -0000	1.50
+++ defs.lisp	16 Mar 2006 18:57:18 -0000	1.51
@@ -200,8 +200,6 @@
 (defun variable-class (var env)
   (caddr (var-declaration 'class var env)))
 
-(defvar *name->class->slotd-table* (make-hash-table))
-
 (defvar *standard-method-combination*)
 
 (defun plist-value (object name)

Index: dfun.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/dfun.lisp,v
retrieving revision 1.45
retrieving revision 1.46
diff -u -d -r1.45 -r1.46
--- dfun.lisp	27 Feb 2006 11:02:12 -0000	1.45
+++ dfun.lisp	16 Mar 2006 18:57:18 -0000	1.46
@@ -1326,21 +1326,26 @@
                                   method))
                             (accessor-method-slot-name method))))
         (when (or (null specl-cpl)
+                  (null so-p)
                   (member *the-class-structure-object* specl-cpl))
           (return-from make-accessor-table nil))
-        (maphash (lambda (class slotd)
-                   (let ((cpl (if early-p
-                                  (early-class-precedence-list class)
-                                  (class-precedence-list class))))
-                     (when (memq specl cpl)
-                       (unless (and (or so-p
-                                        (member *the-class-standard-object*
-                                                cpl))
-                                    (or early-p
-                                        (slot-accessor-std-p slotd type)))
+        ;; Collect all the slot-definitions for SLOT-NAME from SPECL and
+        ;; all of its subclasses. If either SPECL or one of the subclasses
+        ;; is not a standard-class, bail out.
+        (labels ((aux (class)
+                   ;; FIND-SLOT-DEFINITION might not be defined yet
+                   (let ((slotd (find-if (lambda (x)
+                                           (eq (sb-pcl::slot-definition-name x)
+                                               slot-name))
+                                         (sb-pcl::class-slots class))))
+                     (when slotd
+                       (unless (or early-p
+                                   (slot-accessor-std-p slotd type))
                          (return-from make-accessor-table nil))
-                       (push (cons specl slotd) (gethash class table)))))
-                 (gethash slot-name *name->class->slotd-table*))))
+                       (push (cons specl slotd) (gethash class table))))
+                   (dolist (subclass (sb-pcl::class-direct-subclasses class))
+                     (aux subclass))))
+          (aux specl))))
     (maphash (lambda (class specl+slotd-list)
                (dolist (sclass (if early-p
                                    (early-class-precedence-list class)

Index: std-class.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/src/pcl/std-class.lisp,v
retrieving revision 1.93
retrieving revision 1.94
diff -u -d -r1.93 -r1.94
--- std-class.lisp	10 Mar 2006 17:40:27 -0000	1.93
+++ std-class.lisp	16 Mar 2006 18:57:18 -0000	1.94
@@ -73,10 +73,6 @@
                                                 effective-slot-definition))
   (let* ((name (slot-value slotd 'name))
          (class (slot-value slotd '%class)))
-    (let ((table (or (gethash name *name->class->slotd-table*)
-                     (setf (gethash name *name->class->slotd-table*)
-                           (make-hash-table :test 'eq :size 5)))))
-      (setf (gethash class table) slotd))
     (dolist (type '(reader writer boundp))
       (let* ((gf-name (ecase type
                               (reader 'slot-value-using-class)