From 2546d61e3e230629978781602f82cee66f579d07 Mon Sep 17 00:00:00 2001
From: Alexey Dejneka <adejneka@comail.ru>
Date: Sat, 30 Oct 2004 18:29:49 +0000
Subject: [PATCH] 0.8.16.17         * Fix bug MISC.434: constraining REF type
 can terminate a           block;           ... block
 termination immediately marks the successor for            
   deletion.

---
 src/compiler/constraint.lisp |    6 ++++--
 src/compiler/ir1opt.lisp     |   19 +++++++++++--------
 tests/compiler.pure.lisp     |   41 +++++++++++++++++++++++++++++++++++++++++
 version.lisp-expr            |    2 +-
 4 files changed, 57 insertions(+), 11 deletions(-)

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 8844aeb..5e61da0 100644
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -380,7 +380,8 @@
              (derive-node-type ref
                                (make-single-value-type
                                 (or (type-difference res not-res)
-                                    res)))))))
+                                    res)))
+             (maybe-terminate-block ref nil)))))
 
   (values))
 
@@ -588,6 +589,7 @@
              (return))))))
 
   (do-blocks (block component)
-    (use-result-constraints block))
+    (unless (block-delete-p block)
+      (use-result-constraints block)))
 
   (values))
diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 95b4357..820fcf4 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -742,7 +742,7 @@
 ;;;
 ;;; Why do we need to consider LVAR type? -- APD, 2003-07-30
 (defun maybe-terminate-block (node ir1-converting-not-optimizing-p)
-  (declare (type (or basic-combination cast) node))
+  (declare (type (or basic-combination cast ref) node))
   (let* ((block (node-block node))
 	 (lvar (node-lvar node))
          (ctran (node-next node))
@@ -766,13 +766,16 @@
 	      (t
 	       (node-ends-block node)))
 
-	(unlink-blocks block (first (block-succ block)))
-	(setf (component-reanalyze (block-component block)) t)
-	(aver (not (block-succ block)))
-	(link-blocks block tail)
-        (if ir1-converting-not-optimizing-p
-            (%delete-lvar-use node)
-            (delete-lvar-use node))
+        (let ((succ (first (block-succ block))))
+          (unlink-blocks block succ)
+          (setf (component-reanalyze (block-component block)) t)
+          (aver (not (block-succ block)))
+          (link-blocks block tail)
+          (cond (ir1-converting-not-optimizing-p
+                 (%delete-lvar-use node))
+                (t (delete-lvar-use node)
+                   (when (null (block-pred succ))
+                     (mark-for-deletion succ)))))
 	t))))
 
 ;;; This is called both by IR1 conversion and IR1 optimization when
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index cd528ed..36741f4 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1495,3 +1495,44 @@
         (declare (dynamic-extent v5))
         v5))))
     17)))
+
+;;;  MISC.434
+(assert (zerop (funcall
+   (compile
+    nil
+    '(lambda (a b)
+       (declare (type (integer -8431780939320 1571817471932) a))
+       (declare (type (integer -4085 0) b))
+       (declare (ignorable a b))
+       (declare
+	(optimize (space 2)
+		  (compilation-speed 0)
+		  #+sbcl (sb-c:insert-step-conditions 0)
+		  (debug 2)
+		  (safety 0)
+		  (speed 3)))
+       (let ((*s5* 0))
+	 (dotimes (iv1 2 0)
+	   (let ((*s5*
+		  (elt '(1954479092053)
+		       (min 0
+			    (max 0
+				 (if (< iv1 iv1)
+				     (lognand iv1 (ash iv1 (min 53 iv1)))
+				   iv1))))))
+	     0)))))
+   -7639589303599 -1368)))
+
+(compile
+ nil
+ '(lambda (a b)
+   (declare (type (integer) a))
+   (declare (type (integer) b))
+   (declare (ignorable a b))
+   (declare (optimize (space 2) (compilation-speed 0)
+             (debug 0) (safety 0) (speed 3)))
+   (dotimes (iv1 2 0)
+     (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass
+     (print (if (< iv1 iv1)
+                (logand (ash iv1 iv1) 1)
+                iv1)))))
diff --git a/version.lisp-expr b/version.lisp-expr
index 346af38..d7cd333 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.16.16"
+"0.8.16.17"
-- 
1.7.10.4