From 9e70e82b2bb7b583a9c681d687c6ec607ed3009b Mon Sep 17 00:00:00 2001
From: Stas Boukarev <stassats@gmail.com>
Date: Tue, 9 Jan 2018 20:03:47 +0300
Subject: [PATCH] Fix ltn annotation of tail calls.

Don't try to fixup ir2 blocks when splitting ir1 blocks when there's
nothing actually split.

Fixes lp#1742151
---
 src/compiler/ir1util.lisp  | 11 ++++++-----
 src/compiler/ltn.lisp      | 34 ++++++++++++++++++----------------
 tests/compiler-2.pure.lisp | 12 ++++++++++++
 3 files changed, 36 insertions(+), 21 deletions(-)

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 1a20033f9..8f9ea1d55 100644
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -1210,6 +1210,7 @@
 
 ;;; Make NODE the LAST node in its block, splitting the block if necessary.
 ;;; The new block is added to the DFO immediately following NODE's block.
+;;; Returns the new block if it's created.
 (defun node-ends-block (node)
   (declare (type node node))
   (let* ((block (node-block node))
@@ -1221,9 +1222,9 @@
                  (not (block-delete-p block))))
       (let* ((succ (block-succ block))
              (new-block
-              (make-block-key :start start
-                              :component (block-component block)
-                              :succ succ :last last)))
+               (make-block-key :start start
+                               :component (block-component block)
+                               :succ succ :last last)))
         (setf (ctran-kind start) :block-start)
         (setf (ctran-use start) nil)
         (setf (block-last block) node)
@@ -1238,8 +1239,8 @@
 
         (do ((ctran start (node-next (ctran-next ctran))))
             ((not ctran))
-          (setf (ctran-block ctran) new-block)))))
-  (values))
+          (setf (ctran-block ctran) new-block))
+        new-block))))
 
 ;;;; deleting stuff
 
diff --git a/src/compiler/ltn.lisp b/src/compiler/ltn.lisp
index cd6cdea40..a95b48c5f 100644
--- a/src/compiler/ltn.lisp
+++ b/src/compiler/ltn.lisp
@@ -83,6 +83,17 @@
         (setf (ir2-block-popped old-ir2-block) (old-popped))
         (setf (ir2-block-popped new-ir2-block) (new-popped))))))
 
+(defun ir2-change-node-successor (node next-block)
+  (let* ((node-block (node-block node))
+         (old-next-block
+           (if (eq node (block-last node-block))
+               (first (block-succ node-block))
+               (let ((old-next-block (node-ends-block node)))
+                 (fixup-ir2-blocks-for-split-block node-block old-next-block)
+                 old-next-block))))
+    (unlink-blocks node-block old-next-block)
+    (link-blocks node-block next-block)))
+
 ;;; an annotated lvar's primitive-type
 #!-sb-fluid (declaim (inline lvar-ptype))
 (defun lvar-ptype (lvar)
@@ -159,16 +170,12 @@
   (declare (type basic-combination call))
   (let ((tails (and (node-tail-p call)
                     (lambda-tail-set (node-home-lambda call)))))
-    (when tails
-      (cond ((eq (return-info-kind (tail-set-info tails)) :unknown)
-             (node-ends-block call)
-             (let* ((block (node-block call))
-                    (new-block (first (block-succ block))))
-               (fixup-ir2-blocks-for-split-block block new-block)
-               (unlink-blocks block new-block)
-               (link-blocks block (component-tail (block-component block)))))
-            (t
-             (setf (node-tail-p call) nil)))))
+    (cond ((not tails))
+          ((eq (return-info-kind (tail-set-info tails)) :unknown)
+           (ir2-change-node-successor call
+                                      (component-tail (block-component (node-block call)))))
+          (t
+           (setf (node-tail-p call) nil))))
   (values))
 
 ;;; We set the kind to :FULL or :FUNNY, depending on whether there is
@@ -392,12 +399,7 @@
         (callee (combination-lambda call)))
     (aver (eq (lambda-tail-set caller)
               (lambda-tail-set (lambda-home callee))))
-    (node-ends-block call)
-    (let* ((block (node-block call))
-           (new-block (first (block-succ block))))
-      (fixup-ir2-blocks-for-split-block block new-block)
-      (unlink-blocks block new-block)
-      (link-blocks block (lambda-block callee))))
+    (ir2-change-node-successor call (lambda-block callee)))
   (values))
 
 ;;; Annotate the value lvar.
diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp
index 8307c946c..f962ed423 100644
--- a/tests/compiler-2.pure.lisp
+++ b/tests/compiler-2.pure.lisp
@@ -978,3 +978,15 @@
       `(lambda (x)
          (find 1 x :key #'values))
     (('(1)) 1)))
+
+(with-test (:name :tail-call-ltn-annotation)
+  (checked-compile-and-assert
+      ()
+      `(lambda (x)
+         (labels ((ff1 ()
+                    (multiple-value-call #'print
+                      (if x
+                          (values t t)
+                          nil))
+                    (ff1)))
+           (identity (ff1))))))
-- 
2.11.4.GIT