From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Sun, 28 Feb 2010 19:05:39 +0000 (+0000)
Subject: 1.0.36.5: delay transforms for SLOT-VALUE and (SETF SLOT-VALUE)
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=a9588489d05f2d358886eb4aba39ca0a2a3de8b2;p=sbcl.git

1.0.36.5: delay transforms for SLOT-VALUE and (SETF SLOT-VALUE)

 Fixes launchpad bug #520366
---

diff --git a/NEWS b/NEWS
index 2d74cd5..8cb4f36 100644
--- a/NEWS
+++ b/NEWS
@@ -2,6 +2,9 @@
 changes relative to sbcl-1.0.36:
   * enhancement: Backtrace from THROW to uncaught tag on x86oids now shows
     stack frame thrown from.
+  * optimization: SLOT-VALUE and (SETF SLOT-VALUE) take advantage of
+    constraint propgation, allowing better compilation eg. when used to
+    access structures with WITH-SLOTS. (lp#520366)
   * bug fix: Fix compiler error involving MAKE-ARRAY and IF forms
     in :INITIAL-CONTENTS. (lp#523612)
   * bug fix: FUNCTION-LAMBDA-EXPRESSION lost declarations from interpreted
diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp
index e544e0b..d4e0257 100644
--- a/src/pcl/fixup.lisp
+++ b/src/pcl/fixup.lisp
@@ -43,7 +43,8 @@
 (defknown slot-value (t symbol) t (any))
 (defknown sb-pcl::set-slot-value (t symbol t) t (any))
 
-(deftransform slot-value ((object slot-name) (t (constant-arg symbol)))
+(deftransform slot-value ((object slot-name) (t (constant-arg symbol)) *
+                          :node node)
   (let ((c-slot-name (lvar-value slot-name)))
     (if (sb-pcl::interned-symbol-p c-slot-name)
         (let* ((type (lvar-type object))
@@ -52,9 +53,11 @@
                       (sb-kernel::structure-classoid-name type))))
                (dsd (when dd
                       (find c-slot-name (dd-slots dd) :key #'dsd-name))))
-          (if dsd
-              `(,(dsd-accessor-name dsd) object)
-              `(sb-pcl::accessor-slot-value object ',c-slot-name)))
+          (cond (dsd
+                 `(,(dsd-accessor-name dsd) object))
+                (t
+                 (delay-ir1-transform node :constraint)
+                 `(sb-pcl::accessor-slot-value object ',c-slot-name))))
         (give-up-ir1-transform "slot name is not an interned symbol"))))
 
 (deftransform sb-pcl::set-slot-value ((object slot-name new-value)
@@ -68,12 +71,14 @@
                       (sb-kernel::structure-classoid-name type))))
                (dsd (when dd
                       (find c-slot-name (dd-slots dd) :key #'dsd-name))))
-          (if dsd
-              `(setf (,(dsd-accessor-name dsd) object) new-value)
-              (if (policy node (= safety 3))
-                  ;; Safe code wants to check the type, and the global
-                  ;; accessor won't do that. Also see the comment in the
-                  ;; compiler-macro.
-                  (give-up-ir1-transform "cannot use optimized accessor in safe code")
-                  `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value))))
+          (cond (dsd
+                 `(setf (,(dsd-accessor-name dsd) object) new-value))
+                ((policy node (= safety 3))
+                 ;; Safe code wants to check the type, and the global
+                 ;; accessor won't do that. Also see the comment in the
+                 ;; compiler-macro.
+                 (give-up-ir1-transform "cannot use optimized accessor in safe code"))
+                (t
+                 (delay-ir1-transform node :constraint)
+                 `(sb-pcl::accessor-set-slot-value object ',c-slot-name new-value))))
         (give-up-ir1-transform "slot name is not an interned symbol"))))
diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp
index 7a313b9..b0f0490 100644
--- a/tests/clos.impure.lisp
+++ b/tests/clos.impure.lisp
@@ -11,8 +11,9 @@
 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
 ;;;; more information.
 
+(load "compiler-test-util.lisp")
 (defpackage "CLOS-IMPURE"
-  (:use "CL" "ASSERTOID" "TEST-UTIL"))
+  (:use "CL" "ASSERTOID" "TEST-UTIL" "COMPILER-TEST-UTIL"))
 (in-package "CLOS-IMPURE")
 
 ;;; It should be possible to do DEFGENERIC and DEFMETHOD referring to
@@ -1786,4 +1787,22 @@
     bug-485019)
   (bug-485019 (make-instance 'bug-485019)))
 
+;;; The compiler didn't propagate the declarared type before applying
+;;; the transform for (SETF SLOT-VALUE), so the generic accessor was used.
+(defstruct foo-520366
+  slot)
+(defun quux-520366 (cont)
+  (funcall cont))
+(defun bar-520366 (foo-struct)
+  (declare (type foo-520366 foo-struct))
+  (with-slots (slot) foo-struct
+    (tagbody
+       (quux-520366 #'(lambda ()
+                        (setf slot :value)
+                        (go TAG)))
+     TAG)))
+(with-test (:name :bug-520366)
+  (let ((callees (find-named-callees #'bar-520366)))
+    (assert (equal (list #'quux) callees))))
+
 ;;;; success
diff --git a/version.lisp-expr b/version.lisp-expr
index 4ccec24..f34d9ad 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".)
-"1.0.36.4"
+"1.0.36.5"