From b6c9df36d8e047d8b0e620f034a60d470447edbe Mon Sep 17 00:00:00 2001
From: Jan Moringen <jmoringe@techfak.uni-bielefeld.de>
Date: Mon, 18 Sep 2017 20:27:38 +0200
Subject: [PATCH] CONSTANT-LVAR-P ignores problematic constant values behind
 casts

fixes lp#1717971
---
 src/compiler/ir1opt.lisp | 19 ++++++++++++++-----
 tests/compiler.pure.lisp | 12 ++++++++++++
 2 files changed, 26 insertions(+), 5 deletions(-)

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index 4bfb78c03..622a92422 100644
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -23,10 +23,20 @@
 (defun constant-lvar-p (thing)
   (declare (type (or lvar null) thing))
   (and (lvar-p thing)
-       (or (let ((use (principal-lvar-use thing)))
-             (and (ref-p use) (constant-p (ref-leaf use))))
-           ;; check for EQL types and singleton numeric types
-           (values (type-singleton-p (lvar-type thing))))))
+       (let* ((type (lvar-type thing))
+              (principal-lvar (principal-lvar thing))
+              (principal-use (lvar-uses principal-lvar))
+              leaf)
+         (or (and (ref-p principal-use)
+                  (constant-p (setf leaf (ref-leaf principal-use)))
+                  ;; LEAF may be a CONSTANT behind a cast that will
+                  ;; later turn out to be of the wrong type.
+                  ;; And ir1-transforms suffer from this because
+                  ;; they expect LVAR-VALUE to be of a restricted type.
+                  (or (not (lvar-reoptimize principal-lvar))
+                      (ctypep (constant-value leaf) type)))
+             ;; check for EQL types and singleton numeric types
+             (values (type-singleton-p type))))))
 
 ;;; Return the constant value for an LVAR whose only use is a constant
 ;;; node.
@@ -2392,4 +2402,3 @@
 
   (unless do-not-optimize
     (setf (node-reoptimize cast) nil)))
-
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index d1a23d271..fb1a8612b 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -6584,3 +6584,15 @@
                                 (the (member #\UBC19E) x)))
             #\UBC19E)
            #\UBC19E)))
+
+(with-test (:name (compile * :constant-behind-cast :lp-1717971]))
+  (let ((fun (checked-compile
+              `(lambda (x)
+                 (declare (type integer x))
+                 (declare (optimize (debug 1) (safety 0) (space 3) (compilation-speed 0)))
+                 (catch 'ct5
+                   (* (flet ((%f (&key (x (throw 'ct5 123)))
+                               (the integer x)))
+                        (%f))
+                      x))))))
+    (assert (eql (funcall fun 45) 123))))
-- 
2.11.4.GIT