From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Tue, 15 Aug 2006 08:49:51 +0000 (+0000)
Subject: 0.9.15.32:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=71922347ca66f2a3ad4c55092ccb3ad86a14c754;p=sbcl.git

0.9.15.32:
	More baby steps to the removal of the :fast-function initarg.
	This time, some permutation vector cleanups, partly motivated by
	similar changes in CMUCL and partly by the need to communicate
	information between a method function and the other method
	initargs.
	... remove the "interning" of permutation vectors themselves.
	... the first element of a permutation vector is no longer "for
		information"
	... destructively update the slots of a pv when the class
		changes.  (NB: this has threadsafety implications:
		revisit when the dust settles.)
	... delete the PV-TABLE-SYMBOL code; replace the somewhat crufty
		fashion of getting access to the method's pv-table
		(using symbol-value of an uninterned symbol, which is
		SET by INITIALIZE-METHOD-FUNCTION) by a LOAD-TIME-VALUE,
		relying on INTERN-PV-TABLE to, well, intern a PV table.
		(NB: this has performance implications if method
		functions are not compiled.)
	... some test cases: some simple tests of class redefinition and
		slot value, and some where there is a make-method-lambda
		customization.  Also log a failing case where the PV
		slot-value optimization is broken.
---

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index 672e483..ca6d811 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -757,19 +757,20 @@ bootstrapping.
               (when (some #'cdr slots)
                 (multiple-value-bind (slot-name-lists call-list)
                     (slot-name-lists-from-slots slots calls)
-                  (let ((pv-table-symbol (make-symbol "pv-table")))
-                    (setq plist
-                          `(,@(when slot-name-lists
-                                    `(:slot-name-lists ,slot-name-lists))
-                              ,@(when call-list
-                                      `(:call-list ,call-list))
-                              :pv-table-symbol ,pv-table-symbol
-                              ,@plist))
-                    (setq walked-lambda-body
-                          `((pv-binding (,required-parameters
-                                         ,slot-name-lists
-                                         ,pv-table-symbol)
-                              ,@walked-lambda-body))))))
+                  (setq plist
+                        `(,@(when slot-name-lists
+                                  `(:slot-name-lists ,slot-name-lists))
+                          ,@(when call-list
+                                  `(:call-list ,call-list))
+                          ,@plist))
+                  (setq walked-lambda-body
+                        `((pv-binding (,required-parameters
+                                       ,slot-name-lists
+                                       (load-time-value
+                                        (intern-pv-table
+                                         :slot-name-lists ',slot-name-lists
+                                         :call-list ',call-list)))
+                           ,@walked-lambda-body)))))
               (when (and (memq '&key lambda-list)
                          (not (memq '&allow-other-keys lambda-list)))
                 (let ((aux (memq '&aux lambda-list)))
@@ -1432,7 +1433,6 @@ bootstrapping.
   (let* ((mf (getf initargs :function))
          (method-spec (getf initargs :method-spec))
          (plist (getf initargs :plist))
-         (pv-table-symbol (getf plist :pv-table-symbol))
          (pv-table nil)
          (mff (getf initargs :fast-function)))
     (flet ((set-mf-property (p v)
@@ -1454,7 +1454,6 @@ bootstrapping.
           (when (or snl cl)
             (setq pv-table (intern-pv-table :slot-name-lists snl
                                             :call-list cl))
-            (when pv-table (set pv-table-symbol pv-table))
             (set-mf-property :pv-table pv-table)))
         (loop (when (null plist) (return nil))
               (set-mf-property (pop plist) (pop plist)))
diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp
index 121b97a..98344dd 100644
--- a/src/pcl/slots-boot.lisp
+++ b/src/pcl/slots-boot.lisp
@@ -437,52 +437,46 @@
                   (slot-value instance slot-name)))))))
 
 (defun make-std-reader-method-function (class-name slot-name)
-  (let* ((pv-table-symbol (gensym))
-         (initargs (copy-tree
+  (let* ((initargs (copy-tree
                     (make-method-function
                      (lambda (instance)
                        (pv-binding1 (.pv. .calls.
-                                          (symbol-value pv-table-symbol)
+                                          (bug "Please report this")
                                           (instance) (instance-slots))
                          (instance-read-internal
-                          .pv. instance-slots 1
+                          .pv. instance-slots 0
                           (slot-value instance slot-name))))))))
     (setf (getf (getf initargs :plist) :slot-name-lists)
           (list (list nil slot-name)))
-    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
     (list* :method-spec `(reader-method ,class-name ,slot-name)
            initargs)))
 
 (defun make-std-writer-method-function (class-name slot-name)
-  (let* ((pv-table-symbol (gensym))
-         (initargs (copy-tree
+  (let* ((initargs (copy-tree
                     (make-method-function
                      (lambda (nv instance)
                        (pv-binding1 (.pv. .calls.
-                                          (symbol-value pv-table-symbol)
+                                          (bug "Please report this")
                                           (instance) (instance-slots))
                          (instance-write-internal
-                          .pv. instance-slots 1 nv
+                          .pv. instance-slots 0 nv
                           (setf (slot-value instance slot-name) nv))))))))
     (setf (getf (getf initargs :plist) :slot-name-lists)
           (list nil (list nil slot-name)))
-    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
     (list* :method-spec `(writer-method ,class-name ,slot-name)
            initargs)))
 
 (defun make-std-boundp-method-function (class-name slot-name)
-  (let* ((pv-table-symbol (gensym))
-         (initargs (copy-tree
+  (let* ((initargs (copy-tree
                     (make-method-function
                      (lambda (instance)
                        (pv-binding1 (.pv. .calls.
-                                          (symbol-value pv-table-symbol)
+                                          (bug "Please report this")
                                           (instance) (instance-slots))
                           (instance-boundp-internal
-                           .pv. instance-slots 1
+                           .pv. instance-slots 0
                            (slot-boundp instance slot-name))))))))
     (setf (getf (getf initargs :plist) :slot-name-lists)
           (list (list nil slot-name)))
-    (setf (getf (getf initargs :plist) :pv-table-symbol) pv-table-symbol)
     (list* :method-spec `(boundp-method ,class-name ,slot-name)
            initargs)))
diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp
index a3c2970..c2590ec 100644
--- a/src/pcl/vector.lisp
+++ b/src/pcl/vector.lisp
@@ -85,7 +85,7 @@
       (let ((pv-table
              (outer (mapcar #'inner (cons call-list slot-name-lists)))))
         (when new-p
-          (let ((pv-index 1))
+          (let ((pv-index 0))
             (dolist (slot-name-list slot-name-lists)
               (dolist (slot-name (cdr slot-name-list))
                 (note-pv-table-reference slot-name pv-index pv-table)
@@ -132,60 +132,43 @@
         (maphash function entry)))
   ref)
 
-(defvar *pvs* (make-hash-table :test 'equal))
-
 (defun optimize-slot-value-by-class-p (class slot-name type)
   (or (not (eq *boot-state* 'complete))
       (let ((slotd (find-slot-definition class slot-name)))
         (and slotd
              (slot-accessor-std-p slotd type)))))
 
-(defun compute-pv-slot (slot-name wrapper class class-slots class-slot-p-cell)
+(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)
-            (let ((cell (assq slot-name class-slots)))
-              (when cell
-                (setf (car class-slot-p-cell) t)
-                cell))))
+            (assq slot-name class-slots)))
       (when (consp slot-name)
-        (dolist (type '(reader writer) nil)
-          (when (eq (car slot-name) type)
-            (return
-              (let* ((gf-name (cadr slot-name))
-                     (gf (gdefinition gf-name))
-                     (location (when (eq *boot-state* 'complete)
-                                 (accessor-values1 gf type class))))
-                (when (consp location)
-                  (setf (car class-slot-p-cell) t))
-                location)))))))
+        (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-name-lists wrappers)
-  (unless (listp wrappers) (setq wrappers (list wrappers)))
-  (let* ((not-simple-p-cell (list nil))
-         (elements
-          (let ((elements nil))
-            (dolist (slot-names slot-name-lists)
-              (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))))
-                  (dolist (slot-name (cdr slot-names))
-                    ;; Original PCL code had this idiom.  why not:
-                    ;;
-                    ;; (WHEN STD-P
-                    ;;   (PUSH ...)) ?
-                    (push (when std-p
-                            (compute-pv-slot slot-name wrapper class
-                                             class-slots not-simple-p-cell))
-                          elements)))))
-            (nreverse elements))))
-    (if (car not-simple-p-cell)
-        (make-permutation-vector (cons t elements))
-        (or (gethash elements *pvs*)
-            (setf (gethash elements *pvs*)
-                  (make-permutation-vector (cons nil elements)))))))
+  (unless (listp wrappers)
+    (setq wrappers (list wrappers)))
+  (let (elements)
+    (dolist (slot-names slot-name-lists
+             (make-permutation-vector (nreverse elements)))
+      (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))))
+          (dolist (slot-name (cdr slot-names))
+            (push (if std-p
+                      (compute-pv-slot slot-name wrapper class class-slots)
+                      nil)
+                  elements)))))))
 
 (defun compute-calls (call-list wrappers)
   (declare (ignore call-list wrappers))
@@ -271,14 +254,14 @@
   (let* ((cwrapper (class-wrapper class))
          (std-p (typep cwrapper 'wrapper))
          (class-slots (and std-p (wrapper-class-slots cwrapper)))
-         (class-slot-p-cell (list nil))
-         (new-values (mapcar (lambda (slot-name)
-                               (cons slot-name
-                                     (when std-p
-                                       (compute-pv-slot
-                                        slot-name cwrapper class
-                                        class-slots class-slot-p-cell))))
-                             slot-names))
+         (new-values
+          (mapcar
+           (lambda (slot-name)
+             (cons slot-name
+                   (if std-p
+                       (compute-pv-slot slot-name cwrapper class class-slots)
+                       nil)))
+           slot-names))
          (pv-tables nil))
     (dolist (slot-name slot-names)
       (map-pv-table-references-of
@@ -291,7 +274,7 @@
              (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 1) (param-index 0))
+        (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)))
@@ -301,48 +284,27 @@
             (incf param-index)))
         (when cache
           (map-cache (lambda (wrappers pv-cell)
-                       (setf (car pv-cell)
-                             (update-slots-in-pv wrappers (car pv-cell)
-                                                 cwrapper pv-size pv-map)))
+                       (update-slots-in-pv wrappers (car pv-cell)
+                                           cwrapper pv-size pv-map))
                      cache))))))
 
 (defun update-slots-in-pv (wrappers pv cwrapper pv-size pv-map)
-  (if (not (if (atom wrappers)
-               (eq cwrapper wrappers)
-               (dolist (wrapper wrappers nil)
-                 (when (eq wrapper cwrapper)
-                   (return t)))))
-      pv
-      (let* ((old-intern-p (listp (pvref pv 0)))
-             (new-pv (if old-intern-p
-                         (copy-pv pv)
-                         pv))
-             (new-intern-p t))
-        (if (atom wrappers)
-            (dotimes-fixnum (i pv-size)
-              (when (consp (let ((map (svref pv-map i)))
-                             (if map
-                                 (setf (pvref new-pv i) (cdr map))
-                                 (pvref new-pv i))))
-                (setq new-intern-p nil)))
-            (let ((param 0))
-              (dolist (wrapper wrappers)
-                (when (eq wrapper cwrapper)
-                  (dotimes-fixnum (i pv-size)
-                    (when (consp (let ((map (svref pv-map i)))
-                                   (if (and map (= (car map) param))
-                                       (setf (pvref new-pv i) (cdr map))
-                                       (pvref new-pv i))))
-                      (setq new-intern-p nil))))
-                (incf param))))
-        (when new-intern-p
-          (setq new-pv (let ((list-pv (coerce pv 'list)))
-                         (or (gethash (cdr list-pv) *pvs*)
-                             (setf (gethash (cdr list-pv) *pvs*)
-                                   (if old-intern-p
-                                       new-pv
-                                       (make-permutation-vector list-pv)))))))
-        new-pv)))
+  (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 (pvref 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 (pvref pv i) (cdr map))))))
+            (incf param))))))
 
 (defun maybe-expand-accessor-form (form required-parameters slots env)
   (let* ((fname (car form))
@@ -830,7 +792,7 @@
 (defun mutate-slots-and-calls (slots calls)
   (let ((sorted-slots (sort-slots slots))
         (sorted-calls (sort-calls (cdr calls)))
-        (pv-offset 0))  ; index 0 is for info
+        (pv-offset -1))
     (dolist (parameter-entry sorted-slots)
       (dolist (slot-entry (cdr parameter-entry))
         (incf pv-offset)
@@ -893,7 +855,7 @@
 ;;;; Automatically generated reader and writer functions use this
 ;;;; stuff too.
 
-(defmacro pv-binding ((required-parameters slot-name-lists pv-table-symbol)
+(defmacro pv-binding ((required-parameters slot-name-lists pv-table-form)
                       &body body)
   (let (slot-vars pv-parameters)
     (loop for slots in slot-name-lists
@@ -902,13 +864,13 @@
           do (when slots
                (push required-parameter pv-parameters)
                (push (slot-vector-symbol i) slot-vars)))
-    `(pv-binding1 (.pv. .calls. ,pv-table-symbol
+    `(pv-binding1 (.pv. .calls. ,pv-table-form
                    ,(nreverse pv-parameters) ,(nreverse slot-vars))
        ,@body)))
 
-(defmacro pv-binding1 ((pv calls pv-table-symbol pv-parameters slot-vars)
+(defmacro pv-binding1 ((pv calls pv-table-form pv-parameters slot-vars)
                        &body body)
-  `(pv-env (,pv ,calls ,pv-table-symbol ,pv-parameters)
+  `(pv-env (,pv ,calls ,pv-table-form ,pv-parameters)
      (let (,@(mapcar (lambda (slot-var p) `(,slot-var (get-slots-or-nil ,p)))
                      slot-vars pv-parameters))
        (declare (ignorable ,@(mapcar #'identity slot-vars)))
@@ -919,7 +881,7 @@
 (define-symbol-macro pv-env-environment overridden)
 
 (defmacro pv-env (&environment env
-                  (pv calls pv-table-symbol pv-parameters)
+                  (pv calls pv-table-form pv-parameters)
                   &rest forms)
   ;; Decide which expansion to use based on the state of the PV-ENV-ENVIRONMENT
   ;; symbol-macrolet.
@@ -930,17 +892,14 @@
                   ,(make-calls-type-declaration calls))
          ,pv ,calls
          ,@forms)
-      `(locally
-        ,@(when (symbolp pv-table-symbol)
-                `((declare (special ,pv-table-symbol))))
-        (let* ((.pv-table. ,pv-table-symbol)
-               (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
-               (,pv (car .pv-cell.))
-               (,calls (cdr .pv-cell.)))
-          (declare ,(make-pv-type-declaration pv))
-          (declare ,(make-calls-type-declaration calls))
-          ,pv ,calls
-          ,@forms))))
+      `(let* ((.pv-table. ,pv-table-form)
+              (.pv-cell. (pv-table-lookup-pv-args .pv-table. ,@pv-parameters))
+              (,pv (car .pv-cell.))
+              (,calls (cdr .pv-cell.)))
+        (declare ,(make-pv-type-declaration pv))
+        (declare ,(make-calls-type-declaration calls))
+        ,pv ,calls
+        ,@forms)))
 
 (defvar *non-var-declarations*
   ;; FIXME: VALUES was in this list, conditionalized with #+CMU, but I
diff --git a/tests/clos-1.impure.lisp b/tests/clos-1.impure.lisp
new file mode 100644
index 0000000..09b66f0
--- /dev/null
+++ b/tests/clos-1.impure.lisp
@@ -0,0 +1,89 @@
+;;;; miscellaneous side-effectful tests of CLOS
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; While most of SBCL is derived from the CMU CL system, the test
+;;;; files (like this one) were written from scratch after the fork
+;;;; from CMU CL.
+;;;;
+;;;; This software is in the public domain and is provided with
+;;;; absolutely no warranty. See the COPYING and CREDITS files for
+;;;; more information.
+
+;;; clos.impure.lisp was getting too big and confusing
+
+(load "assertoid.lisp")
+
+(defpackage "CLOS-1"
+  (:use "CL" "ASSERTOID" "TEST-UTIL"))
+
+;;; tests that various optimization paths for slot-valuish things
+;;; respect class redefinitions.
+(defclass foo ()
+  ((a :initarg :a)))
+
+(defvar *foo* (make-instance 'foo :a 1))
+
+(defmethod a-of ((x foo))
+  (slot-value x 'a))
+(defmethod b-of ((x foo))
+  (slot-value x 'b))
+(defmethod c-of ((x foo))
+  (slot-value x 'c))
+
+(let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
+  (dotimes (i 4) ; KLUDGE: get caches warm
+    (assert (= 1 (slot-value *foo* 'a)))
+    (assert (= 1 (a-of *foo*)))
+    (assert (= 1 (funcall fun *foo*)))
+    (assert (raises-error? (b-of *foo*)))
+    (assert (raises-error? (c-of *foo*)))))
+
+(defclass foo ()
+  ((b :initarg :b :initform 3) (a :initarg :a)))
+
+(let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
+  (dotimes (i 4) ; KLUDGE: get caches warm
+    (assert (= 1 (slot-value *foo* 'a)))
+    (assert (= 1 (a-of *foo*)))
+    (assert (= 1 (funcall fun *foo*)))
+    (assert (= 3 (b-of *foo*)))
+    (assert (raises-error? (c-of *foo*)))))
+
+(defclass foo ()
+  ((c :initarg :c :initform t :allocation :class)
+   (b :initarg :b :initform 3)
+   (a :initarg :a)))
+
+(let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
+  (dotimes (i 4) ; KLUDGE: get caches warm
+    (assert (= 1 (slot-value *foo* 'a)))
+    (assert (= 1 (a-of *foo*)))
+    (assert (= 1 (funcall fun *foo*)))
+    (assert (= 3 (b-of *foo*)))
+    (assert (eq t (c-of *foo*)))))
+
+(defclass foo ()
+  ((a :initarg :a)
+   (b :initarg :b :initform 3)
+   (c :initarg :c :initform t)))
+
+(let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
+  (dotimes (i 4) ; KLUDGE: get caches warm
+    (assert (= 1 (slot-value *foo* 'a)))
+    (assert (= 1 (a-of *foo*)))
+    (assert (= 1 (funcall fun *foo*)))
+    (assert (= 3 (b-of *foo*)))
+    (assert (eq t (c-of *foo*)))))
+
+(defclass foo ()
+  ((b :initarg :b :initform 3)))
+
+(let ((fun (compile nil '(lambda (x) (slot-value x 'a)))))
+  (dotimes (i 4) ; KLUDGE: get caches warm
+    (assert (raises-error? (slot-value *foo* 'a)))
+    (assert (raises-error? (a-of *foo*)))
+    (assert (raises-error? (funcall fun *foo*)))
+    (assert (= 3 (b-of *foo*)))
+    (assert (raises-error? (c-of *foo*)))))
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 84c7ec3..e5cc140 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -1383,4 +1383,22 @@
 (make-instances-obsolete (find-class 'obsolete-again))
 (assert (not (is-a-structure-object-p *obsolete-again*)))
 
+;;; overeager optimization of slot-valuish things
+(defclass listoid ()
+  ((caroid :initarg :caroid)
+   (cdroid :initarg :cdroid :initform nil)))
+(defmethod lengthoid ((x listoid))
+  (let ((result 0))
+    (loop until (null x)
+          do (incf result) (setq x (slot-value x 'cdroid)))
+    result))
+(with-test (:name ((:setq :method-parameter) slot-value) :fails-on :sbcl)
+  (assert (= (lengthoid (make-instance 'listoid)) 1))
+  (error "the failure mode is an infinite loop")
+  (assert (= (lengthoid
+              (make-instance 'listoid :cdroid
+                             (make-instance 'listoid :cdroid
+                                            (make-instance 'listoid))))
+             3)))
+
 ;;;; success
diff --git a/tests/mop-23.impure.lisp b/tests/mop-23.impure.lisp
index 45d4ac8..04d9cf5 100644
--- a/tests/mop-23.impure.lisp
+++ b/tests/mop-23.impure.lisp
@@ -53,3 +53,12 @@
                    (assert (equal (foo (make-instance 'sub :a 4))
                                   '(4 nil))))
                  "Called a method!Called a method!"))
+
+(defclass super () 
+  ((b :initform 3) 
+   (a :initarg :a)))
+
+(assert (string= (with-output-to-string (*trace-output*)
+                   (assert (equal (foo (make-instance 'sub :a 5))
+                                  '(5 t))))
+                 "Called a method!Called a method!"))
diff --git a/version.lisp-expr b/version.lisp-expr
index 967b43c..7c459ea 100644
--- 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".)
-"0.9.15.31"
+"0.9.15.32"