From: Stas Boukarev <stassats@gmail.com>
Date: Sat, 7 Dec 2013 09:04:14 +0000 (+0400)
Subject: Fix cut-to-width in the presence of bad constants in dead code.
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=961c6bf2eda5d492d5dbb7e275fe4e0931f7adf8;p=sbcl.git

Fix cut-to-width in the presence of bad constants in dead code.

Unreachable branches may have mismatching types and constant values,
and when cut-to-width is run before such nodes are deleted, it gets
confused.

Reported by Douglas Katzman.
---

diff --git a/NEWS b/NEWS
index 303ebc0..364d1e9 100644
--- a/NEWS
+++ b/NEWS
@@ -15,6 +15,8 @@ changes relative to sbcl-1.1.14:
     having GUI applications without an automatically appearing console window.
   * bug fix: Windows applications without the console window no longer misbehave.
     (patch by Wilfredo Velazquez, lp#1256034).
+  * bug fix: modular arithmetic optimizations do not stumble on dead branches
+    with bad constants. (reported by Douglas Katzman)
 
 changes in sbcl-1.1.14 relative to sbcl-1.1.13:
   * optimization: complicated TYPEP tests are less opaque to the type
diff --git a/src/compiler/srctran.lisp b/src/compiler/srctran.lisp
index c808988..fa780c9 100644
--- a/src/compiler/srctran.lisp
+++ b/src/compiler/srctran.lisp
@@ -2955,7 +2955,7 @@
                  (setf (block-reoptimize (node-block node)) t)
                  (reoptimize-component (node-component node) :maybe))
                t)
-             (cut-node (node &aux did-something over-wide)
+             (cut-node (node)
                "Try to cut a node to width. The primary return value is
                 whether we managed to cut (cleverly), and the second whether
                 anything was changed.  The third return value tells whether
@@ -2967,9 +2967,13 @@
                   (typecase (ref-leaf node)
                     (constant
                      (let* ((constant-value (constant-value (ref-leaf node)))
-                            (new-value (if signedp
-                                           (mask-signed-field width constant-value)
-                                           (ldb (byte width 0) constant-value))))
+                            (new-value
+                              (cond ((not (integerp constant-value))
+                                     (return-from cut-node (values t nil)))
+                                    (signedp
+                                     (mask-signed-field width constant-value))
+                                    (t
+                                     (ldb (byte width 0) constant-value)))))
                        (cond ((= constant-value new-value)
                               (values t nil)) ; we knew what to do and did nothing
                              (t
@@ -3014,7 +3018,9 @@
                                                  (modular-fun-info-name modular-fun))
                                                 (function
                                                  (funcall modular-fun node width)))
-                                              :exit-if-null))
+                                              :exit-if-null)
+                                        (did-something nil)
+                                        (over-wide nil))
                                (unless (eql modular-fun :good)
                                  (setq did-something t
                                        over-wide t)
diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 2fe23b1..e63e2d6 100644
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1443,6 +1443,20 @@
   (assert (equal (compile '(setf compile-setf))
                  '(setf compile-setf))))
 
+(declaim (inline cut-test))
+(defun cut-test (b)
+  (cond ((integerp b) b)
+        (b 469)
+        (t 2)))
+
+(with-test (:name :cut-to-width-bad-constant)
+  (assert (= (funcall (compile nil
+                               `(lambda ()
+                                  (multiple-value-bind (a b) (values t t)
+                                    (declare (ignore b))
+                                    (mask-field (byte 10 0) (cut-test a))))))
+             469)))
+
 
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself