1.0.37.73: Remove the one place we assumed constant LVARs referred literals

 * Resulted in a type mismatch or subtle errors during compilation with
   singleton types.

   Reported by Chun Tian (binghe) on sbcl-devel

diff --git a/NEWS b/NEWS
index 13f057e..5deb27e 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -80,6 +80,8 @@ changes relative to sbcl-1.0.37:
     (lp#569404)
   * bug fix: RANDOM-STATE can be printed readably again.
   * bug fix: Unreadable objects were sometimes printed like #<\nFoo>.
+  * bug fix: Using EQL with non-constant values of constant type (e.g. EQL
+    types) could result in type mismatches during compilation.
 
 changes in sbcl-1.0.37 relative to sbcl-1.0.36:
   * enhancement: Backtrace from THROW to uncaught tag on x86oids now shows

diff --git a/src/compiler/constraint.lisp b/src/compiler/constraint.lisp
index 5a4c627..eb936ba 100644 (file)
--- a/src/compiler/constraint.lisp
+++ b/src/compiler/constraint.lisp
@@ -491,7 +491,11 @@
                           (var2
                            (add 'eql var1 var2 nil))
                           ((constant-lvar-p arg2)
-                           (add 'eql var1 (ref-leaf (principal-lvar-use arg2))
+                           (add 'eql var1
+                                (let ((use (principal-lvar-use arg2)))
+                                  (if (ref-p use)
+                                      (ref-leaf use)
+                                      (find-constant (lvar-value arg2))))
                                 nil))
                           (t
                            (add-test-constraint 'typep var1 (lvar-type arg2)

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 8f9b132..99ba834 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1944,4 +1944,21 @@
 (setf *mystery* :mystery)
 (assert (eq :ok (test-mystery (make-thing :slot :mystery))))
 
+;;; Singleton types can also be constant.
+(test-util:with-test (:name :propagate-singleton-types-to-eql)
+  (macrolet ((test (type value &aux (fun (gensym "FUN")))
+               `(progn
+                  (declaim (ftype (function () (values ,type &optional)) ,fun))
+                  (defun ,fun ()
+                    ',value)
+                  (lambda (x)
+                    (if (eql x (,fun))
+                        nil
+                        (eql x (,fun)))))))
+    (values
+      (test (eql foo) foo)
+      (test (integer 0 0) 0)
+      (test (double-float 0d0 0d0) 0d0)
+      (test (eql #\c) #\c))))
+
 ;;; success

diff --git a/version.lisp-expr b/version.lisp-expr
index 6c153e3..cec842e 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".)
-"1.0.37.72"
+"1.0.37.73"