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 '(and :darwin :ppc)) ;; bug 372
 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 (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 :ppc :openbsd)
 159                            (and :ppc :darwin)
 160                            (and :x86 :netbsd)))
 161   (assert-error
 162    (sb-sys:without-interrupts
 163      (sb-int:set-floating-point-modes :current-exceptions nil
 164                                       :accrued-exceptions nil)
 165      (loop repeat 2 summing most-positive-double-float)
 166      (sleep 2))
 167    floating-point-overflow))
 168
 169 ;;; On x86-64 generating complex floats on the stack failed an aver in
 170 ;;; the compiler if the stack slot was the same as the one containing
 171 ;;; the real part of the complex. The following expression was able to
 172 ;;; trigger this in 0.9.5.62.
 173 (with-test (:name :complex-float-stack)
 174   (dolist (type '((complex double-float)
 175                   (complex single-float)))
 176     (checked-compile `(lambda (x0 x1 x2 x3 x4 x5 x6 x7)
 177                         (declare (type ,type x0 x1 x2 x3 x4 x5 x6 x7))
 178                         (let ((x0 (+ x0 x0))
 179                               (x1 (+ x1 x1))
 180                               (x2 (+ x2 x2))
 181                               (x3 (+ x3 x3))
 182                               (x4 (+ x4 x4))
 183                               (x5 (+ x5 x5))
 184                               (x6 (+ x6 x6))
 185                               (x7 (+ x7 x7)))
 186                           (* (+ x0 x1 x2 x3) (+ x4 x5 x6 x7)
 187                              (+ x0 x2 x4 x6) (+ x1 x3 x5 x7)
 188                              (+ x0 x3 x4 x7) (+ x1 x2 x5 x6)
 189                              (+ x0 x1 x6 x7) (+ x2 x3 x4 x5)))))))
 190
 191 (with-test (:name (:nan :comparison)
 192             :fails-on '(or :sparc))
 193   (sb-int:with-float-traps-masked (:invalid)
 194     (macrolet ((test (form)
 195                  (let ((nform (subst '(/ 0.0 0.0) 'nan form)))
 196                    `(progn
 197                       (assert (eval ',nform))
 198                       (assert (eval `(let ((nan (/ 0.0 0.0)))
 199                                        ,',form)))
 200                       (assert (funcall
 201                                (checked-compile `(lambda () ,',nform))))
 202                       (assert (funcall
 203                                (checked-compile `(lambda (nan) ,',form))
 204                                (locally
 205                                    (declare (muffle-conditions style-warning))
 206                                  (/ 0.0 0.0))))))))
 207       (test (/= nan nan))
 208       (test (/= nan nan nan))
 209       (test (/= 1.0 nan 2.0 nan))
 210       (test (/= nan 1.0 2.0 nan))
 211       (test (not (= nan 1.0)))
 212       (test (not (= nan nan)))
 213       (test (not (= nan nan nan)))
 214       (test (not (= 1.0 nan)))
 215       (test (not (= nan 1.0)))
 216       (test (not (= 1.0 1.0 nan)))
 217       (test (not (= 1.0 nan 1.0)))
 218       (test (not (= nan 1.0 1.0)))
 219       (test (not (>= nan nan)))
 220       (test (not (>= nan 1.0)))
 221       (test (not (>= 1.0 nan)))
 222       (test (not (>= 1.0 nan 0.0)))
 223       (test (not (>= 1.0 0.0 nan)))
 224       (test (not (>= nan 1.0 0.0)))
 225       (test (not (<= nan nan)))
 226       (test (not (<= nan 1.0)))
 227       (test (not (<= 1.0 nan)))
 228       (test (not (<= 1.0 nan 2.0)))
 229       (test (not (<= 1.0 2.0 nan)))
 230       (test (not (<= nan 1.0 2.0)))
 231       (test (not (< nan nan)))
 232       (test (not (< -1.0 nan)))
 233       (test (not (< nan 1.0)))
 234       (test (not (> nan nan)))
 235       (test (not (> -1.0 nan)))
 236       (test (not (> nan 1.0))))))
 237
 238 (with-test (:name :log-int/double-accuracy)
 239   ;; we used to use single precision for intermediate results
 240   (assert (eql 2567.6046442221327d0
 241                (log (loop for n from 1 to 1000 for f = 1 then (* f n)
 242                           finally (return f))
 243                     10d0)))
 244   ;; both ways
 245   (assert (eql (log 123123123.0d0 10) (log 123123123 10.0d0))))
 246
 247 (with-test (:name :log-base-zero-return-type)
 248   (assert (eql 0.0f0 (log 123 (eval 0))))
 249   (assert (eql 0.0d0 (log 123.0d0 (eval 0))))
 250   (assert (eql 0.0d0 (log 123 (eval 0.0d0))))
 251   (let ((f (checked-compile '(lambda (x y)
 252                               (declare (optimize speed))
 253                               (etypecase x
 254                                 (single-float
 255                                  (etypecase y
 256                                    (single-float (log x y))
 257                                    (double-float (log x y))))
 258                                 (double-float
 259                                  (etypecase y
 260                                    (single-float (log x y))
 261                                    (double-float (log x y)))))))))
 262     (assert (eql 0.0f0 (funcall f 123.0 0.0)))
 263     (assert (eql 0.0d0 (funcall f 123.0d0 0.0)))
 264     (assert (eql 0.0d0 (funcall f 123.0d0 0.0d0)))
 265     (assert (eql 0.0d0 (funcall f 123.0 0.0d0)))))
 266
 267 ;; Bug reported by Eric Marsden on July 15 2009. The compiler
 268 ;; used not to constant fold calls with arguments of type
 269 ;; (EQL foo).
 270 (with-test (:name :eql-type-constant-fold)
 271   (assert (equal '(FUNCTION (T) (VALUES (MEMBER T) &OPTIONAL))
 272                  (sb-kernel:%simple-fun-type
 273                   (compile nil `(lambda (x)
 274                                   (eql #c(1.0 2.0)
 275                                        (the (eql #c(1.0 2.0))
 276                                          x))))))))
 277
 278 ;; Leakage from the host could result in wrong values for truncation.
 279 (with-test (:name :truncate)
 280   (assert (plusp (sb-kernel:%unary-truncate/single-float (expt 2f0 33))))
 281   (assert (plusp (sb-kernel:%unary-truncate/double-float (expt 2d0 33))))
 282   ;; That'd be one strange host, but just in case
 283   (assert (plusp (sb-kernel:%unary-truncate/single-float (expt 2f0 65))))
 284   (assert (plusp (sb-kernel:%unary-truncate/double-float (expt 2d0 65)))))
 285
 286 ;; On x86-64, we sometimes forgot to clear the higher order bits of the
 287 ;; destination register before using it with an instruction that doesn't
 288 ;; clear the (unused) high order bits. Suspect instructions are operations
 289 ;; with only one operand: for everything else, the destination has already
 290 ;; been loaded with a value, making it safe (by induction).
 291 ;;
 292 ;; The tests are extremely brittle and could be broken by any number of
 293 ;; back- or front-end optimisations. We should just keep the issue above
 294 ;; in mind at all times when working with SSE or similar instruction sets.
 295 ;;
 296 ;; Run only on x86/x86-64m as no other platforms have SB-VM::TOUCH-OBJECT.
 297 #-interpreter
 298 (macrolet ((with-pinned-floats ((count type &rest names) &body body)
 299              "Force COUNT float values to be kept live (and hopefully in registers),
 300               fill a temporary register with noise, and execute BODY."
 301              ;; KLUDGE: SB-VM is locked, and non-x86oids don't have
 302              ;; SB-VM::TOUCH-OBJECT.  Don't even READ this body on
 303              ;; other platforms.
 304              #-(or x86 x86-64)
 305              (declare (ignore count type names body))
 306              #+(or x86 x86-64)
 307              (let ((dummy (loop repeat count
 308                                 collect (or (pop names)
 309                                             (gensym "TEMP")))))
 310                `(let ,(loop for i downfrom -1
 311                             for var in dummy
 312                             for j = (coerce i type)
 313                             collect
 314                             `(,var ,(complex j j))) ; we don't actually need that, but
 315                   (declare (type (complex ,type) ,@dummy)) ; future-proofing can't hurt
 316                   ,@(loop for var in dummy
 317                           for i upfrom 0
 318                           collect `(setf ,var ,(complex i (coerce i type))))
 319                   (multiple-value-prog1
 320                       (progn
 321                         (let ((x ,(complex 1d0 1d0)))
 322                           (declare (type (complex double-float) x))
 323                           (setf x ,(complex most-positive-fixnum (float most-positive-fixnum 1d0)))
 324                           (sb-vm::touch-object x))
 325                         (locally ,@body))
 326                     ,@(loop for var in dummy
 327                             collect `(sb-vm::touch-object ,var)))))))
 328   (with-test (:name :clear-sqrtsd :skipped-on '(not (or :x86 :x86-64)))
 329     (flet ((test-sqrtsd (float)
 330              (declare (optimize speed (safety 1))
 331                       (type (double-float (0d0)) float))
 332              (with-pinned-floats (14 double-float x0)
 333                (let ((x (sqrt float)))
 334                  (values (+ x x0) float)))))
 335       (declare (notinline test-sqrtsd))
 336       (assert (zerop (imagpart (test-sqrtsd 4d0))))))
 337
 338   (with-test (:name :clear-sqrtsd-single :skipped-on '(not (or :x86 :x86-64)))
 339     (flet ((test-sqrtsd-float (float)
 340              (declare (optimize speed (safety 1))
 341                       (type (single-float (0f0)) float))
 342              (with-pinned-floats (14 single-float x0)
 343                (let ((x (sqrt float)))
 344                  (values (+ x x0) float)))))
 345       (declare (notinline test-sqrtsd-float))
 346       (assert (zerop (imagpart (test-sqrtsd-float 4f0))))))
 347
 348   (with-test (:name :clear-cvtss2sd :skipped-on '(not (or :x86 :x86-64)))
 349     (flet ((test-cvtss2sd (float)
 350              (declare (optimize speed (safety 1))
 351                       (type single-float float))
 352              (with-pinned-floats (14 double-float x0)
 353                (let ((x (float float 0d0)))
 354                  (values (+ x x0) (+ 1e0 float))))))
 355       (declare (notinline test-cvtss2sd))
 356       (assert (zerop (imagpart (test-cvtss2sd 1f0))))))
 357
 358   (with-test (:name :clear-cvtsd2ss :skipped-on '(not (or :x86 :x86-64)))
 359     (flet ((test-cvtsd2ss (float)
 360              (declare (optimize speed (safety 1))
 361                       (type double-float float))
 362              (with-pinned-floats (14 single-float x0)
 363                (let ((x (float float 1e0)))
 364                  (values (+ x x0) (+ 1d0 float))))))
 365       (declare (notinline test-cvtsd2ss))
 366       (assert (zerop (imagpart (test-cvtsd2ss 4d0))))))
 367
 368   (with-test (:name :clear-cvtsi2sd :skipped-on '(not (or :x86 :x86-64)))
 369     (flet ((test-cvtsi2sd (int)
 370              (declare (optimize speed (safety 0))
 371                       (type (unsigned-byte 10) int))
 372              (with-pinned-floats (15 double-float x0)
 373                (+ (float int 0d0) x0))))
 374       (declare (notinline test-cvtsi2sd))
 375       (assert (zerop (imagpart (test-cvtsi2sd 4))))))
 376
 377   (with-test (:name :clear-cvtsi2ss :skipped-on '(not (or :x86 :x86-64)))
 378     (flet ((test-cvtsi2ss (int)
 379              (declare (optimize speed (safety 0))
 380                       (type (unsigned-byte 10) int))
 381              (with-pinned-floats (15 single-float x0)
 382                (+ (float int 0e0) x0))))
 383       (declare (notinline test-cvtsi2ss))
 384       (assert (zerop (imagpart (test-cvtsi2ss 4)))))))
 385
 386 (with-test (:name :round-to-bignum)
 387   (assert (= (round 1073741822.3d0) 1073741822))
 388   (assert (= (round 1073741822.5d0) 1073741822))
 389   (assert (= (round 1073741822.7d0) 1073741823))
 390   (assert (= (round 1073741823.3d0) 1073741823))
 391   (assert (= (round 1073741823.5d0) 1073741824))
 392   (assert (= (round 1073741823.7d0) 1073741824)))
 393
 394 (with-test (:name :round-single-to-bignum)
 395   (assert (= (round 1e14) 100000000376832))
 396   (assert (= (round 1e19) 9999999980506447872)))
 397
 398 (with-test (:name :scaled-%hypot)
 399   (assert (<= (abs (complex most-positive-double-float 1d0))
 400               (1+ most-positive-double-float))))
 401
 402 ;; On x86-64, MAKE-SINGLE-FLOAT with a negative argument used to set
 403 ;; bits 32-63 of the XMM register to 1, breaking the invariant that
 404 ;; unused parts of XMM registers are always zero. This could become
 405 ;; visible as a QNaN in the imaginary part when next using the register
 406 ;; in a (COMPLEX SINGLE-FLOAT) operation.
 407 (with-test (:name :make-single-float-clear-imagpart)
 408   (let ((f (checked-compile
 409             '(lambda (x)
 410               (declare (optimize speed))
 411               (= #c(1.0f0 2.0f0)
 412                (+ #c(3.0f0 2.0f0)
 413                 (sb-kernel:make-single-float x))))))
 414         (bits (sb-kernel:single-float-bits -2.0f0)))
 415     (assert (< bits 0))         ; Make sure the test is fit for purpose.
 416     (assert (funcall f bits))))
 417
 418 (with-test (:name :negative-zero-derivation)
 419   (assert (not
 420            (funcall (checked-compile
 421                      '(lambda (exponent)
 422                        (declare ((integer 0 1) exponent))
 423                        (eql 0d0 (scale-float -0.0d0 exponent))))
 424                     0))))