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 (cl:in-package :cl-user)
  15
  16 (load "compiler-test-util.lisp")
  17
  18 (with-test (:name (:infinities :comparison))
  19   (dolist (ifnis (list (cons single-float-positive-infinity
  20                              single-float-negative-infinity)
  21                        (cons double-float-positive-infinity
  22                              double-float-negative-infinity)))
  23     (destructuring-bind (+ifni . -ifni) ifnis
  24       (assert (= (* +ifni 1) +ifni))
  25       (assert (= (* +ifni -0.1) -ifni))
  26       (assert (= (+ +ifni -0.1) +ifni))
  27       (assert (= (- +ifni -0.1) +ifni))
  28       (assert (= (sqrt +ifni) +ifni))
  29       (assert (= (* -ifni -14) +ifni))
  30       (assert (= (/ -ifni 0.1) -ifni))
  31       (assert (= (/ -ifni 100/3) -ifni))
  32       (assert (not (= +ifni -ifni)))
  33       (assert (= -ifni -ifni))
  34       (assert (not (= +ifni 100/3)))
  35       (assert (not (= -ifni -1.0 -ifni)))
  36       (assert (not (= -ifni -17/02 -ifni)))
  37       (assert (< -ifni +ifni))
  38       (assert (not (< +ifni 100)))
  39       (assert (not (< +ifni 100.0)))
  40       (assert (not (< +ifni -ifni)))
  41       (assert (< 100 +ifni))
  42       (assert (< 100.0 +ifni))
  43       (assert (>= 100 -ifni))
  44       (assert (not (<= 6/7 (* 3 -ifni))))
  45       (assert (not (> +ifni +ifni))))))
  46
  47 ;;; ANSI: FLOAT-RADIX should signal an error if its argument is not a
  48 ;;; float.
  49 ;;;
  50 ;;; (Peter Van Eynde's ansi-test suite caught this, and Eric Marsden
  51 ;;; reported a fix for CMU CL, which was ported to sbcl-0.6.12.35.)
  52 (with-test (:name (float-radix simple-type-error))
  53   (multiple-value-bind  (fun failure-p warnings)
  54       (checked-compile '(lambda () (float-radix "notfloat")) :allow-warnings t)
  55     (assert failure-p)
  56     (assert (= 1 (length warnings)))
  57     (assert-error (funcall fun) type-error))
  58   (assert-error (funcall (fdefinition 'float-radix) "notfloat") type-error))
  59
  60 ;;; Before 0.8.2.14 the cross compiler failed to work with
  61 ;;; denormalized numbers
  62 (with-test (:name (:denormalized float))
  63   (when (subtypep 'single-float 'short-float)
  64     (assert (eql least-positive-single-float least-positive-short-float))))
  65
  66 ;;; bug found by Paul Dietz: FFLOOR and similar did not work for integers
  67 (with-test (:name (ffloor integer))
  68   (let ((tests '(((ffloor -8 3) (-3.0 1))
  69                  ((fround -8 3) (-3.0 1))
  70                  ((ftruncate -8 3) (-2.0 -2))
  71                  ((fceiling -8 3) (-2.0 -2)))))
  72     (loop for (exp res) in tests
  73        for real-res = (multiple-value-list (eval exp))
  74        do (assert (equal real-res res)))))
  75
  76 ;;; bug 45b reported by PVE
  77 (with-test (:name (:least-*-*-float :bug-45b))
  78   (dolist (type '(short single double long))
  79     (dolist (sign '(positive negative))
  80       (let* ((name (find-symbol (format nil "LEAST-~A-~A-FLOAT"
  81                                         sign type)
  82                                 :cl))
  83              (value (symbol-value name)))
  84         (assert (zerop (/ value 2)))))))
  85
  86 ;;; bug found by Paul Dietz: bad rounding on small floats
  87 (with-test (:name (fround least-positive-short-float))
  88   (assert (= (fround least-positive-short-float least-positive-short-float) 1.0)))
  89
  90 ;;; bug found by Peter Seibel: scale-float was only accepting float
  91 ;;; exponents, when it should accept all integers.  (also bug #269)
  92 (with-test (:name (scale-float :bug-269))
  93   (assert (= (multiple-value-bind (significand expt sign)
  94                  (integer-decode-float least-positive-double-float)
  95                (* (scale-float (float significand 0.0d0) expt) sign))
  96              least-positive-double-float))
  97   (assert (= (multiple-value-bind (significand expt sign)
  98                  (decode-float least-positive-double-float)
  99                (* (scale-float significand expt) sign))
 100              least-positive-double-float))
 101   (assert (= 0.0 (scale-float 1.0 most-negative-fixnum)))
 102   (assert (= 0.0d0 (scale-float 1.0d0 (1- most-negative-fixnum)))))
 103
 104 (with-test (:name (:scale-float-overflow :bug-372)
 105             :fails-on (or :arm64 (and :darwin :ppc)))
 106   (flet ((test (form)
 107            (assert-error (funcall (checked-compile `(lambda () ,form)
 108                                                    :allow-style-warnings t))
 109                          floating-point-overflow)))
 110     (test '(scale-float 1.0 most-positive-fixnum))
 111     (test '(scale-float 1.0d0 (1+ most-positive-fixnum)))))
 112
 113 ;;; bug found by jsnell when nfroyd tried to implement better LOGAND
 114 ;;; type derivation.
 115 (assert (= (integer-decode-float (coerce -1756510900000000000
 116                                          'single-float))
 117            12780299))
 118
 119 ;;; MISC.564: no out-of-line %ATAN2 for constant folding
 120 (with-test (:name (:%atan2 :constant-folding))
 121   (assert (typep
 122            (funcall
 123             (checked-compile
 124              '(lambda (p1)
 125                (declare (optimize (speed 3) (safety 2) (debug 3) (space 0))
 126                         (type complex p1))
 127                (phase (the (eql #c(1.0d0 2.0d0)) p1))))
 128             #c(1.0d0 2.0d0))
 129            'double-float)))
 130
 131 ;;; More out of line functions (%COS, %SIN, %TAN) for constant folding,
 132 ;;; reported by Mika Pihlajamäki
 133 (with-test (:name (sin cos tan :constant-folding))
 134   (flet ((test (function)
 135            (funcall (checked-compile
 136                      `(lambda () (,function (tan (round 0))))))))
 137     (mapc #'test '(sin cos tan))))
 138
 139 (with-test (:name (:addition-overflow :bug-372)
 140             :fails-on (or :arm64
 141                         (and :ppc :openbsd)
 142                         (and :ppc :darwin)
 143                         (and :x86 :netbsd)))
 144   (assert-error
 145    (sb-sys:without-interrupts
 146      (sb-int:set-floating-point-modes :current-exceptions nil
 147                                       :accrued-exceptions nil)
 148      (loop repeat 2 summing most-positive-double-float)
 149      (sleep 2))
 150    floating-point-overflow))
 151
 152 ;; This is the same test as above.  Even if the above copy passes,
 153 ;; this copy will fail if SIGFPE handling ends up clearing the FPU
 154 ;; control word, which can happen if the kernel clears the FPU control
 155 ;; (a reasonable thing for it to do) and the runtime fails to
 156 ;; compensate for this (see RESTORE_FP_CONTROL_WORD in interrupt.c).
 157 ;; Note that this only works when running float.pure.lisp alone, as
 158 ;; the preceeding "pure" test files aren't as free of side effects as
 159 ;; we might like.
 160 (with-test (:name (:addition-overflow :bug-372 :take-2)
 161             :fails-on (or :arm64
 162                         (and :ppc :openbsd)
 163                         (and :ppc :darwin)
 164                         (and :x86 :netbsd)))
 165   (assert-error
 166    (sb-sys:without-interrupts
 167      (sb-int:set-floating-point-modes :current-exceptions nil
 168                                       :accrued-exceptions nil)
 169      (loop repeat 2 summing most-positive-double-float)
 170      (sleep 2))
 171    floating-point-overflow))
 172
 173 ;;; On x86-64 generating complex floats on the stack failed an aver in
 174 ;;; the compiler if the stack slot was the same as the one containing
 175 ;;; the real part of the complex. The following expression was able to
 176 ;;; trigger this in 0.9.5.62.
 177 (with-test (:name :complex-float-stack)
 178   (dolist (type '((complex double-float)
 179                   (complex single-float)))
 180     (checked-compile `(lambda (x0 x1 x2 x3 x4 x5 x6 x7)
 181                         (declare (type ,type x0 x1 x2 x3 x4 x5 x6 x7))
 182                         (let ((x0 (+ x0 x0))
 183                               (x1 (+ x1 x1))
 184                               (x2 (+ x2 x2))
 185                               (x3 (+ x3 x3))
 186                               (x4 (+ x4 x4))
 187                               (x5 (+ x5 x5))
 188                               (x6 (+ x6 x6))
 189                               (x7 (+ x7 x7)))
 190                           (* (+ x0 x1 x2 x3) (+ x4 x5 x6 x7)
 191                              (+ x0 x2 x4 x6) (+ x1 x3 x5 x7)
 192                              (+ x0 x3 x4 x7) (+ x1 x2 x5 x6)
 193                              (+ x0 x1 x6 x7) (+ x2 x3 x4 x5)))))))
 194
 195 (with-test (:name (:nan :comparison)
 196             :fails-on (or :sparc))
 197   (sb-int:with-float-traps-masked (:invalid)
 198     (macrolet ((test (form)
 199                  (let ((nform (subst '(/ 0.0 0.0) 'nan form)))
 200                    `(progn
 201                       (assert (eval ',nform))
 202                       (assert (eval `(let ((nan (/ 0.0 0.0)))
 203                                        ,',form)))
 204                       (assert (funcall
 205                                (checked-compile `(lambda () ,',nform))))
 206                       (assert (funcall
 207                                (checked-compile `(lambda (nan) ,',form))
 208                                (locally
 209                                    (declare (muffle-conditions style-warning))
 210                                  (/ 0.0 0.0))))))))
 211       (test (/= nan nan))
 212       (test (/= nan nan nan))
 213       (test (/= 1.0 nan 2.0 nan))
 214       (test (/= nan 1.0 2.0 nan))
 215       (test (not (= nan 1.0)))
 216       (test (not (= nan nan)))
 217       (test (not (= nan nan nan)))
 218       (test (not (= 1.0 nan)))
 219       (test (not (= nan 1.0)))
 220       (test (not (= 1.0 1.0 nan)))
 221       (test (not (= 1.0 nan 1.0)))
 222       (test (not (= nan 1.0 1.0)))
 223       (test (not (>= nan nan)))
 224       (test (not (>= nan 1.0)))
 225       (test (not (>= 1.0 nan)))
 226       (test (not (>= 1.0 nan 0.0)))
 227       (test (not (>= 1.0 0.0 nan)))
 228       (test (not (>= nan 1.0 0.0)))
 229       (test (not (<= nan nan)))
 230       (test (not (<= nan 1.0)))
 231       (test (not (<= 1.0 nan)))
 232       (test (not (<= 1.0 nan 2.0)))
 233       (test (not (<= 1.0 2.0 nan)))
 234       (test (not (<= nan 1.0 2.0)))
 235       (test (not (< nan nan)))
 236       (test (not (< -1.0 nan)))
 237       (test (not (< nan 1.0)))
 238       (test (not (> nan nan)))
 239       (test (not (> -1.0 nan)))
 240       (test (not (> nan 1.0))))))
 241
 242 (with-test (:name :log-int/double-accuracy)
 243   ;; we used to use single precision for intermediate results
 244   (assert (eql 2567.6046442221327d0
 245                (log (loop for n from 1 to 1000 for f = 1 then (* f n)
 246                           finally (return f))
 247                     10d0)))
 248   ;; both ways
 249   (assert (eql (log 123123123.0d0 10) (log 123123123 10.0d0))))
 250
 251 (with-test (:name :log-base-zero-return-type)
 252   (assert (eql 0.0f0 (log 123 (eval 0))))
 253   (assert (eql 0.0d0 (log 123.0d0 (eval 0))))
 254   (assert (eql 0.0d0 (log 123 (eval 0.0d0))))
 255   (let ((f (checked-compile '(lambda (x y)
 256                               (declare (optimize speed))
 257                               (etypecase x
 258                                 (single-float
 259                                  (etypecase y
 260                                    (single-float (log x y))
 261                                    (double-float (log x y))))
 262                                 (double-float
 263                                  (etypecase y
 264                                    (single-float (log x y))
 265                                    (double-float (log x y)))))))))
 266     (assert (eql 0.0f0 (funcall f 123.0 0.0)))
 267     (assert (eql 0.0d0 (funcall f 123.0d0 0.0)))
 268     (assert (eql 0.0d0 (funcall f 123.0d0 0.0d0)))
 269     (assert (eql 0.0d0 (funcall f 123.0 0.0d0)))))
 270
 271 ;; Bug reported by Eric Marsden on July 15 2009. The compiler
 272 ;; used not to constant fold calls with arguments of type
 273 ;; (EQL foo).
 274 (with-test (:name :eql-type-constant-fold)
 275   (assert (equal '(FUNCTION (T) (VALUES (MEMBER T) &OPTIONAL))
 276                  (sb-kernel:%simple-fun-type
 277                   (compile nil `(lambda (x)
 278                                   (eql #c(1.0 2.0)
 279                                        (the (eql #c(1.0 2.0))
 280                                          x))))))))
 281
 282 ;; Leakage from the host could result in wrong values for truncation.
 283 (with-test (:name :truncate)
 284   (assert (plusp (sb-kernel:%unary-truncate/single-float (expt 2f0 33))))
 285   (assert (plusp (sb-kernel:%unary-truncate/double-float (expt 2d0 33))))
 286   ;; That'd be one strange host, but just in case
 287   (assert (plusp (sb-kernel:%unary-truncate/single-float (expt 2f0 65))))
 288   (assert (plusp (sb-kernel:%unary-truncate/double-float (expt 2d0 65)))))
 289
 290 ;; On x86-64, we sometimes forgot to clear the higher order bits of the
 291 ;; destination register before using it with an instruction that doesn't
 292 ;; clear the (unused) high order bits. Suspect instructions are operations
 293 ;; with only one operand: for everything else, the destination has already
 294 ;; been loaded with a value, making it safe (by induction).
 295 ;;
 296 ;; The tests are extremely brittle and could be broken by any number of
 297 ;; back- or front-end optimisations. We should just keep the issue above
 298 ;; in mind at all times when working with SSE or similar instruction sets.
 299 ;;
 300 ;; Run only on x86/x86-64m as no other platforms have SB-VM::TOUCH-OBJECT.
 301 #-interpreter
 302 (macrolet ((with-pinned-floats ((count type &rest names) &body body)
 303              "Force COUNT float values to be kept live (and hopefully in registers),
 304               fill a temporary register with noise, and execute BODY."
 305              ;; KLUDGE: SB-VM is locked, and non-x86oids don't have
 306              ;; SB-VM::TOUCH-OBJECT.  Don't even READ this body on
 307              ;; other platforms.
 308              #-(or x86 x86-64)
 309              (declare (ignore count type names body))
 310              #+(or x86 x86-64)
 311              (let ((dummy (loop repeat count
 312                                 collect (or (pop names)
 313                                             (gensym "TEMP")))))
 314                `(let ,(loop for i downfrom -1
 315                             for var in dummy
 316                             for j = (coerce i type)
 317                             collect
 318                             `(,var ,(complex j j))) ; we don't actually need that, but
 319                   (declare (type (complex ,type) ,@dummy)) ; future-proofing can't hurt
 320                   ,@(loop for var in dummy
 321                           for i upfrom 0
 322                           collect `(setf ,var ,(complex i (coerce i type))))
 323                   (multiple-value-prog1
 324                       (progn
 325                         (let ((x ,(complex 1d0 1d0)))
 326                           (declare (type (complex double-float) x))
 327                           (setf x ,(complex most-positive-fixnum (float most-positive-fixnum 1d0)))
 328                           (sb-vm::touch-object x))
 329                         (locally ,@body))
 330                     ,@(loop for var in dummy
 331                             collect `(sb-vm::touch-object ,var)))))))
 332   (with-test (:name :clear-sqrtsd :skipped-on (not (or :x86 :x86-64)))
 333     (flet ((test-sqrtsd (float)
 334              (declare (optimize speed (safety 1))
 335                       (type (double-float (0d0)) float))
 336              (with-pinned-floats (14 double-float x0)
 337                (let ((x (sqrt float)))
 338                  (values (+ x x0) float)))))
 339       (declare (notinline test-sqrtsd))
 340       (assert (zerop (imagpart (test-sqrtsd 4d0))))))
 341
 342   (with-test (:name :clear-sqrtsd-single :skipped-on (not (or :x86 :x86-64)))
 343     (flet ((test-sqrtsd-float (float)
 344              (declare (optimize speed (safety 1))
 345                       (type (single-float (0f0)) float))
 346              (with-pinned-floats (14 single-float x0)
 347                (let ((x (sqrt float)))
 348                  (values (+ x x0) float)))))
 349       (declare (notinline test-sqrtsd-float))
 350       (assert (zerop (imagpart (test-sqrtsd-float 4f0))))))
 351
 352   (with-test (:name :clear-cvtss2sd :skipped-on (not (or :x86 :x86-64)))
 353     (flet ((test-cvtss2sd (float)
 354              (declare (optimize speed (safety 1))
 355                       (type single-float float))
 356              (with-pinned-floats (14 double-float x0)
 357                (let ((x (float float 0d0)))
 358                  (values (+ x x0) (+ 1e0 float))))))
 359       (declare (notinline test-cvtss2sd))
 360       (assert (zerop (imagpart (test-cvtss2sd 1f0))))))
 361
 362   (with-test (:name :clear-cvtsd2ss :skipped-on (not (or :x86 :x86-64)))
 363     (flet ((test-cvtsd2ss (float)
 364              (declare (optimize speed (safety 1))
 365                       (type double-float float))
 366              (with-pinned-floats (14 single-float x0)
 367                (let ((x (float float 1e0)))
 368                  (values (+ x x0) (+ 1d0 float))))))
 369       (declare (notinline test-cvtsd2ss))
 370       (assert (zerop (imagpart (test-cvtsd2ss 4d0))))))
 371
 372   (with-test (:name :clear-cvtsi2sd :skipped-on (not (or :x86 :x86-64)))
 373     (flet ((test-cvtsi2sd (int)
 374              (declare (optimize speed (safety 0))
 375                       (type (unsigned-byte 10) int))
 376              (with-pinned-floats (15 double-float x0)
 377                (+ (float int 0d0) x0))))
 378       (declare (notinline test-cvtsi2sd))
 379       (assert (zerop (imagpart (test-cvtsi2sd 4))))))
 380
 381   (with-test (:name :clear-cvtsi2ss :skipped-on (not (or :x86 :x86-64)))
 382     (flet ((test-cvtsi2ss (int)
 383              (declare (optimize speed (safety 0))
 384                       (type (unsigned-byte 10) int))
 385              (with-pinned-floats (15 single-float x0)
 386                (+ (float int 0e0) x0))))
 387       (declare (notinline test-cvtsi2ss))
 388       (assert (zerop (imagpart (test-cvtsi2ss 4)))))))
 389
 390 (with-test (:name :round-to-bignum)
 391   (assert (= (round 1073741822.3d0) 1073741822))
 392   (assert (= (round 1073741822.5d0) 1073741822))
 393   (assert (= (round 1073741822.7d0) 1073741823))
 394   (assert (= (round 1073741823.3d0) 1073741823))
 395   (assert (= (round 1073741823.5d0) 1073741824))
 396   (assert (= (round 1073741823.7d0) 1073741824)))
 397
 398 (with-test (:name :round-single-to-bignum)
 399   (assert (= (round 1e14) 100000000376832))
 400   (assert (= (round 1e19) 9999999980506447872)))
 401
 402 (with-test (:name :scaled-%hypot)
 403   (assert (<= (abs (complex most-positive-double-float 1d0))
 404               (1+ most-positive-double-float))))
 405
 406 ;; On x86-64, MAKE-SINGLE-FLOAT with a negative argument used to set
 407 ;; bits 32-63 of the XMM register to 1, breaking the invariant that
 408 ;; unused parts of XMM registers are always zero. This could become
 409 ;; visible as a QNaN in the imaginary part when next using the register
 410 ;; in a (COMPLEX SINGLE-FLOAT) operation.
 411 (with-test (:name :make-single-float-clear-imagpart)
 412   (let ((f (checked-compile
 413             '(lambda (x)
 414               (declare (optimize speed))
 415               (= #c(1.0f0 2.0f0)
 416                (+ #c(3.0f0 2.0f0)
 417                 (sb-kernel:make-single-float x))))))
 418         (bits (sb-kernel:single-float-bits -2.0f0)))
 419     (assert (< bits 0))         ; Make sure the test is fit for purpose.
 420     (assert (funcall f bits))))
 421
 422 (with-test (:name :negative-zero-derivation)
 423   (assert (not
 424            (funcall (checked-compile
 425                      '(lambda (exponent)
 426                        (declare ((integer 0 1) exponent))
 427                        (eql 0d0 (scale-float -0.0d0 exponent))))
 428                     0))))
 429
 430 (with-test (:name :complex-eql-all-constants)
 431   (assert (funcall (checked-compile
 432                     '(lambda ()
 433                       (declare (optimize (debug 2)))
 434                       (typep #c(1.0 1.0) '(member #c(1.0 1.0))))))))
 435
 436 (with-test (:name (truncate float :no-consing)
 437                   :skipped-on :interpreter)
 438   (let ((f (checked-compile
 439             '(lambda (x)
 440               (values (truncate (the double-float x)))))))
 441     (ctu:assert-no-consing (funcall f 1d0))
 442     (ctu:assert-no-consing (funcall f (float most-negative-fixnum 1d0))))
 443   (let ((f (checked-compile
 444             '(lambda (x)
 445               (values (truncate (the single-float x)))))))
 446     (ctu:assert-no-consing (funcall f 1f0))
 447     (ctu:assert-no-consing (funcall f (float most-negative-fixnum 1f0)))))