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                   :fails-on :sbcl)
 322   (let ((twos (list 2 2.0f0 2.0d0 #c(2.0f0 0.0f0) #c(2.0d0 0.0d0))))
 323     (let ((result (loop for number in twos
 324                         append (loop for base in twos
 325                                      for result = (log number base)
 326                                      if (/= (realpart result) 1)
 327                                      collect (list number base result)))))
 328       (assert (null result)))))
 329
 330 ;; Bug reported by Eric Marsden on July 15 2009. The compiler
 331 ;; used not to constant fold calls with arguments of type
 332 ;; (EQL foo).
 333 (with-test (:name :eql-type-constant-fold)
 334   (assert (equal '(FUNCTION (T) (VALUES (MEMBER T) &OPTIONAL))
 335                  (sb-kernel:%simple-fun-type
 336                   (compile nil `(lambda (x)
 337                                   (eql #c(1.0 2.0)
 338                                        (the (eql #c(1.0 2.0))
 339                                          x))))))))
 340
 341 ;; Leakage from the host could result in wrong values for truncation.
 342 (with-test (:name :truncate)
 343   (assert (plusp (sb-kernel:%unary-truncate (expt 2f0 33))))
 344   (assert (plusp (sb-kernel:%unary-truncate (expt 2d0 33))))
 345   ;; That'd be one strange host, but just in case
 346   (assert (plusp (sb-kernel:%unary-truncate (expt 2f0 65))))
 347   (assert (plusp (sb-kernel:%unary-truncate (expt 2d0 65)))))
 348
 349 ;; On x86-64, we sometimes forgot to clear the higher order bits of the
 350 ;; destination register before using it with an instruction that doesn't
 351 ;; clear the (unused) high order bits. Suspect instructions are operations
 352 ;; with only one operand: for everything else, the destination has already
 353 ;; been loaded with a value, making it safe (by induction).
 354 ;;
 355 ;; The tests are extremely brittle and could be broken by any number of
 356 ;; back- or front-end optimisations. We should just keep the issue above
 357 ;; in mind at all times when working with SSE or similar instruction sets.
 358 ;;
 359 ;; Run only on x86/x86-64m as no other platforms have SB-VM::TOUCH-OBJECT.
 360 #-interpreter
 361 (macrolet ((with-pinned-floats ((count type &rest names) &body body)
 362              "Force COUNT float values to be kept live (and hopefully in registers),
 363               fill a temporary register with noise, and execute BODY."
 364              ;; KLUDGE: SB-VM is locked, and non-x86oids don't have
 365              ;; SB-VM::TOUCH-OBJECT.  Don't even READ this body on
 366              ;; other platforms.
 367              #-(or x86 x86-64)
 368              (declare (ignore count type names body))
 369              #+(or x86 x86-64)
 370              (let ((dummy (loop repeat count
 371                                 collect (or (pop names)
 372                                             (gensym "TEMP")))))
 373                `(let ,(loop for i downfrom -1
 374                             for var in dummy
 375                             for j = (coerce i type)
 376                             collect
 377                             `(,var ,(complex j j))) ; we don't actually need that, but
 378                   (declare (type (complex ,type) ,@dummy)) ; future-proofing can't hurt
 379                   ,@(loop for var in dummy
 380                           for i upfrom 0
 381                           collect `(setf ,var ,(complex i (coerce i type))))
 382                   (multiple-value-prog1
 383                       (progn
 384                         (let ((x ,(complex 1d0 1d0)))
 385                           (declare (type (complex double-float) x))
 386                           (setf x ,(complex most-positive-fixnum (float most-positive-fixnum 1d0)))
 387                           (sb-vm::touch-object x))
 388                         (locally ,@body))
 389                     ,@(loop for var in dummy
 390                             collect `(sb-vm::touch-object ,var)))))))
 391   (with-test (:name :clear-sqrtsd :skipped-on (not (or :x86 :x86-64)))
 392     (flet ((test-sqrtsd (float)
 393              (declare (optimize speed (safety 1))
 394                       (type (double-float (0d0)) float))
 395              (with-pinned-floats (14 double-float x0)
 396                (let ((x (sqrt float)))
 397                  (values (+ x x0) float)))))
 398       (declare (notinline test-sqrtsd))
 399       (assert (zerop (imagpart (test-sqrtsd 4d0))))))
 400
 401   (with-test (:name :clear-sqrtsd-single :skipped-on (not (or :x86 :x86-64)))
 402     (flet ((test-sqrtsd-float (float)
 403              (declare (optimize speed (safety 1))
 404                       (type (single-float (0f0)) float))
 405              (with-pinned-floats (14 single-float x0)
 406                (let ((x (sqrt float)))
 407                  (values (+ x x0) float)))))
 408       (declare (notinline test-sqrtsd-float))
 409       (assert (zerop (imagpart (test-sqrtsd-float 4f0))))))
 410
 411   (with-test (:name :clear-cvtss2sd :skipped-on (not (or :x86 :x86-64)))
 412     (flet ((test-cvtss2sd (float)
 413              (declare (optimize speed (safety 1))
 414                       (type single-float float))
 415              (with-pinned-floats (14 double-float x0)
 416                (let ((x (float float 0d0)))
 417                  (values (+ x x0) (+ 1e0 float))))))
 418       (declare (notinline test-cvtss2sd))
 419       (assert (zerop (imagpart (test-cvtss2sd 1f0))))))
 420
 421   (with-test (:name :clear-cvtsd2ss :skipped-on (not (or :x86 :x86-64)))
 422     (flet ((test-cvtsd2ss (float)
 423              (declare (optimize speed (safety 1))
 424                       (type double-float float))
 425              (with-pinned-floats (14 single-float x0)
 426                (let ((x (float float 1e0)))
 427                  (values (+ x x0) (+ 1d0 float))))))
 428       (declare (notinline test-cvtsd2ss))
 429       (assert (zerop (imagpart (test-cvtsd2ss 4d0))))))
 430
 431   (with-test (:name :clear-cvtsi2sd :skipped-on (not (or :x86 :x86-64)))
 432     (flet ((test-cvtsi2sd (int)
 433              (declare (optimize speed (safety 0))
 434                       (type (unsigned-byte 10) int))
 435              (with-pinned-floats (15 double-float x0)
 436                (+ (float int 0d0) x0))))
 437       (declare (notinline test-cvtsi2sd))
 438       (assert (zerop (imagpart (test-cvtsi2sd 4))))))
 439
 440   (with-test (:name :clear-cvtsi2ss :skipped-on (not (or :x86 :x86-64)))
 441     (flet ((test-cvtsi2ss (int)
 442              (declare (optimize speed (safety 0))
 443                       (type (unsigned-byte 10) int))
 444              (with-pinned-floats (15 single-float x0)
 445                (+ (float int 0e0) x0))))
 446       (declare (notinline test-cvtsi2ss))
 447       (assert (zerop (imagpart (test-cvtsi2ss 4)))))))
 448
 449 (with-test (:name :round-to-bignum)
 450   (assert (= (round 1073741822.3d0) 1073741822))
 451   (assert (= (round 1073741822.5d0) 1073741822))
 452   (assert (= (round 1073741822.7d0) 1073741823))
 453   (assert (= (round 1073741823.3d0) 1073741823))
 454   (assert (= (round 1073741823.5d0) 1073741824))
 455   (assert (= (round 1073741823.7d0) 1073741824)))
 456
 457 (with-test (:name :round-single-to-bignum)
 458   (assert (= (round 1e14) 100000000376832))
 459   (assert (= (round 1e19) 9999999980506447872)))
 460
 461 (with-test (:name :scaled-%hypot)
 462   (assert (<= (abs (complex most-positive-double-float 1d0))
 463               (1+ most-positive-double-float))))
 464
 465 ;; On x86-64, MAKE-SINGLE-FLOAT with a negative argument used to set
 466 ;; bits 32-63 of the XMM register to 1, breaking the invariant that
 467 ;; unused parts of XMM registers are always zero. This could become
 468 ;; visible as a QNaN in the imaginary part when next using the register
 469 ;; in a (COMPLEX SINGLE-FLOAT) operation.
 470 (with-test (:name :make-single-float-clear-imagpart)
 471   (let ((f (checked-compile
 472             '(lambda (x)
 473               (declare (optimize speed))
 474               (= #c(1.0f0 2.0f0)
 475                (+ #c(3.0f0 2.0f0)
 476                 (sb-kernel:make-single-float x))))))
 477         (bits (sb-kernel:single-float-bits -2.0f0)))
 478     (assert (< bits 0))         ; Make sure the test is fit for purpose.
 479     (assert (funcall f bits))))
 480
 481 (with-test (:name :negative-zero-derivation)
 482   (assert (not
 483            (funcall (checked-compile
 484                      '(lambda (exponent)
 485                        (declare ((integer 0 1) exponent))
 486                        (eql 0d0 (scale-float -0.0d0 exponent))))
 487                     0))))
 488
 489 (with-test (:name :complex-eql-all-constants)
 490   (assert (funcall (checked-compile
 491                     '(lambda ()
 492                       (declare (optimize (debug 2)))
 493                       (typep #c(1.0 1.0) '(member #c(1.0 1.0))))))))
 494
 495 (with-test (:name (truncate float :no-consing)
 496                   :skipped-on :interpreter)
 497   (let ((f (checked-compile
 498             '(lambda (x)
 499               (values (truncate (the double-float x)))))))
 500     (ctu:assert-no-consing (funcall f 1d0))
 501     (ctu:assert-no-consing (funcall f (float most-negative-fixnum 1d0))))
 502   (let ((f (checked-compile
 503             '(lambda (x)
 504               (values (truncate (the single-float x)))))))
 505     (ctu:assert-no-consing (funcall f 1f0))
 506     (ctu:assert-no-consing (funcall f (float most-negative-fixnum 1f0)))))
 507
 508 (with-test (:name :trig-derive-type-complex-rational)
 509   (macrolet ((test (fun type)
 510                `(checked-compile-and-assert
 511                  ()
 512                  '(lambda (a)
 513                    (declare ((complex ,type) a))
 514                    (,fun a))
 515                  ((#C(1 2)) (eval '(,fun #C(1 2)))))))
 516     (test sin integer)
 517     (test cos integer)
 518     (test tan integer)
 519     (test sin rational)
 520     (test cos rational)
 521     (test tan rational)))
 522
 523 (defun exercise-float-decoder (type exponent-bits mantissa-bits &optional print)
 524   (let* ((exp-max (1- (ash 1 (1- exponent-bits))))
 525          (exp-min (- (1- exp-max)))
 526          (exp-bias exp-max)
 527          ;; mantissa-bits excludes the hidden bit
 528          (total-bits (+ mantissa-bits exponent-bits 1)))
 529     (labels ((try (sign-bit exponent mantissa)
 530                (let* ((bit-pattern
 531                        (logior (ash sign-bit (+ exponent-bits mantissa-bits))
 532                                (ash (+ exp-bias exponent) mantissa-bits)
 533                                mantissa))
 534                       (signed-bits
 535                        (sb-disassem:sign-extend bit-pattern total-bits))
 536                       (x (ecase type
 537                           (single-float
 538                            (sb-kernel:make-single-float signed-bits))
 539                           (double-float
 540                            (sb-kernel:make-double-float (ash signed-bits -32)
 541                                                         (ldb (byte 32 0) signed-bits))))))
 542                  (when print
 543                    (format t "~v,'0b -> ~f~%" total-bits bit-pattern x))
 544                  (multiple-value-bind (significand exponent sign) (decode-float x)
 545                    (let ((reconstructed (* significand (expt 2 exponent) sign)))
 546                      (unless (= reconstructed x)
 547                        (error "DF -> ~s ~s ~s -> ~f~%" significand exponent sign
 548                               reconstructed))))
 549                  (multiple-value-bind (significand exponent sign) (integer-decode-float x)
 550                    (let ((reconstructed (* significand (expt 2 exponent) sign)))
 551                      (unless (= reconstructed x)
 552                        (error "IDF -> ~s ~s ~s -> ~f~%" significand exponent sign
 553                               reconstructed)))))))
 554       ;; walking 1 bit
 555       (loop for exp from exp-min to (1- exp-max)
 556             do (let ((bit (ash 1 mantissa-bits)))
 557                  (loop while (/= bit 0)
 558                        do (try 0 exp (ldb (byte mantissa-bits 0) bit))
 559                           (setq bit (ash bit -1))))))))
 560
 561 (with-test (:name :test-float-decoders)
 562   (flet ((test-df (input expect-sig expect-exp expect-sign)
 563            (multiple-value-bind (significand exponent sign)
 564                (decode-float input)
 565              (assert (and (= significand expect-sig)
 566                           (= exponent expect-exp)
 567                           (= sign expect-sign)))))
 568          (test-idf (input expect-sig expect-exp expect-sign)
 569            (multiple-value-bind (significand exponent sign)
 570                (integer-decode-float input)
 571              (assert (and (= significand expect-sig)
 572                           (= exponent expect-exp)
 573                           (= sign expect-sign))))))
 574     (test-df +0s0 0.0s0 0 1.0)
 575     (test-df -0s0 0.0s0 0 -1.0)
 576     (test-df +0d0 0.0d0 0 1.0d0)
 577     (test-df -0d0 0.0d0 0 -1.0d0)
 578     (test-idf +0s0 0 0 1)
 579     (test-idf -0s0 0 0 -1)
 580     (test-idf +0d0 0 0 1)
 581     (test-idf -0d0 0 0 -1)
 582     (test-idf least-positive-normalized-single-float 8388608 -149 1)
 583     (test-idf least-negative-normalized-single-float 8388608 -149 -1)
 584     (test-idf least-positive-normalized-double-float 4503599627370496 -1074 1)
 585     (test-idf least-negative-normalized-double-float 4503599627370496 -1074 -1))
 586   (exercise-float-decoder 'single-float  8 23)
 587   (exercise-float-decoder 'double-float 11 52)
 588   ;; TODO: test denormals
 589   )
 590
 591
 592 (with-test (:name :conservative-floor-bounds)
 593   (assert
 594    (subtypep (second (third (sb-kernel:%simple-fun-type
 595                           (checked-compile
 596                            `(lambda (x)
 597                               (declare (unsigned-byte x))
 598                               (values (truncate 1.0 x)))))))
 599              'unsigned-byte)))
 600
 601 (with-test (:name :single-float-sign-stubs)
 602   (checked-compile-and-assert
 603    ()
 604    '(lambda (p1)
 605      (declare (type (eql -96088.234) p1))
 606      (float-sign
 607       (the single-float
 608        (labels ((%f () (the real p1))) (%f)))))
 609    ((-96088.234) -1.0)))
 610
 611 (with-test (:name :inline-signum)
 612   (assert (equal '(signum)
 613                  (ctu:ir1-named-calls ; should be a full call
 614                         '(lambda (x)
 615                            (signum (truly-the number x))))))
 616   ;; FIXME: This test passed by accident on backends that didn't fully inline
 617   ;; the call, because PLUSP (from the IR transform) is an asm routine.
 618   #+x86-64
 619   (dolist (type '(integer
 620                   (or (integer 1 10) (integer 50 90))
 621                   rational
 622                   single-float
 623                   (or (single-float -10f0 0f0) (single-float 1f0 20f0))
 624                   double-float
 625                   (or (double-float -10d0 0d0) (double-float 1d0 20d0))))
 626     (assert (null (ctu:ir1-named-calls
 627                                 `(lambda (x)
 628                                    (signum (truly-the ,type x)))))))
 629   ;; check signed zero
 630   (let ((f (compile nil '(lambda (x) (signum (the single-float x))))))
 631     (assert (eql (funcall f -0f0) -0f0))
 632     (assert (eql (funcall f +0f0) +0f0)))
 633   (let ((f (compile nil '(lambda (x) (signum (the double-float x))))))
 634     (assert (eql (funcall f -0d0) -0d0))
 635     (assert (eql (funcall f +0d0) +0d0))))
 636
 637
 638 (with-test (:name :expt-double-no-complex)
 639   (checked-compile-and-assert
 640       (:allow-notes nil)
 641       `(lambda (x y)
 642          (> (expt (the double-float x) 4d0)
 643             (the double-float y)))
 644     ((1d0 0d0) t))
 645   (checked-compile-and-assert
 646       (:allow-notes nil)
 647       `(lambda (x y)
 648          (> (expt (the (double-float 0d0) x) (the double-float y))
 649             y))
 650     ((1d0 0d0) t)))
 651
 652 (with-test (:name :ftruncate-inline
 653             :fails-on :ppc64
 654             :skipped-on (not :64-bit))
 655   (checked-compile
 656    `(lambda (v d)
 657       (declare (optimize speed)
 658                (double-float d)
 659                ((simple-array double-float (2)) v))
 660       (setf (aref v 0) (ffloor (aref v 0) d))
 661       v)
 662    :allow-notes nil))
 663
 664 (with-test (:name :ctype-of-nan)
 665   (checked-compile '(lambda () #.(sb-kernel:make-single-float -1))))
 666
 667 ;; bug #1914094
 668 (with-test (:name :float-type-derivation :skipped-on (not :64-bit))
 669   (labels ((car-type-equal (x y)
 670              (and (subtypep (car x) (car y))
 671                   (subtypep (car y) (car x)))))
 672     (let ((long #+long-float 'long-float
 673                 #-long-float 'double-float))
 674       (checked-compile-and-assert () '(lambda (x) (ctu:compiler-derived-type (* 3d0 x)))
 675         ((1) (values `(or ,long (complex ,long)) t) :test #'car-type-equal))
 676       (checked-compile-and-assert () '(lambda (x) (ctu:compiler-derived-type (* 3f0 x)))
 677         ((1) (values `(or single-float ,long (complex single-float) (complex ,long)) t)
 678          :test #'car-type-equal))
 679       (checked-compile-and-assert () '(lambda (x) (ctu:compiler-derived-type (* 3f0 x)))
 680         ((1) (values `(or single-float ,long (complex single-float) (complex ,long)) t)
 681          :test #'car-type-equal))
 682       (checked-compile-and-assert () '(lambda (x y) (ctu:compiler-derived-type (atan x y)))
 683         ((1 2) (values `(or ,long single-float (complex ,long) (complex single-float)) t) :test #'car-type-equal)))))
 684
 685 (with-test (:name :comparison-transform-overflow)
 686   (checked-compile-and-assert
 687    ()
 688    `(lambda (a)
 689       (declare (float a))
 690       (= a 1854150818890592943838975159000134470424763027560))
 691    ((1d0) nil)
 692    ((1f0) nil)))
 693
 694 (with-test (:name :comparison-merging)
 695   (checked-compile-and-assert
 696    ()
 697    `(lambda (a b)
 698       (declare (double-float a b))
 699       (cond ((= a b) 0)
 700             ((< a b) 1)
 701             (t 2)))
 702    ((1d0 1d0) 0)
 703    ((1d0 3d0) 1)
 704    ((3d0 1d0) 2)))
 705
 706 ;; Based on example in lp#1926383
 707 (defun idf (x) (multiple-value-list (cl:integer-decode-float x)))
 708 (defun testfloat (k)
 709   (let* ((kidf (idf k))
 710          (kff (float (* (car kidf) (expt 2 (cadr kidf))) k))
 711          (kss (scale-float (float (car kidf) k) (cadr kidf))))
 712     (format t "Input k(~a): ~,15e, IDF ~{~b ~d ~d~}~%" (type-of k) k kidf)
 713     (format t "float k(~a): ~,15e, IDF ~{~b ~d ~d~}, diff ~,5e~%" (type-of k) kff (idf kff) (- k kff))
 714     (format t "scale k(~a): ~,15e, IDF ~{~b ~d ~d~}, diff ~,5e~%" (type-of k) kff (idf kss) (- k kss))))
 715
 716 ;;; (time (exhaustive-test-single-floats))
 717 ;;; Evaluation took:
 718 ;;;   12.873 seconds of real time
 719 ;;;   12.666938 seconds of total run time (12.629706 user, 0.037232 system)
 720 ;;;   [ Run times consist of 0.055 seconds GC time, and 12.612 seconds non-GC time. ]
 721 ;;;   98.40% CPU
 722 ;;;   36,149,296,946 processor cycles
 723 ;;;   5,033,148,304 bytes consed
 724 ;;;
 725 #+nil ; This is too slow to be a regression test. And why does it cons?
 726 (defun exhaustive-test-single-floats ()
 727   (loop for i from 1 to (1- (ash 1 23))
 728      do (let ((k (sb-kernel:make-lisp-obj (logior (ash i 32) sb-vm:single-float-widetag))))
 729           (multiple-value-bind (mant exp sign) (integer-decode-float k)
 730             (declare (ignore sign))
 731             (let ((way1 (float (* mant (expt 2 exp)) k))
 732                   (way2 (scale-float (float mant k) exp)))
 733               ;; Do bitwise comparison
 734               (assert (= (sb-kernel:single-float-bits k)
 735                          (sb-kernel:single-float-bits way1)))
 736               (assert (= (sb-kernel:single-float-bits k)
 737                          (sb-kernel:single-float-bits way2))))))))
 738
 739 ;;; For #+64-bit we could eradicate the legacy interface
 740 ;;; to MAKE-DOUBLE-FLOAT, and just take the bits.
 741 (defun mdf (bits)
 742   (let ((hi (ldb (byte 32 32) bits))
 743         (lo (ldb (byte 32  0) bits)))
 744     (sb-kernel:make-double-float (sb-disassem:sign-extend hi 32) lo)))
 745 (compile 'mdf)
 746
 747 #+64-bit
 748 (progn
 749 (defun test-single-floats (n)
 750   (dotimes (i n)
 751     (let* ((bits (random (ash 1 23)))
 752            ;; This isn't a valid call to MAKE-LISP-OBJ for 32 bit words
 753            (k (sb-kernel:make-lisp-obj (logior (ash i 32) sb-vm:single-float-widetag))))
 754       (when (zerop bits) (incf bits))
 755       (multiple-value-bind (mant exp sign) (integer-decode-float k)
 756         (declare (ignore sign))
 757         (let ((way1 (float (* mant (expt 2 exp)) k))
 758               (way2 (scale-float (float mant k) exp)))
 759           ;; Do bitwise comparison
 760           (assert (= (sb-kernel:single-float-bits k)
 761                      (sb-kernel:single-float-bits way1)))
 762           (assert (= (sb-kernel:single-float-bits k)
 763                      (sb-kernel:single-float-bits way2))))))))
 764
 765 (defun test-double-floats (n)
 766   (dotimes (i n)
 767     (let ((bits (random (ash 1 52))))
 768       (when (zerop bits) (incf bits))
 769       (let ((k (mdf bits)))
 770         (multiple-value-bind (mant exp sign) (integer-decode-float k)
 771           (declare (ignore sign))
 772           (let ((way1 (float (* mant (expt 2 exp)) k))
 773                 (way2 (scale-float (float mant k) exp)))
 774             ;; Do bitwise comparison
 775             (assert (= (sb-kernel:double-float-bits k)
 776                        (sb-kernel:double-float-bits way1)))
 777             (assert (= (sb-kernel:double-float-bits k)
 778                        (sb-kernel:double-float-bits way2)))))))))
 779
 780 (with-test (:name :round-trip-decode-recompose)
 781   (test-single-floats 10000)
 782   (test-double-floats 10000))
 783 )
 784
 785 ;; lp#1920931
 786 (with-test (:name :coerce-to-float-no-warning)
 787   (let ((f (checked-compile '(lambda (y) (coerce (sqrt y) 'float)))))
 788     (assert (floatp (funcall f 3)))
 789     (assert-error (funcall f #c(1 2)))))
 790
 791 (with-test (:name :imagpart-real-negative-zero-derived-type)
 792   (checked-compile-and-assert
 793    ()
 794    `(lambda (x)
 795       (eql (imagpart (the real x)) -0.0))
 796    ((-1.0) t)))
 797
 798 (with-test (:name :negative-zero-in-ranges)
 799   (checked-compile-and-assert
 800       ()
 801       `(lambda (x y)
 802          (declare ((or (integer 0 0) (double-float 0.0d0 0.0d0)) x)
 803                   ((or (rational -10 0) (double-float -10.0d0 -0.0d0)) y))
 804          (= x y))
 805   ((0 0) t)
 806   ((0 0d0) t)
 807   ((0 -0d0) t)
 808   ((0d0 -0d0) t)
 809   ((0 -1d0) nil)))
 810
 811 (with-test (:name :unary-truncate-float-derive-type)
 812   (assert
 813    (subtypep (second (third (sb-kernel:%simple-fun-type
 814                              (checked-compile
 815                               `(lambda (f)
 816                                  (declare ((double-float 10d0 30d0) f))
 817                                  (values (truncate f)))))))
 818              '(integer 10 30))))
 819
 820 (with-test (:name :rational-not-bignum)
 821   (assert (equal (type-of (eval '(rational -4.3973217e12)))
 822                  (type-of -4397321682944))))