0.8.16.17

        * Fix bug MISC.434: constraining REF type can terminate a
          block;
          ... block termination immediately marks the successor for
              deletion.

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 8844aeb..5e61da0 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"