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