From: Alexey Dejneka <adejneka@comail.ru>
Date: Mon, 17 Nov 2003 11:47:09 +0000 (+0000)
Subject: 0.8.5.45:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f10dce4be24d44e1db0fb3d5b1d3689d6caa062a;p=sbcl.git

0.8.5.45:
        * Fix PFD bugs MISC.177, 182: in copy propagation a local
          lambda argument has a hidden write.
---

diff --git a/BUGS b/BUGS
index fed7fc3..c74909d 100644
--- a/BUGS
+++ b/BUGS
@@ -447,7 +447,9 @@ WORKAROUND:
     * '``(FOO ,@',@S)
     ``(FOO SB-IMPL::BACKQ-COMMA-AT S)
 
-  b. (fixed in 0.8.4.7)
+  c. (reported by Paul F. Dietz)
+     * '`(lambda ,x)
+     `(LAMBDA (SB-IMPL::BACKQ-COMMA X))
 
 143:
   (reported by Jesse Bouwman 2001-10-24 through the unfortunately
diff --git a/src/compiler/copyprop.lisp b/src/compiler/copyprop.lisp
index cd5293d..eefacbd 100644
--- a/src/compiler/copyprop.lisp
+++ b/src/compiler/copyprop.lisp
@@ -83,12 +83,18 @@
 				(primitive-type-scs
 				 (tn-primitive-type arg-tn)))
 		       (let ((leaf (tn-leaf tn)))
-			 ;; Do we not care about preserving this this
-			 ;; TN for debugging?
 			 (or (not leaf)
-			     (not (symbol-package (leaf-debug-name leaf)))
-			     (policy (vop-node vop)
-				     (or (= speed 3) (< debug 2)))))
+                             (and
+                              ;; Do we not care about preserving this this
+                              ;; TN for debugging?
+                              (or
+                               (not (symbol-package (leaf-debug-name leaf)))
+                               (policy (vop-node vop)
+                                       (or (= speed 3) (< debug 2))))
+                              ;; arguments of local functions have hidden write
+                              (not (and (lambda-var-p leaf)
+                                        (memq (functional-kind (lambda-var-home leaf))
+                                                   '(nil :optional)))))))
 		       arg-tn)))))))
 
 ;;; Init the sets in BLOCK for copy propagation. To find GEN, we just
@@ -107,8 +113,9 @@
 		     (when (tn-is-copy-of y)
 		       (sset-adjoin y gen)
 		       t)))
+        ;; WANTED: explanation of UNLESS above.
 	(do ((res (vop-results vop) (tn-ref-across res)))
-	    ((null res))
+	    ((not res))
 	  (let ((res-tn (tn-ref-tn res)))
 	    (do ((read (tn-reads res-tn) (tn-ref-next read)))
 		((null read))
@@ -118,7 +125,6 @@
 		    (when (tn-is-copy-of y)
 		      (sset-delete y gen)
 		      (sset-adjoin y kill))))))))))
-
     (setf (block-out block) (copy-sset gen))
     (setf (block-kill block) kill)
     (setf (block-gen block) gen))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 0b07cfc..45c22e8 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -940,3 +940,29 @@
                        -32326608))))
               1 2 3)
              -32326608))
+
+;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
+;;; local lambda argument
+(assert
+ (equal
+  (funcall
+   (compile nil
+            '(lambda (a b c)
+              (declare (type (integer 804561 7640697) a))
+              (declare (type (integer -1 10441401) b))
+              (declare (type (integer -864634669 55189745) c))
+              (declare (ignorable a b c))
+              (declare (optimize (speed 3)))
+              (declare (optimize (safety 1)))
+              (declare (optimize (debug 1)))
+              (flet ((%f11
+                         (f11-1 f11-2)
+                       (labels ((%f4 () (round 200048 (max 99 c))))
+                         (logand
+                          f11-1
+                          (labels ((%f3 (f3-1) -162967612))
+                            (%f3 (let* ((v8 (%f4)))
+                                   (setq f11-1 (%f4)))))))))
+                (%f11 -120429363 (%f11 62362 b)))))
+   6714367 9645616 -637681868)
+  -264223548))
diff --git a/version.lisp-expr b/version.lisp-expr
index 301c1fc..652311a 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.8.5.44"
+"0.8.5.45"