From 570bc3c47e03c922eb7cd0ddcfe4825e119ab698 Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Mon, 4 Apr 2016 16:38:02 +0300
Subject: [PATCH] Reduce consing during copy propagation.

Don't push TNs into OUT if their reads are limited to the block they
are written to.

Fixes lp#1540125
---
 src/compiler/copyprop.lisp | 23 +++++++++++++++++------
 src/compiler/node.lisp     |  1 -
 2 files changed, 17 insertions(+), 7 deletions(-)

diff --git a/src/compiler/copyprop.lisp b/src/compiler/copyprop.lisp
index 10a17684b..633bb9a80 100644
--- a/src/compiler/copyprop.lisp
+++ b/src/compiler/copyprop.lisp
@@ -97,6 +97,13 @@
                                                    '(nil :optional)))))))
                        arg-tn)))))))
 
+(defun reads-within-block-p (tn block)
+  (do ((ref (tn-reads tn) (tn-ref-across ref)))
+      ((null ref) t)
+    (let ((vop (tn-ref-vop ref)))
+      (unless (eq (ir2-block-block (vop-block vop)) block)
+        (return)))))
+
 ;;; Init the sets in BLOCK for copy propagation. To find GEN, we just
 ;;; look for MOVE vops, and then see whether the result is a eligible
 ;;; copy TN. To find KILL, we must look at all VOP results, seeing
@@ -105,13 +112,14 @@
 (defun init-copy-sets (block)
   (declare (type cblock block))
   (let ((kill (make-sset))
-        (gen (make-sset)))
+        (out (make-sset)))
     (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
         ((null vop))
       (unless (and (eq (vop-info-name (vop-info vop)) 'move)
                    (let ((y (tn-ref-tn (vop-results vop))))
                      (when (tn-is-copy-of y)
-                       (sset-adjoin y gen)
+                       (unless (reads-within-block-p y block)
+                        (sset-adjoin y out))
                        t)))
         ;; WANTED: explanation of UNLESS above.
         (do ((res (vop-results vop) (tn-ref-across res)))
@@ -123,11 +131,10 @@
                 (when (eq (vop-info-name (vop-info read-vop)) 'move)
                   (let ((y (tn-ref-tn (vop-results read-vop))))
                     (when (tn-is-copy-of y)
-                      (sset-delete y gen)
+                      (sset-delete y out)
                       (sset-adjoin y kill))))))))))
-    (setf (block-out block) (copy-sset gen))
-    (setf (block-kill block) kill)
-    (setf (block-gen block) gen))
+    (setf (block-out block) out
+          (block-kill block) kill))
   (values))
 
 ;;; Do the flow analysis step for copy propagation on BLOCK. We rely
@@ -206,6 +213,10 @@
 (defun propagate-copies (block original-copy-of)
   (declare (type cblock block) (type hash-table original-copy-of))
   (let ((in (block-in block)))
+    ;; Don't retain garbage
+    (setf (block-in block) nil
+          (block-out block) nil
+          (block-kill block) nil)
     (do ((vop (ir2-block-start-vop (block-info block)) (vop-next vop)))
         ((null vop))
       (let ((this-copy (and (eq (vop-info-name (vop-info vop)) 'move)
diff --git a/src/compiler/node.lisp b/src/compiler/node.lisp
index 442dfb652..ed43342bc 100644
--- a/src/compiler/node.lisp
+++ b/src/compiler/node.lisp
@@ -317,7 +317,6 @@
   ;; in copy propagation: list of killed TNs
   (kill nil)
   ;; other sets used in constraint propagation and/or copy propagation
-  (gen nil)
   (in nil)
   (out nil)
   ;; Set of all blocks that dominate this block. NIL is interpreted
-- 
2.11.4.GIT