From 77b96647b278fdf86736086bff865449aac98443 Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Tue, 27 Apr 2010 16:19:22 +0000 Subject: [PATCH] 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 --- NEWS | 2 ++ src/compiler/constraint.lisp | 6 +++++- tests/compiler.impure.lisp | 17 +++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 25 insertions(+), 2 deletions(-) diff --git a/NEWS b/NEWS index 13f057e..5deb27e 100644 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4