From 5b4af0d79ba72a4e1f1529d134ee80aa45887973 Mon Sep 17 00:00:00 2001 From: Andrew Berkley Date: Sat, 13 Feb 2021 08:13:58 -0800 Subject: [PATCH 11/11] Improve numeric-contagion for float number pairs. Fixes https://bugs.launchpad.net/sbcl/+bug/1914094 --- src/code/late-type.lisp | 23 +++++++++++------------ src/compiler/float-tran.lisp | 24 +++++++++++++++--------- src/compiler/ir1opt.lisp | 7 ++++--- tests/float.pure.lisp | 18 ++++++++++++++++++ 4 files changed, 48 insertions(+), 24 deletions(-) diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp index ecc0f63b3..1afeac4f5 100644 --- a/src/code/late-type.lisp +++ b/src/code/late-type.lisp @@ -2564,10 +2564,10 @@ used for a COMPLEX component.~:@>" (return f))))) ;;; Return the result of an operation on TYPE1 and TYPE2 according to -;;; the rules of numeric contagion. This is always NUMBER, some float -;;; format (possibly complex) or RATIONAL. Due to rational -;;; canonicalization, there isn't much we can do here with integers or -;;; rational complex numbers. +;;; the rules of numeric contagion. This is NUMBER, some float +;;; format (possibly complex) or RATIONAL or a UNION-TYPE of +;;; these. Due to rational canonicalization, there isn't much we can +;;; do here with integers or rational complex numbers. ;;; ;;; If either argument is not a NUMERIC-TYPE, then return NUMBER. This ;;; is useful mainly for allowing types that are technically numbers, @@ -2580,10 +2580,7 @@ used for a COMPLEX component.~:@>" (format2 (numeric-type-format type2)) (complexp1 (numeric-type-complexp type1)) (complexp2 (numeric-type-complexp type2))) - (cond ((or (null complexp1) - (null complexp2)) - (specifier-type 'number)) - ((eq class1 'float) + (cond ((eq class1 'float) (make-numeric-type :class 'float :format (ecase class2 @@ -2602,10 +2599,12 @@ used for a COMPLEX component.~:@>" (if (eq format1 'long-float) 'long-float nil))) - :complexp (if (or (eq complexp1 :complex) - (eq complexp2 :complex)) - :complex - :real))) + :complexp (cond ((and (eq complexp1 :real) + (eq complexp2 :real)) + :real) + ((or (null complexp1) (null complexp2)) + nil) + (t :complex)))) ((eq class2 'float) (numeric-contagion type2 type1)) ((and (eq complexp1 :real) (eq complexp2 :real)) (make-numeric-type diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 64cbff452..e612af2d6 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -619,15 +619,21 @@ ;;; should be the right kind of float. Allow bounds for the float ;;; part too. (defun float-or-complex-float-type (arg &optional lo hi) - (declare (type numeric-type arg)) - (let* ((format (case (numeric-type-class arg) - ((integer rational) 'single-float) - (t (numeric-type-format arg)))) - (float-type (or format 'float)) - (lo (coerce-numeric-bound lo float-type)) - (hi (coerce-numeric-bound hi float-type))) - (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*)) - (complex ,float-type))))) + (cond + ((numeric-type-p arg) + (let* ((format (case (numeric-type-class arg) + ((integer rational) 'single-float) + (t (numeric-type-format arg)))) + (float-type (or format 'float)) + (lo (coerce-numeric-bound lo float-type)) + (hi (coerce-numeric-bound hi float-type))) + (specifier-type `(or (,float-type ,(or lo '*) ,(or hi '*)) + (complex ,float-type))))) + ((union-type-p arg) + (apply #'type-union + (loop for type in (union-type-types arg) + collect (float-or-complex-float-type type)))) + (t (specifier-type 'number)))) (eval-when (:compile-toplevel :execute) ;; So the problem with this hack is that it's actually broken. If diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp index 338900bee..49eee1a66 100644 --- a/src/compiler/ir1opt.lisp +++ b/src/compiler/ir1opt.lisp @@ -1885,9 +1885,10 @@ ;; Detect cases like (LOOP FOR 1.0 to 5.0 ...), where ;; the initial and the step are of different types, ;; and the step is less contagious. - (numeric-type-equal initial-type - (numeric-contagion initial-type - step-type)))) + (let ((contagion-type (numeric-contagion initial-type + step-type))) + (and (numeric-type-p contagion-type) + (numeric-type-equal initial-type contagion-type))))) (labels ((leftmost (x y cmp cmp=) (cond ((eq x nil) nil) ((eq y nil) nil) diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index 0eaf0980c..6940e97f8 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -596,3 +596,21 @@ (with-test (:name :ctype-of-nan) (checked-compile '(lambda () #.(sb-kernel:make-single-float -1)))) + +;; bug #1914094 +(with-test (:name :float-type-derivation :skipped-on (not :64-bit)) + (labels ((car-type-equal (x y) + (and (subtypep (car x) (car y)) + (subtypep (car y) (car x))))) + (let ((long #+long-float 'long-float + #-long-float 'double-float)) + (checked-compile-and-assert () '(lambda (x) (ctu:compiler-derived-type (* 3d0 x))) + ((1) (values `(or ,long (complex ,long)) t) :test #'car-type-equal)) + (checked-compile-and-assert () '(lambda (x) (ctu:compiler-derived-type (* 3f0 x))) + ((1) (values `(or single-float ,long (complex single-float) (complex ,long)) t) + :test #'car-type-equal)) + (checked-compile-and-assert () '(lambda (x) (ctu:compiler-derived-type (* 3f0 x))) + ((1) (values `(or single-float ,long (complex single-float) (complex ,long)) t) + :test #'car-type-equal)) + (checked-compile-and-assert () '(lambda (x y) (ctu:compiler-derived-type (atan x y))) + ((1 2) (values `(or ,long single-float (complex ,long) (complex single-float)) t) :test #'car-type-equal))))) -- 2.17.1