tests/float.pure.lisp

   1 ;;;; floating-point-related tests with no side effects
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (with-test (:name (:infinities :comparison))
  15   (dolist (ifnis (list (cons single-float-positive-infinity
  16                              single-float-negative-infinity)
  17                        (cons double-float-positive-infinity
  18                              double-float-negative-infinity)))
  19     (destructuring-bind (+ifni . -ifni) ifnis
  20       (assert (= (* +ifni 1) +ifni))
  21       (assert (= (* +ifni -0.1) -ifni))
  22       (assert (= (+ +ifni -0.1) +ifni))
  23       (assert (= (- +ifni -0.1) +ifni))
  24       (assert (= (sqrt +ifni) +ifni))
  25       (assert (= (* -ifni -14) +ifni))
  26       (assert (= (/ -ifni 0.1) -ifni))
  27       (assert (= (/ -ifni 100/3) -ifni))
  28       (assert (not (= +ifni -ifni)))
  29       (assert (= -ifni -ifni))
  30       (assert (not (= +ifni 100/3)))
  31       (assert (not (= -ifni -1.0 -ifni)))
  32       (assert (not (= -ifni -17/02 -ifni)))
  33       (assert (< -ifni +ifni))
  34       (assert (not (< +ifni 100)))
  35       (assert (not (< +ifni 100.0)))
  36       (assert (not (< +ifni -ifni)))
  37       (assert (< 100 +ifni))
  38       (assert (< 100.0 +ifni))
  39       (assert (>= 100 -ifni))
  40       (assert (not (<= 6/7 (* 3 -ifni))))
  41       (assert (not (> +ifni +ifni))))))
  42
  43 ;;; ANSI: FLOAT-RADIX should signal an error if its argument is not a
  44 ;;; float.
  45 ;;;
  46 ;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden
  47 ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
  48 (with-test (:name (float-radix simple-type-error))
  49   (multiple-value-bind  (fun failure-p warnings)
  50       (checked-compile '(lambda () (float-radix "notfloat")) :allow-warnings t)
  51     (assert failure-p)
  52     (assert (= 1 (length warnings)))
  53     (assert-error (funcall fun) type-error))
  54   (assert-error (funcall (fdefinition 'float-radix) "notfloat") type-error))
  55
  56 ;;; Before 0.8.2.14 the cross compiler failed to work with
  57 ;;; denormalized numbers
  58 (with-test (:name (:denormalized float))
  59   (when (subtypep 'single-float 'short-float)
  60     (assert (eql least-positive-single-float least-positive-short-float))))
  61
  62 ;;; bug found by Paul Dietz: FFLOOR and similar did not work for integers
  63 (with-test (:name (ffloor integer))
  64   (let ((tests '(((ffloor -8 3) (-3.0 1))
  65                  ((fround -8 3) (-3.0 1))
  66                  ((ftruncate -8 3) (-2.0 -2))
  67                  ((fceiling -8 3) (-2.0 -2)))))
  68     (loop for (exp res) in tests
  69        for real-res = (multiple-value-list (eval exp))
  70        do (assert (equal real-res res)))))
  71
  72 ;;; bug 45b reported by PVE
  73 (with-test (:name (:least-*-*-float :bug-45b))
  74   (dolist (type '(short single double long))
  75     (dolist (sign '(positive negative))
  76       (let* ((name (find-symbol (format nil "LEAST-~A-~A-FLOAT"
  77                                         sign type)
  78                                 :cl))
  79              (value (symbol-value name)))
  80         (assert (zerop (/ value 2)))))))
  81
  82 ;;; bug found by Paul Dietz: bad rounding on small floats
  83 (with-test (:name (fround least-positive-short-float))
  84   (assert (= (fround least-positive-short-float least-positive-short-float) 1.0)))
  85
  86 ;;; bug found by Peter Seibel: scale-float was only accepting float
  87 ;;; exponents, when it should accept all integers.  (also bug #269)
  88 (with-test (:name (scale-float :bug-269))
  89   (assert (= (multiple-value-bind (significand expt sign)
  90                  (integer-decode-float least-positive-double-float)
  91                (* (scale-float (float significand 0.0d0) expt) sign))
  92              least-positive-double-float))
  93   (assert (= (multiple-value-bind (significand expt sign)
  94                  (decode-float least-positive-double-float)
  95                (* (scale-float significand expt) sign))
  96              least-positive-double-float))
  97   (assert (= 0.0 (scale-float 1.0 most-negative-fixnum)))
  98   (assert (= 0.0d0 (scale-float 1.0d0 (1- most-negative-fixnum)))))
  99
 100 (with-test (:name (:scale-float-overflow :bug-372)
 101             :fails-on :no-float-traps)
 102   (flet ((test (form)
 103            (assert-error (funcall (checked-compile `(lambda () ,form)
 104                                                    :allow-style-warnings t))
 105                          floating-point-overflow)))
 106     (test '(scale-float 1.0 most-positive-fixnum))
 107     (test '(scale-float 1.0d0 (1+ most-positive-fixnum)))))
 108
 109 ;;; bug found by jsnell when nfroyd tried to implement better LOGAND
 110 ;;; type derivation.
 111 (assert (= (integer-decode-float (coerce -1756510900000000000
 112                                          'single-float))
 113            12780299))
 114
 115 ;;; MISC.564: no out-of-line %ATAN2 for constant folding
 116 (with-test (:name (:%atan2 :constant-folding))
 117   (assert (typep
 118            (funcall
 119             (checked-compile
 120              '(lambda (p1)
 121                (declare (optimize (speed 3) (safety 2) (debug 3) (space 0))
 122                         (type complex p1))
 123                (phase (the (eql #c(1.0d0 2.0d0)) p1))))
 124             #c(1.0d0 2.0d0))
 125            'double-float)))
 126
 127 ;;; More out of line functions (%COS, %SIN, %TAN) for constant folding,
 128 ;;; reported by Mika Pihlajamäki
 129 (with-test (:name (sin cos tan :constant-folding))
 130   (flet ((test (function)
 131            (funcall (checked-compile
 132                      `(lambda () (,function (tan (round 0))))))))
 133     (mapc #'test '(sin cos tan))))
 134
 135 (with-test (:name (:addition-overflow :bug-372)
 136             :fails-on (or (and :arm64 (not :darwin))
 137                           :arm
 138                           (and :ppc :openbsd)
 139                           (and :ppc :darwin)
 140                           (and :x86 :netbsd)))
 141   (assert-error
 142    (sb-sys:without-interrupts
 143      (sb-int:set-floating-point-modes :current-exceptions nil
 144                                       :accrued-exceptions nil)
 145      (loop repeat 2 summing most-positive-double-float)
 146      (sleep 2))
 147    floating-point-overflow))
 148
 149 ;; This is the same test as above.  Even if the above copy passes,
 150 ;; this copy will fail if SIGFPE handling ends up clearing the FPU
 151 ;; control word, which can happen if the kernel clears the FPU control
 152 ;; (a reasonable thing for it to do) and the runtime fails to
 153 ;; compensate for this (see RESTORE_FP_CONTROL_WORD in interrupt.c).
 154 ;; Note that this only works when running float.pure.lisp alone, as
 155 ;; the preceeding "pure" test files aren't as free of side effects as
 156 ;; we might like.
 157 (with-test (:name (:addition-overflow :bug-372 :take-2)
 158             :fails-on (or (and :arm64 (not :darwin))
 159                           :arm
 160                           (and :ppc :openbsd)
 161                           (and :ppc :darwin)
 162                           (and :x86 :netbsd)))
 163   (assert-error
 164    (sb-sys:without-interrupts
 165      (sb-int:set-floating-point-modes :current-exceptions nil
 166                                       :accrued-exceptions nil)
 167      (loop repeat 2 summing most-positive-double-float)
 168      (sleep 2))
 169    floating-point-overflow))
 170
 171 ;;; On x86-64 generating complex floats on the stack failed an aver in
 172 ;;; the compiler if the stack slot was the same as the one containing
 173 ;;; the real part of the complex. The following expression was able to
 174 ;;; trigger this in 0.9.5.62.
 175 (with-test (:name :complex-float-stack)
 176   (dolist (type '((complex double-float)
 177                   (complex single-float)))
 178     (checked-compile `(lambda (x0 x1 x2 x3 x4 x5 x6 x7)
 179                         (declare (type ,type x0 x1 x2 x3 x4 x5 x6 x7))
 180                         (let ((x0 (+ x0 x0))
 181                               (x1 (+ x1 x1))
 182                               (x2 (+ x2 x2))
 183                               (x3 (+ x3 x3))
 184                               (x4 (+ x4 x4))
 185                               (x5 (+ x5 x5))
 186                               (x6 (+ x6 x6))
 187                               (x7 (+ x7 x7)))
 188                           (* (+ x0 x1 x2 x3) (+ x4 x5 x6 x7)
 189                              (+ x0 x2 x4 x6) (+ x1 x3 x5 x7)
 190                              (+ x0 x3 x4 x7) (+ x1 x2 x5 x6)
 191                              (+ x0 x1 x6 x7) (+ x2 x3 x4 x5)))))))
 192
 193 (with-test (:name (:nan :comparison)
 194             :fails-on (or :sparc))
 195   (sb-int:with-float-traps-masked (:invalid)
 196     (macrolet ((test (form)
 197                  (let ((nform (subst '(/ 0.0 0.0) 'nan form)))
 198                    `(progn
 199                       (assert (eval ',nform))
 200                       (assert (eval `(let ((nan (/ 0.0 0.0)))
 201                                        ,',form)))
 202                       (assert (funcall
 203                                (checked-compile `(lambda () ,',nform))))
 204                       (assert (funcall
 205                                (checked-compile `(lambda (nan) ,',form))
 206                                (locally
 207                                    (declare (muffle-conditions style-warning))
 208                                  (/ 0.0 0.0))))))))
 209       (test (/= nan nan))
 210       (test (/= nan nan nan))
 211       (test (/= 1.0 nan 2.0 nan))
 212       (test (/= nan 1.0 2.0 nan))
 213       (test (not (= nan 1.0)))
 214       (test (not (= nan nan)))
 215       (test (not (= nan nan nan)))
 216       (test (not (= 1.0 nan)))
 217       (test (not (= nan 1.0)))
 218       (test (not (= 1.0 1.0 nan)))
 219       (test (not (= 1.0 nan 1.0)))
 220       (test (not (= nan 1.0 1.0)))
 221       (test (not (>= nan nan)))
 222       (test (not (>= nan 1.0)))
 223       (test (not (>= 1.0 nan)))
 224       (test (not (>= 1.0 nan 0.0)))
 225       (test (not (>= 1.0 0.0 nan)))
 226       (test (not (>= nan 1.0 0.0)))
 227       (test (not (<= nan nan)))
 228       (test (not (<= nan 1.0)))
 229       (test (not (<= 1.0 nan)))
 230       (test (not (<= 1.0 nan 2.0)))
 231       (test (not (<= 1.0 2.0 nan)))
 232       (test (not (<= nan 1.0 2.0)))
 233       (test (not (< nan nan)))
 234       (test (not (< -1.0 nan)))
 235       (test (not (< nan 1.0)))
 236       (test (not (> nan nan)))
 237       (test (not (> -1.0 nan)))
 238       (test (not (> nan 1.0))))))
 239
 240 (with-test (:name (:nan :comparison :non-float)
 241             :fails-on (or :sparc))
 242   (sb-int:with-float-traps-masked (:invalid)
 243     (let ((nan (/ 0.0 0.0))
 244           (reals (list 0 1 -1 1/2 -1/2 (expt 2 300) (- (expt 2 300))))
 245           (funs '(> < <= >= =)))
 246       (loop for fun in funs
 247             do
 248             (loop for real in reals
 249                   do (assert (not (funcall fun nan real)))
 250                      (assert (not (funcall fun real nan))))))))
 251
 252 (with-test (:name :log-int/double-accuracy)
 253   ;; we used to use single precision for intermediate results
 254   (assert (eql 2567.6046442221327d0
 255                (log (loop for n from 1 to 1000 for f = 1 then (* f n)
 256                           finally (return f))
 257                     10d0)))
 258   ;; both ways
 259   (assert (eql (log 123123123.0d0 10) (log 123123123 10.0d0))))
 260
 261 (with-test (:name :log-base-zero-return-type)
 262   (assert (eql 0.0f0 (log 123 (eval 0))))
 263   (assert (eql 0.0d0 (log 123.0d0 (eval 0))))
 264   (assert (eql 0.0d0 (log 123 (eval 0.0d0))))
 265   (let ((f (checked-compile '(lambda (x y)
 266                               (declare (optimize speed))
 267                               (etypecase x
 268                                 (single-float
 269                                  (etypecase y
 270                                    (single-float (log x y))
 271                                    (double-float (log x y))))
 272                                 (double-float
 273                                  (etypecase y
 274                                    (single-float (log x y))
 275                                    (double-float (log x y)))))))))
 276     (assert (eql 0.0f0 (funcall f 123.0 0.0)))
 277     (assert (eql 0.0d0 (funcall f 123.0d0 0.0)))
 278     (assert (eql 0.0d0 (funcall f 123.0d0 0.0d0)))
 279     (assert (eql 0.0d0 (funcall f 123.0 0.0d0)))))
 280
 281 (with-test (:name (:log2 :non-negative-powers-of-two))
 282   (let ((diffs
 283           (loop for i from 0 to 128
 284                 for x = (log (expt 2 i) 2.0d0)
 285                 if (or (not (typep x 'double-float)) (/= x i)) collect (cons i x))))
 286     (assert (null diffs))))
 287
 288 (with-test (:name (:log2 :negative-powers-of-two))
 289   (let ((diffs
 290           (loop for i from -128 to -1
 291                 for x = (log (expt 2 i) 2.0d0)
 292                 if (or (not (typep x 'double-float)) (/= x i)) collect (cons i x))))
 293     (assert (null diffs))))
 294
 295 (with-test (:name (:log2 :powers-of-two-negative))
 296   (let ((diffs
 297           (loop for i from -128 to 128
 298                 for x = (log (- (expt 2 i)) 2.0d0)
 299                 if (or (not (typep x '(complex double-float)))
 300                        (/= (realpart x) i))
 301                 collect (cons i x))))
 302     (assert (null diffs))))
 303
 304 (with-test (:name (:log :ratios-near-1))
 305   ;; LOG of 1 +/- 1/2^100 is approximately +/-1/2^100, comfortably
 306   ;; within single-float range.
 307   (let ((nvals
 308           (loop for i from -128 to 128
 309                 for x = (log (/ (+ i (expt 2 100)) (+ i (expt 2 100) 1)))
 310                 collect x))
 311         (pvals
 312           (loop for i from -128 to 128
 313                 for x = (log (/ (+ i (expt 2 100) 1) (+ i (expt 2 100))))
 314                 collect x)))
 315     (assert (= (length (remove-duplicates nvals)) 1))
 316     (assert (< (first nvals) 0))
 317     (assert (= (length (remove-duplicates pvals)) 1))
 318     (assert (> (first pvals) 0))))
 319
 320 (with-test (:name (:log :same-base-different-precision))
 321   (let ((twos (list 2 2.0f0 2.0d0 #c(2.0f0 0.0f0) #c(2.0d0 0.0d0))))
 322     (let ((result (loop for number in twos
 323                         append (loop for base in twos
 324                                      for result = (log number base)
 325                                      if (/= (realpart result) 1)
 326                                      collect (list number base result)))))
 327       (assert (null result)))))
 328
 329 ;; Bug reported by Eric Marsden on July 15 2009. The compiler
 330 ;; used not to constant fold calls with arguments of type
 331 ;; (EQL foo).
 332 (with-test (:name :eql-type-constant-fold)
 333   (assert (equal '(FUNCTION (T) (VALUES (MEMBER T) &OPTIONAL))
 334                  (sb-kernel:%simple-fun-type
 335                   (compile nil `(lambda (x)
 336                                   (eql #c(1.0 2.0)
 337                                        (the (eql #c(1.0 2.0))
 338                                          x))))))))
 339
 340 ;; Leakage from the host could result in wrong values for truncation.
 341 (with-test (:name :truncate)
 342   (assert (plusp (sb-kernel:%unary-truncate (expt 2f0 33))))
 343   (assert (plusp (sb-kernel:%unary-truncate (expt 2d0 33))))
 344   ;; That'd be one strange host, but just in case
 345   (assert (plusp (sb-kernel:%unary-truncate (expt 2f0 65))))
 346   (assert (plusp (sb-kernel:%unary-truncate (expt 2d0 65)))))
 347
 348 ;; On x86-64, we sometimes forgot to clear the higher order bits of the
 349 ;; destination register before using it with an instruction that doesn't
 350 ;; clear the (unused) high order bits. Suspect instructions are operations
 351 ;; with only one operand: for everything else, the destination has already
 352 ;; been loaded with a value, making it safe (by induction).
 353 ;;
 354 ;; The tests are extremely brittle and could be broken by any number of
 355 ;; back- or front-end optimisations. We should just keep the issue above
 356 ;; in mind at all times when working with SSE or similar instruction sets.
 357 ;;
 358 ;; Run only on x86/x86-64m as no other platforms have SB-VM::TOUCH-OBJECT.
 359 #-interpreter
 360 (macrolet ((with-pinned-floats ((count type &rest names) &body body)
 361              "Force COUNT float values to be kept live (and hopefully in registers),
 362               fill a temporary register with noise, and execute BODY."
 363              ;; KLUDGE: SB-VM is locked, and non-x86oids don't have
 364              ;; SB-VM::TOUCH-OBJECT.  Don't even READ this body on
 365              ;; other platforms.
 366              #-(or x86 x86-64)
 367              (declare (ignore count type names body))
 368              #+(or x86 x86-64)
 369              (let ((dummy (loop repeat count
 370                                 collect (or (pop names)
 371                                             (gensym "TEMP")))))
 372                `(let ,(loop for i downfrom -1
 373                             for var in dummy
 374                             for j = (coerce i type)
 375                             collect
 376                             `(,var ,(complex j j))) ; we don't actually need that, but
 377                   (declare (type (complex ,type) ,@dummy)) ; future-proofing can't hurt
 378                   ,@(loop for var in dummy
 379                           for i upfrom 0
 380                           collect `(setf ,var ,(complex i (coerce i type))))
 381                   (multiple-value-prog1
 382                       (progn
 383                         (let ((x ,(complex 1d0 1d0)))
 384                           (declare (type (complex double-float) x))
 385                           (setf x ,(complex most-positive-fixnum (float most-positive-fixnum 1d0)))
 386                           (sb-vm::touch-object x))
 387                         (locally ,@body))
 388                     ,@(loop for var in dummy
 389                             collect `(sb-vm::touch-object ,var)))))))
 390   (with-test (:name :clear-sqrtsd :skipped-on (not (or :x86 :x86-64)))
 391     (flet ((test-sqrtsd (float)
 392              (declare (optimize speed (safety 1))
 393                       (type (double-float (0d0)) float))
 394              (with-pinned-floats (14 double-float x0)
 395                (let ((x (sqrt float)))
 396                  (values (+ x x0) float)))))
 397       (declare (notinline test-sqrtsd))
 398       (assert (zerop (imagpart (test-sqrtsd 4d0))))))
 399
 400   (with-test (:name :clear-sqrtsd-single :skipped-on (not (or :x86 :x86-64)))
 401     (flet ((test-sqrtsd-float (float)
 402              (declare (optimize speed (safety 1))
 403                       (type (single-float (0f0)) float))
 404              (with-pinned-floats (14 single-float x0)
 405                (let ((x (sqrt float)))
 406                  (values (+ x x0) float)))))
 407       (declare (notinline test-sqrtsd-float))
 408       (assert (zerop (imagpart (test-sqrtsd-float 4f0))))))
 409
 410   (with-test (:name :clear-cvtss2sd :skipped-on (not (or :x86 :x86-64)))
 411     (flet ((test-cvtss2sd (float)
 412              (declare (optimize speed (safety 1))
 413                       (type single-float float))
 414              (with-pinned-floats (14 double-float x0)
 415                (let ((x (float float 0d0)))
 416                  (values (+ x x0) (+ 1e0 float))))))
 417       (declare (notinline test-cvtss2sd))
 418       (assert (zerop (imagpart (test-cvtss2sd 1f0))))))
 419
 420   (with-test (:name :clear-cvtsd2ss :skipped-on (not (or :x86 :x86-64)))
 421     (flet ((test-cvtsd2ss (float)
 422              (declare (optimize speed (safety 1))
 423                       (type double-float float))
 424              (with-pinned-floats (14 single-float x0)
 425                (let ((x (float float 1e0)))
 426                  (values (+ x x0) (+ 1d0 float))))))
 427       (declare (notinline test-cvtsd2ss))
 428       (assert (zerop (imagpart (test-cvtsd2ss 4d0))))))
 429
 430   (with-test (:name :clear-cvtsi2sd :skipped-on (not (or :x86 :x86-64)))
 431     (flet ((test-cvtsi2sd (int)
 432              (declare (optimize speed (safety 0))
 433                       (type (unsigned-byte 10) int))
 434              (with-pinned-floats (15 double-float x0)
 435                (+ (float int 0d0) x0))))
 436       (declare (notinline test-cvtsi2sd))
 437       (assert (zerop (imagpart (test-cvtsi2sd 4))))))
 438
 439   (with-test (:name :clear-cvtsi2ss :skipped-on (not (or :x86 :x86-64)))
 440     (flet ((test-cvtsi2ss (int)
 441              (declare (optimize speed (safety 0))
 442                       (type (unsigned-byte 10) int))
 443              (with-pinned-floats (15 single-float x0)
 444                (+ (float int 0e0) x0))))
 445       (declare (notinline test-cvtsi2ss))
 446       (assert (zerop (imagpart (test-cvtsi2ss 4)))))))
 447
 448 (with-test (:name :round-to-bignum)
 449   (assert (= (round 1073741822.3d0) 1073741822))
 450   (assert (= (round 1073741822.5d0) 1073741822))
 451   (assert (= (round 1073741822.7d0) 1073741823))
 452   (assert (= (round 1073741823.3d0) 1073741823))
 453   (assert (= (round 1073741823.5d0) 1073741824))
 454   (assert (= (round 1073741823.7d0) 1073741824)))
 455
 456 (with-test (:name :round-single-to-bignum)
 457   (assert (= (round 1e14) 100000000376832))
 458   (assert (= (round 1e19) 9999999980506447872)))
 459
 460 (with-test (:name :scaled-%hypot)
 461   (assert (<= (abs (complex most-positive-double-float 1d0))
 462               (1+ most-positive-double-float))))
 463
 464 ;; On x86-64, MAKE-SINGLE-FLOAT with a negative argument used to set
 465 ;; bits 32-63 of the XMM register to 1, breaking the invariant that
 466 ;; unused parts of XMM registers are always zero. This could become
 467 ;; visible as a QNaN in the imaginary part when next using the register
 468 ;; in a (COMPLEX SINGLE-FLOAT) operation.
 469 (with-test (:name :make-single-float-clear-imagpart)
 470   (let ((f (checked-compile
 471             '(lambda (x)
 472               (declare (optimize speed))
 473               (= #c(1.0f0 2.0f0)
 474                (+ #c(3.0f0 2.0f0)
 475                 (sb-kernel:make-single-float x))))))
 476         (bits (sb-kernel:single-float-bits -2.0f0)))
 477     (assert (< bits 0))         ; Make sure the test is fit for purpose.
 478     (assert (funcall f bits))))
 479
 480 (with-test (:name :negative-zero-derivation)
 481   (assert (not
 482            (funcall (checked-compile
 483                      '(lambda (exponent)
 484                        (declare ((integer 0 1) exponent))
 485                        (eql 0d0 (scale-float -0.0d0 exponent))))
 486                     0))))
 487
 488 (with-test (:name :complex-eql-all-constants)
 489   (assert (funcall (checked-compile
 490                     '(lambda ()
 491                       (declare (optimize (debug 2)))
 492                       (typep #c(1.0 1.0) '(member #c(1.0 1.0))))))))
 493
 494 (with-test (:name (truncate float :no-consing)
 495                   :skipped-on :interpreter)
 496   (let ((f (checked-compile
 497             '(lambda (x)
 498               (values (truncate (the double-float x)))))))
 499     (ctu:assert-no-consing (funcall f 1d0))
 500     (ctu:assert-no-consing (funcall f (float most-negative-fixnum 1d0))))
 501   (let ((f (checked-compile
 502             '(lambda (x)
 503               (values (truncate (the single-float x)))))))
 504     (ctu:assert-no-consing (funcall f 1f0))
 505     (ctu:assert-no-consing (funcall f (float most-negative-fixnum 1f0)))))
 506
 507 (with-test (:name :trig-derive-type-complex-rational)
 508   (macrolet ((test (fun type)
 509                `(checked-compile-and-assert
 510                  ()
 511                  '(lambda (a)
 512                    (declare ((complex ,type) a))
 513                    (,fun a))
 514                  ((#C(1 2)) (eval '(,fun #C(1 2)))))))
 515     (test sin integer)
 516     (test cos integer)
 517     (test tan integer)
 518     (test sin rational)
 519     (test cos rational)
 520     (test tan rational)))
 521
 522 (defun exercise-float-decoder (type exponent-bits mantissa-bits &optional print)
 523   (let* ((exp-max (1- (ash 1 (1- exponent-bits))))
 524          (exp-min (- (1- exp-max)))
 525          (exp-bias exp-max)
 526          ;; mantissa-bits excludes the hidden bit
 527          (total-bits (+ mantissa-bits exponent-bits 1)))
 528     (labels ((try (sign-bit exponent mantissa)
 529                (let* ((bit-pattern
 530                        (logior (ash sign-bit (+ exponent-bits mantissa-bits))
 531                                (ash (+ exp-bias exponent) mantissa-bits)
 532                                mantissa))
 533                       (signed-bits
 534                        (sb-disassem:sign-extend bit-pattern total-bits))
 535                       (x (ecase type
 536                           (single-float
 537                            (sb-kernel:make-single-float signed-bits))
 538                           (double-float
 539                            (sb-kernel:make-double-float (ash signed-bits -32)
 540                                                         (ldb (byte 32 0) signed-bits))))))
 541                  (when print
 542                    (format t "~v,'0b -> ~f~%" total-bits bit-pattern x))
 543                  (multiple-value-bind (significand exponent sign) (decode-float x)
 544                    (let ((reconstructed (* significand (expt 2 exponent) sign)))
 545                      (unless (= reconstructed x)
 546                        (error "DF -> ~s ~s ~s -> ~f~%" significand exponent sign
 547                               reconstructed))))
 548                  (multiple-value-bind (significand exponent sign) (integer-decode-float x)
 549                    (let ((reconstructed (* significand (expt 2 exponent) sign)))
 550                      (unless (= reconstructed x)
 551                        (error "IDF -> ~s ~s ~s -> ~f~%" significand exponent sign
 552                               reconstructed)))))))
 553       ;; walking 1 bit
 554       (loop for exp from exp-min to (1- exp-max)
 555             do (let ((bit (ash 1 mantissa-bits)))
 556                  (loop while (/= bit 0)
 557                        do (try 0 exp (ldb (byte mantissa-bits 0) bit))
 558                           (setq bit (ash bit -1))))))))
 559
 560 (with-test (:name :test-float-decoders)
 561   (flet ((test-df (input expect-sig expect-exp expect-sign)
 562            (multiple-value-bind (significand exponent sign)
 563                (decode-float input)
 564              (assert (and (= significand expect-sig)
 565                           (= exponent expect-exp)
 566                           (= sign expect-sign)))))
 567          (test-idf (input expect-sig expect-exp expect-sign)
 568            (multiple-value-bind (significand exponent sign)
 569                (integer-decode-float input)
 570              (assert (and (= significand expect-sig)
 571                           (= exponent expect-exp)
 572                           (= sign expect-sign))))))
 573     (test-df +0s0 0.0s0 0 1.0)
 574     (test-df -0s0 0.0s0 0 -1.0)
 575     (test-df +0d0 0.0d0 0 1.0d0)
 576     (test-df -0d0 0.0d0 0 -1.0d0)
 577     (test-idf +0s0 0 0 1)
 578     (test-idf -0s0 0 0 -1)
 579     (test-idf +0d0 0 0 1)
 580     (test-idf -0d0 0 0 -1)
 581     (test-idf least-positive-normalized-single-float 8388608 -149 1)
 582     (test-idf least-negative-normalized-single-float 8388608 -149 -1)
 583     (test-idf least-positive-normalized-double-float 4503599627370496 -1074 1)
 584     (test-idf least-negative-normalized-double-float 4503599627370496 -1074 -1))
 585   (exercise-float-decoder 'single-float  8 23)
 586   (exercise-float-decoder 'double-float 11 52)
 587   ;; TODO: test denormals
 588   )
 589
 590
 591 (with-test (:name :conservative-floor-bounds)
 592   (assert
 593    (subtypep (second (third (sb-kernel:%simple-fun-type
 594                           (checked-compile
 595                            `(lambda (x)
 596                               (declare (unsigned-byte x))
 597                               (values (truncate 1.0 x)))))))
 598              'unsigned-byte)))
 599
 600 (with-test (:name :single-float-sign-stubs)
 601   (checked-compile-and-assert
 602    ()
 603    '(lambda (p1)
 604      (declare (type (eql -96088.234) p1))
 605      (float-sign
 606       (the single-float
 607        (labels ((%f () (the real p1))) (%f)))))
 608    ((-96088.234) -1.0)))
 609
 610 (with-test (:name :inline-signum)
 611   (assert (equal '(signum)
 612                  (ctu:ir1-named-calls ; should be a full call
 613                         '(lambda (x)
 614                            (signum (truly-the number x))))))
 615   ;; FIXME: This test passed by accident on backends that didn't fully inline
 616   ;; the call, because PLUSP (from the IR transform) is an asm routine.
 617   #+x86-64
 618   (dolist (type '(integer
 619                   (or (integer 1 10) (integer 50 90))
 620                   rational
 621                   single-float
 622                   (or (single-float -10f0 0f0) (single-float 1f0 20f0))
 623                   double-float
 624                   (or (double-float -10d0 0d0) (double-float 1d0 20d0))))
 625     (assert (null (ctu:ir1-named-calls
 626                                 `(lambda (x)
 627                                    (signum (truly-the ,type x)))))))
 628   ;; check signed zero
 629   (let ((f (compile nil '(lambda (x) (signum (the single-float x))))))
 630     (assert (eql (funcall f -0f0) -0f0))
 631     (assert (eql (funcall f +0f0) +0f0)))
 632   (let ((f (compile nil '(lambda (x) (signum (the double-float x))))))
 633     (assert (eql (funcall f -0d0) -0d0))
 634     (assert (eql (funcall f +0d0) +0d0))))
 635
 636
 637 (with-test (:name :expt-double-no-complex)
 638   (checked-compile-and-assert
 639       (:allow-notes nil)
 640       `(lambda (x y)
 641          (> (expt (the double-float x) 4d0)
 642             (the double-float y)))
 643     ((1d0 0d0) t))
 644   (checked-compile-and-assert
 645       (:allow-notes nil)
 646       `(lambda (x y)
 647          (> (expt (the (double-float 0d0) x) (the double-float y))
 648             y))
 649     ((1d0 0d0) t)))
 650
 651 (with-test (:name :ftruncate-inline
 652             :fails-on :ppc64
 653             :skipped-on (not :64-bit))
 654   (checked-compile
 655    `(lambda (v d)
 656       (declare (optimize speed)
 657                (double-float d)
 658                ((simple-array double-float (2)) v))
 659       (setf (aref v 0) (ffloor (aref v 0) d))
 660       v)
 661    :allow-notes nil))
 662
 663 (with-test (:name :ctype-of-nan)
 664   (checked-compile '(lambda () #.(sb-kernel:make-single-float -1))))
 665
 666 ;; bug #1914094
 667 (with-test (:name :float-type-derivation :skipped-on (not :64-bit))
 668   (labels ((car-type-equal (x y)
 669              (and (subtypep (car x) (car y))
 670                   (subtypep (car y) (car x)))))
 671     (let ((long #+long-float 'long-float
 672                 #-long-float 'double-float))
 673       (checked-compile-and-assert () '(lambda (x) (ctu:compiler-derived-type (* 3d0 x)))
 674         ((1) (values `(or ,long (complex ,long)) t) :test #'car-type-equal))
 675       (checked-compile-and-assert () '(lambda (x) (ctu:compiler-derived-type (* 3f0 x)))
 676         ((1) (values `(or single-float ,long (complex single-float) (complex ,long)) t)
 677          :test #'car-type-equal))
 678       (checked-compile-and-assert () '(lambda (x) (ctu:compiler-derived-type (* 3f0 x)))
 679         ((1) (values `(or single-float ,long (complex single-float) (complex ,long)) t)
 680          :test #'car-type-equal))
 681       (checked-compile-and-assert () '(lambda (x y) (ctu:compiler-derived-type (atan x y)))
 682         ((1 2) (values `(or ,long single-float (complex ,long) (complex single-float)) t) :test #'car-type-equal)))))
 683
 684 (with-test (:name :comparison-transform-overflow)
 685   (checked-compile-and-assert
 686    ()
 687    `(lambda (a)
 688       (declare (float a))
 689       (= a 1854150818890592943838975159000134470424763027560))
 690    ((1d0) nil)
 691    ((1f0) nil)))
 692
 693 (with-test (:name :comparison-merging)
 694   (checked-compile-and-assert
 695    ()
 696    `(lambda (a b)
 697       (declare (double-float a b))
 698       (cond ((= a b) 0)
 699             ((< a b) 1)
 700             (t 2)))
 701    ((1d0 1d0) 0)
 702    ((1d0 3d0) 1)
 703    ((3d0 1d0) 2)))
 704
 705 ;; Based on example in lp#1926383
 706 (defun idf (x) (multiple-value-list (cl:integer-decode-float x)))
 707 (defun testfloat (k)
 708   (let* ((kidf (idf k))
 709          (kff (float (* (car kidf) (expt 2 (cadr kidf))) k))
 710          (kss (scale-float (float (car kidf) k) (cadr kidf))))
 711     (format t "Input k(~a): ~,15e, IDF ~{~b ~d ~d~}~%" (type-of k) k kidf)
 712     (format t "float k(~a): ~,15e, IDF ~{~b ~d ~d~}, diff ~,5e~%" (type-of k) kff (idf kff) (- k kff))
 713     (format t "scale k(~a): ~,15e, IDF ~{~b ~d ~d~}, diff ~,5e~%" (type-of k) kff (idf kss) (- k kss))))
 714
 715 ;;; (time (exhaustive-test-single-floats))
 716 ;;; Evaluation took:
 717 ;;;   12.873 seconds of real time
 718 ;;;   12.666938 seconds of total run time (12.629706 user, 0.037232 system)
 719 ;;;   [ Run times consist of 0.055 seconds GC time, and 12.612 seconds non-GC time. ]
 720 ;;;   98.40% CPU
 721 ;;;   36,149,296,946 processor cycles
 722 ;;;   5,033,148,304 bytes consed
 723 ;;;
 724 #+nil ; This is too slow to be a regression test. And why does it cons?
 725 (defun exhaustive-test-single-floats ()
 726   (loop for i from 1 to (1- (ash 1 23))
 727      do (let ((k (sb-kernel:make-lisp-obj (logior (ash i 32) sb-vm:single-float-widetag))))
 728           (multiple-value-bind (mant exp sign) (integer-decode-float k)
 729             (declare (ignore sign))
 730             (let ((way1 (float (* mant (expt 2 exp)) k))
 731                   (way2 (scale-float (float mant k) exp)))
 732               ;; Do bitwise comparison
 733               (assert (= (sb-kernel:single-float-bits k)
 734                          (sb-kernel:single-float-bits way1)))
 735               (assert (= (sb-kernel:single-float-bits k)
 736                          (sb-kernel:single-float-bits way2))))))))
 737
 738 ;;; For #+64-bit we could eradicate the legacy interface
 739 ;;; to MAKE-DOUBLE-FLOAT, and just take the bits.
 740 (defun mdf (bits)
 741   (let ((hi (ldb (byte 32 32) bits))
 742         (lo (ldb (byte 32  0) bits)))
 743     (sb-kernel:make-double-float (sb-disassem:sign-extend hi 32) lo)))
 744 (compile 'mdf)
 745
 746 #+64-bit
 747 (progn
 748 (defun test-single-floats (n)
 749   (dotimes (i n)
 750     (let* ((bits (random (ash 1 23)))
 751            ;; This isn't a valid call to MAKE-LISP-OBJ for 32 bit words
 752            (k (sb-kernel:make-lisp-obj (logior (ash i 32) sb-vm:single-float-widetag))))
 753       (when (zerop bits) (incf bits))
 754       (multiple-value-bind (mant exp sign) (integer-decode-float k)
 755         (declare (ignore sign))
 756         (let ((way1 (float (* mant (expt 2 exp)) k))
 757               (way2 (scale-float (float mant k) exp)))
 758           ;; Do bitwise comparison
 759           (assert (= (sb-kernel:single-float-bits k)
 760                      (sb-kernel:single-float-bits way1)))
 761           (assert (= (sb-kernel:single-float-bits k)
 762                      (sb-kernel:single-float-bits way2))))))))
 763
 764 (defun test-double-floats (n)
 765   (dotimes (i n)
 766     (let ((bits (random (ash 1 52))))
 767       (when (zerop bits) (incf bits))
 768       (let ((k (mdf bits)))
 769         (multiple-value-bind (mant exp sign) (integer-decode-float k)
 770           (declare (ignore sign))
 771           (let ((way1 (float (* mant (expt 2 exp)) k))
 772                 (way2 (scale-float (float mant k) exp)))
 773             ;; Do bitwise comparison
 774             (assert (= (sb-kernel:double-float-bits k)
 775                        (sb-kernel:double-float-bits way1)))
 776             (assert (= (sb-kernel:double-float-bits k)
 777                        (sb-kernel:double-float-bits way2)))))))))
 778
 779 (with-test (:name :round-trip-decode-recompose)
 780   (test-single-floats 10000)
 781   (test-double-floats 10000))
 782 )
 783
 784 ;; lp#1920931
 785 (with-test (:name :coerce-to-float-no-warning)
 786   (let ((f (checked-compile '(lambda (y) (coerce (sqrt y) 'float)))))
 787     (assert (floatp (funcall f 3)))
 788     (assert-error (funcall f #c(1 2)))))
 789
 790 (with-test (:name :imagpart-real-negative-zero-derived-type)
 791   (checked-compile-and-assert
 792    ()
 793    `(lambda (x)
 794       (eql (imagpart (the real x)) -0.0))
 795    ((-1.0) t)))
 796
 797 (with-test (:name :negative-zero-in-ranges)
 798   (checked-compile-and-assert
 799       ()
 800       `(lambda (x y)
 801          (declare ((or (integer 0 0) (double-float 0.0d0 0.0d0)) x)
 802                   ((or (rational -10 0) (double-float -10.0d0 -0.0d0)) y))
 803          (= x y))
 804   ((0 0) t)
 805   ((0 0d0) t)
 806   ((0 -0d0) t)
 807   ((0d0 -0d0) t)
 808   ((0 -1d0) nil)))
 809
 810 (with-test (:name :unary-truncate-float-derive-type)
 811   (assert
 812    (subtypep (second (third (sb-kernel:%simple-fun-type
 813                              (checked-compile
 814                               `(lambda (f)
 815                                  (declare ((double-float 10d0 30d0) f))
 816                                  (values (truncate f)))))))
 817              '(integer 10 30))))
 818
 819 (with-test (:name :rational-not-bignum)
 820   (assert (equal (type-of (eval '(rational -4.3973217e12)))
 821                  (type-of -4397321682944))))
 822
 823 (with-test (:name :single-to-double-comparsion)
 824   (assert (= (count 'sb-kernel:%double-float
 825                     (ctu:ir1-named-calls
 826                      `(lambda (x)
 827                         (declare (single-float x))
 828                         (= x 1d0))
 829                      nil))
 830              0)))
 831
 832 (with-test (:name :float-to-known-comparison)
 833   (assert (= (count 'sb-int:single-float-p
 834                     (ctu:ir1-named-calls
 835                      `(lambda (x)
 836                         (declare (float x)
 837                                  (optimize speed))
 838                         (= x 1d0))
 839                      nil))
 840              1))
 841   (assert (= (count 'sb-int:single-float-p
 842                     (ctu:ir1-named-calls
 843                      `(lambda (x y)
 844                         (declare (float x)
 845                                  ((signed-byte 8) y)
 846                                  (optimize speed))
 847                         (= x y))
 848                      nil))
 849              1))
 850   (assert (= (count 'sb-int:single-float-p
 851                     (ctu:ir1-named-calls
 852                      `(lambda (x)
 853                         (declare (float x)
 854                                  (optimize (speed 1)))
 855                         (= x 1d0))
 856                      nil))
 857              0)))