X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fcopyprop.lisp;h=eefacbdd397e18ecdd76294f5ebc8b162e2d4a3f;hb=94ea2b2082deaa0331dfb66fa6af6ca12dd8dc83;hp=4977d1cb9fd17c8a06b120df7dcf4008c3d1999d;hpb=1a6def3955b715472eb2c75b15660912b9f90173;p=sbcl.git

diff --git a/src/compiler/copyprop.lisp b/src/compiler/copyprop.lisp
index 4977d1c..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,9 +125,8 @@
 		    (when (tn-is-copy-of y)
 		      (sset-delete y gen)
 		      (sset-adjoin y kill))))))))))
-
     (setf (block-out block) (copy-sset gen))
-    (setf (block-kill-sset block) kill)
+    (setf (block-kill block) kill)
     (setf (block-gen block) gen))
   (values))
 
@@ -137,7 +143,7 @@
     (setf (block-in block) in)
     (sset-union-of-difference (block-out block)
 			      in
-			      (block-kill-sset block))))
+			      (block-kill block))))
 
 (defevent copy-deleted-move "Copy propagation deleted a move.")