tests/arith.pure.lisp

   1 ;;;; arithmetic 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 ;;; Once upon a time, in the process of porting CMUCL's SPARC backend
  17 ;;; to SBCL, multiplications were excitingly broken.  While it's
  18 ;;; unlikely that anything with such fundamental arithmetic errors as
  19 ;;; these are going to get this far, it's probably worth checking.
  20 (macrolet ((test (op res1 res2)
  21              `(progn
  22                (assert (= (,op 4 2) ,res1))
  23                (assert (= (,op 2 4) ,res2))
  24                (assert (= (funcall (compile nil '(lambda (x y) (,op x y))) 4 2)
  25                         ,res1))
  26                (assert (= (funcall (compile nil '(lambda (x y) (,op x y))) 2 4)
  27                         ,res2)))))
  28   (test + 6 6)
  29   (test - 2 -2)
  30   (test * 8 8)
  31   (test / 2 1/2)
  32   (test expt 16 16))
  33
  34 ;;; In a bug reported by Wolfhard Buss on cmucl-imp 2002-06-18 (BUG
  35 ;;; 184), sbcl didn't catch all divisions by zero, notably divisions
  36 ;;; of bignums and ratios by 0.  Fixed in sbcl-0.7.6.13.
  37 (assert (raises-error? (/ 2/3 0) division-by-zero))
  38 (assert (raises-error? (/ (1+ most-positive-fixnum) 0) division-by-zero))
  39
  40 ;;; In a bug reported by Raymond Toy on cmucl-imp 2002-07-18, (COERCE
  41 ;;; <RATIONAL> '(COMPLEX FLOAT)) was failing to return a complex
  42 ;;; float; a patch was given by Wolfhard Buss cmucl-imp 2002-07-19.
  43 (assert (= (coerce 1 '(complex float)) #c(1.0 0.0)))
  44 (assert (= (coerce 1/2 '(complex float)) #c(0.5 0.0)))
  45 (assert (= (coerce 1.0d0 '(complex float)) #c(1.0d0 0.0d0)))
  46
  47 ;;; (COERCE #c(<RATIONAL> <RATIONAL>) '(complex float)) resulted in
  48 ;;; an error up to 0.8.17.31
  49 (assert (= (coerce #c(1 2) '(complex float)) #c(1.0 2.0)))
  50
  51 ;;; COERCE also sometimes failed to verify that a particular coercion
  52 ;;; was possible (in particular coercing rationals to bounded float
  53 ;;; types.
  54 (assert (raises-error? (coerce 1 '(float 2.0 3.0)) type-error))
  55 (assert (raises-error? (coerce 1 '(single-float -1.0 0.0)) type-error))
  56 (assert (eql (coerce 1 '(single-float -1.0 2.0)) 1.0))
  57
  58 ;;; ANSI says MIN and MAX should signal TYPE-ERROR if any argument
  59 ;;; isn't REAL. SBCL 0.7.7 didn't in the 1-arg case. (reported as a
  60 ;;; bug in CMU CL on #lisp IRC by lrasinen 2002-09-01)
  61 (assert (null (ignore-errors (min '(1 2 3)))))
  62 (assert (= (min -1) -1))
  63 (assert (null (ignore-errors (min 1 #(1 2 3)))))
  64 (assert (= (min 10 11) 10))
  65 (assert (null (ignore-errors (min (find-package "CL") -5.0))))
  66 (assert (= (min 5.0 -3) -3))
  67 (assert (null (ignore-errors (max #c(4 3)))))
  68 (assert (= (max 0) 0))
  69 (assert (null (ignore-errors (max "MIX" 3))))
  70 (assert (= (max -1 10.0) 10.0))
  71 (assert (null (ignore-errors (max 3 #'max))))
  72 (assert (= (max -3 0) 0))
  73
  74 ;;; (CEILING x 2^k) was optimized incorrectly
  75 (loop for divisor in '(-4 4)
  76       for ceiler = (compile nil `(lambda (x)
  77                                    (declare (fixnum x))
  78                                    (declare (optimize (speed 3)))
  79                                    (ceiling x ,divisor)))
  80       do (loop for i from -5 to 5
  81                for exact-q = (/ i divisor)
  82                do (multiple-value-bind (q r)
  83                       (funcall ceiler i)
  84                     (assert (= (+ (* q divisor) r) i))
  85                     (assert (<= exact-q q))
  86                     (assert (< q (1+ exact-q))))))
  87
  88 ;;; (TRUNCATE x 2^k) was optimized incorrectly
  89 (loop for divisor in '(-4 4)
  90       for truncater = (compile nil `(lambda (x)
  91                                       (declare (fixnum x))
  92                                       (declare (optimize (speed 3)))
  93                                       (truncate x ,divisor)))
  94       do (loop for i from -9 to 9
  95                for exact-q = (/ i divisor)
  96                do (multiple-value-bind (q r)
  97                       (funcall truncater i)
  98                     (assert (= (+ (* q divisor) r) i))
  99                     (assert (<= (abs q) (abs exact-q)))
 100                     (assert (< (abs exact-q) (1+ (abs q)))))))
 101
 102 ;;; CEILING had a corner case, spotted by Paul Dietz
 103 (assert (= (ceiling most-negative-fixnum (1+ most-positive-fixnum)) -1))
 104
 105 ;;; give any optimizers of constant multiplication a light testing.
 106 ;;; 100 may seem low, but (a) it caught CSR's initial errors, and (b)
 107 ;;; before checking in, CSR tested with 10000.  So one hundred
 108 ;;; checkins later, we'll have doubled the coverage.
 109 (dotimes (i 100)
 110   (let* ((x (random most-positive-fixnum))
 111          (x2 (* x 2))
 112          (x3 (* x 3)))
 113     (let ((fn (handler-bind ((sb-ext:compiler-note
 114                               (lambda (c)
 115                                 (when (<= x3 most-positive-fixnum)
 116                                   (error c)))))
 117                 (compile nil
 118                          `(lambda (y)
 119                             (declare (optimize speed) (type (integer 0 3) y))
 120                             (* y ,x))))))
 121       (unless (and (= (funcall fn 0) 0)
 122                    (= (funcall fn 1) x)
 123                    (= (funcall fn 2) x2)
 124                    (= (funcall fn 3) x3))
 125         (error "bad results for ~D" x)))))
 126
 127 ;;; Bugs reported by Paul Dietz:
 128
 129 ;;; (GCD 0 x) must return (abs x)
 130 (dolist (x (list -10 (* 3 most-negative-fixnum)))
 131   (assert (= (gcd 0 x) (abs x))))
 132 ;;; LCM returns a non-negative number
 133 (assert (= (lcm 4 -10) 20))
 134 (assert (= (lcm 0 0) 0))
 135
 136 ;;; PPC bignum arithmetic bug:
 137 (multiple-value-bind (quo rem)
 138     (truncate 291351647815394962053040658028983955 10000000000000000000000000)
 139   (assert (= quo 29135164781))
 140   (assert (= rem 5394962053040658028983955)))
 141
 142 ;;; x86 LEA bug:
 143 (assert (= (funcall
 144             (compile nil '(lambda (x) (declare (bit x)) (+ x #xf0000000)))
 145             1)
 146            #xf0000001))
 147
 148 ;;; LOGBITP on bignums:
 149 (dolist (x '(((1+ most-positive-fixnum) 1 nil)
 150              ((1+ most-positive-fixnum) -1 t)
 151              ((1+ most-positive-fixnum) (1+ most-positive-fixnum) nil)
 152              ((1+ most-positive-fixnum) (1- most-negative-fixnum) t)
 153              (1 (ash most-negative-fixnum 1) nil)
 154              (#.(- sb-vm:n-word-bits sb-vm:n-lowtag-bits) most-negative-fixnum t)
 155              (#.(1+ (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t)
 156              (#.(+ 2 (- sb-vm:n-word-bits sb-vm:n-lowtag-bits)) (ash most-negative-fixnum 1) t)
 157              (#.(+ sb-vm:n-word-bits 32) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) nil)
 158              (#.(+ sb-vm:n-word-bits 33) (ash most-negative-fixnum #.(+ 32 sb-vm:n-lowtag-bits 1)) t)))
 159   (destructuring-bind (index int result) x
 160     (assert (eq (eval `(logbitp ,index ,int)) result))))
 161
 162 ;;; off-by-1 type inference error for %DPB and %DEPOSIT-FIELD:
 163 (let ((f (compile nil '(lambda (b)
 164                         (integer-length (dpb b (byte 4 28) -1005))))))
 165   (assert (= (funcall f 1230070) 32)))
 166 (let ((f (compile nil '(lambda (b)
 167                         (integer-length (deposit-field b (byte 4 28) -1005))))))
 168   (assert (= (funcall f 1230070) 32)))
 169
 170 ;;; type inference leading to an internal compiler error:
 171 (let ((f (compile nil '(lambda (x)
 172                         (declare (type fixnum x))
 173                         (ldb (byte 0 0) x)))))
 174   (assert (= (funcall f 1) 0))
 175   (assert (= (funcall f most-positive-fixnum) 0))
 176   (assert (= (funcall f -1) 0)))
 177
 178 ;;; Alpha bignum arithmetic bug:
 179 (assert (= (* 966082078641 419216044685) 404997107848943140073085))
 180
 181 ;;; Alpha smallnum arithmetic bug:
 182 (assert (= (ash -129876 -1026) -1))
 183
 184 ;;; Alpha middlenum (yes, really! Affecting numbers between 2^32 and
 185 ;;; 2^64 :) arithmetic bug
 186 (let ((fn (compile nil '(LAMBDA (A B C D)
 187           (DECLARE (TYPE (INTEGER -1621 -513) A)
 188                    (TYPE (INTEGER -3 34163) B)
 189                    (TYPE (INTEGER -9485132993 81272960) C)
 190                    (TYPE (INTEGER -255340814 519943) D)
 191                    (IGNORABLE A B C D)
 192                    (OPTIMIZE (SPEED 3) (SAFETY 1) (DEBUG 1)))
 193           (TRUNCATE C (MIN -100 4149605))))))
 194   (assert (= (funcall fn -1332 5864 -6963328729 -43789079) 69633287)))
 195
 196 ;;; Here's another fantastic Alpha backend bug: the code to load
 197 ;;; immediate 64-bit constants into a register was wrong.
 198 (let ((fn (compile nil '(LAMBDA (A B C D)
 199           (DECLARE (TYPE (INTEGER -3563 2733564) A)
 200                    (TYPE (INTEGER -548947 7159) B)
 201                    (TYPE (INTEGER -19 0) C)
 202                    (TYPE (INTEGER -2546009 0) D)
 203                    (IGNORABLE A B C D)
 204                    (OPTIMIZE (SPEED 3) (SAFETY 1) (DEBUG 1)))
 205           (CASE A
 206             ((89 125 16) (ASH A (MIN 18 -706)))
 207             (T (DPB -3 (BYTE 30 30) -1)))))))
 208   (assert (= (funcall fn 1227072 -529823 -18 -792831) -2147483649)))
 209
 210 ;;; ASH of a negative bignum by a bignum count would erroneously
 211 ;;; return 0 prior to sbcl-0.8.4.4
 212 (assert (= (ash (1- most-negative-fixnum) (1- most-negative-fixnum)) -1))
 213
 214 ;;; Whoops.  Too much optimization in division operators for 0
 215 ;;; divisor.
 216 (macrolet ((frob (name)
 217              `(let ((fn (compile nil '(lambda (x)
 218                                        (declare (optimize speed) (fixnum x))
 219                                        (,name x 0)))))
 220                (assert (raises-error? (funcall fn 1) division-by-zero)))))
 221   (frob mod)
 222   (frob truncate)
 223   (frob rem)
 224   (frob /)
 225   (frob floor)
 226   (frob ceiling))
 227
 228 ;; Check that the logic in SB-KERNEL::BASIC-COMPARE for doing fixnum/float
 229 ;; comparisons without rationalizing the floats still gives the right anwers
 230 ;; in the edge cases (had a fencepost error).
 231 (macrolet ((test (range type sign)
 232              `(let (ints
 233                     floats
 234                     (start (- ,(find-symbol (format nil
 235                                                     "MOST-~A-EXACTLY-~A-FIXNUM"
 236                                                     sign type)
 237                                             :sb-kernel)
 238                               ,range)))
 239                 (dotimes (i (1+ (* ,range 2)))
 240                   (let* ((x (+ start i))
 241                          (y (coerce x ',type)))
 242                     (push x ints)
 243                     (push y floats)))
 244                 (dolist (i ints)
 245                   (dolist (f floats)
 246                     (dolist (op '(< <= = >= >))
 247                       (unless (eq (funcall op i f)
 248                                   (funcall op i (rationalize f)))
 249                         (error "(not (eq (~a ~a ~f) (~a ~a ~a)))~%"
 250                                op i f
 251                                op i (rationalize f)))
 252                       (unless (eq (funcall op f i)
 253                                   (funcall op (rationalize f) i))
 254                         (error "(not (eq (~a ~f ~a) (~a ~a ~a)))~%"
 255                                op f i
 256                                op (rationalize f) i))))))))
 257   (test 32 double-float negative)
 258   (test 32 double-float positive)
 259   (test 32 single-float negative)
 260   (test 32 single-float positive))
 261
 262 ;; x86-64 sign-extension bug found using pfdietz's random tester.
 263 (assert (= 286142502
 264            (funcall (lambda ()
 265                       (declare (notinline logxor))
 266                       (min (logxor 0 0 0 286142502))))))
 267
 268 ;; Small bugs in LOGCOUNT can still allow SBCL to be built and thus go
 269 ;; unnoticed, so check more thoroughly here.
 270 (with-test (:name :logcount)
 271   (flet ((test (x n)
 272            (unless (= (logcount x) n)
 273              (error "logcount failure for ~a" x))))
 274     ;; Test with some patterns with well known number of ones/zeroes ...
 275     (dotimes (i 128)
 276       (let ((x (ash 1 i)))
 277         (test x 1)
 278         (test (- x) i)
 279         (test (1- x) i)))
 280     ;; ... and with some random integers of varying length.
 281     (flet ((test-logcount (x)
 282              (declare (type integer x))
 283              (do ((result 0 (1+ result))
 284                   (x (if (minusp x)
 285                          (lognot x)
 286                          x)
 287                      (logand x (1- x))))
 288                  ((zerop x) result))))
 289       (dotimes (i 200)
 290         (let ((x (random (ash 1 i))))
 291           (test x (test-logcount x))
 292           (test (- x) (test-logcount (- x))))))))
 293
 294 ;; 1.0 had a broken ATANH on win32
 295 (with-test (:name :atanh)
 296   (assert (= (atanh 0.9d0) 1.4722194895832204d0)))
 297
 298 ;; Test some cases of integer operations with constant arguments
 299 (with-test (:name :constant-integers)
 300   (labels ((test-forms (op x y header &rest forms)
 301              (let ((val (funcall op x y)))
 302                (dolist (form forms)
 303                  (let ((new-val (funcall (compile nil (append header form)) x y)))
 304                    (unless (eql val new-val)
 305                      (error "~S /= ~S: ~S ~S ~S~%" val new-val (append header form) x y))))))
 306            (test-case (op x y type)
 307              (test-forms op x y `(lambda (x y &aux z)
 308                                    (declare (type ,type x y)
 309                                             (ignorable x y z)
 310                                             (notinline identity)
 311                                             (optimize speed (safety 0))))
 312                          `((,op x ,y))
 313                          `((setf z (,op x ,y))
 314                            (identity x)
 315                            z)
 316                          `((values (,op x ,y) x))
 317                          `((,op ,x y))
 318                          `((setf z (,op ,x y))
 319                            (identity y)
 320                            z)
 321                          `((values (,op ,x y) y))
 322
 323                          `((identity x)
 324                            (,op x ,y))
 325                          `((identity x)
 326                            (setf z (,op x ,y))
 327                            (identity x)
 328                            z)
 329                          `((identity x)
 330                            (values (,op x ,y) x))
 331                          `((identity y)
 332                            (,op ,x y))
 333                          `((identity y)
 334                            (setf z (,op ,x y))
 335                            (identity y)
 336                            z)
 337                          `((identity y)
 338                            (values (,op ,x y) y))))
 339            (test-op (op)
 340              (let ((ub `(unsigned-byte ,sb-vm:n-word-bits))
 341                    (sb `(signed-byte ,sb-vm:n-word-bits)))
 342                (loop for (x y type) in `((2 1 fixnum)
 343                                          (2 1 ,ub)
 344                                          (2 1 ,sb)
 345                                          (,(1+ (ash 1 28)) ,(1- (ash 1 28)) fixnum)
 346                                          (,(+ 3 (ash 1 30)) ,(+ 2 (ash 1 30)) ,ub)
 347                                          (,(- -2 (ash 1 29)) ,(- 3 (ash 1 29)) ,sb)
 348                                          ,@(when (> sb-vm:n-word-bits 32)
 349                                              `((,(1+ (ash 1 29)) ,(1- (ash 1 29)) fixnum)
 350                                                (,(1+ (ash 1 31)) ,(1- (ash 1 31)) ,ub)
 351                                                (,(- -2 (ash 1 31)) ,(- 3 (ash 1 30)) ,sb)
 352                                                (,(ash 1 40) ,(ash 1 39) fixnum)
 353                                                (,(ash 1 40) ,(ash 1 39) ,ub)
 354                                                (,(ash 1 40) ,(ash 1 39) ,sb))))
 355                      do
 356                   (test-case op x y type)
 357                   (test-case op x x type)))))
 358     (mapc #'test-op '(+ - * truncate
 359                       < <= = >= >
 360                       eql
 361                       eq))))
 362
 363 ;; GCD used to sometimes return negative values. The following did, on 32 bit
 364 ;; builds.
 365 (with-test (:name :gcd)
 366   (assert (plusp (gcd 20286123923750474264166990598656
 367                       680564733841876926926749214863536422912))))
 368
 369 (with-test (:name :expt-zero-zero)
 370   ;; Check that (expt 0.0 0.0) and (expt 0 0.0) signal error, but (expt 0.0 0)
 371   ;; returns 1.0
 372   (assert (raises-error? (expt 0.0 0.0) sb-int:arguments-out-of-domain-error))
 373   (assert (raises-error? (expt 0 0.0) sb-int:arguments-out-of-domain-error))
 374   (assert (eql (expt 0.0 0) 1.0)))
 375
 376 (with-test (:name :multiple-constant-folding)
 377   (let ((*random-state* (make-random-state t)))
 378     (flet ((make-args ()
 379              (let (args vars)
 380                (loop repeat (1+ (random 12))
 381                      do (if (zerop (random 2))
 382                             (let ((var (gensym)))
 383                               (push var args)
 384                               (push var vars))
 385                             (push (- (random 21) 10) args)))
 386                (values args vars))))
 387       (dolist (op '(+ * logior logxor logand logeqv gcd lcm - /))
 388         (loop repeat 10
 389               do (multiple-value-bind (args vars) (make-args)
 390                    (let ((fast (compile nil `(lambda ,vars
 391                                                (,op ,@args))))
 392                          (slow (compile nil `(lambda ,vars
 393                                                (declare (notinline ,op))
 394                                                (,op ,@args)))))
 395                      (loop repeat 3
 396                            do (let* ((call-args (loop repeat (length vars)
 397                                                       collect (- (random 21) 10)))
 398                                      (fast-result (handler-case
 399                                                       (apply fast call-args)
 400                                                     (division-by-zero () :div0)))
 401                                      (slow-result (handler-case
 402                                                       (apply slow call-args)
 403                                                     (division-by-zero () :div0))))
 404                                 (if (eql fast-result slow-result)
 405                                     (print (list :ok `(,op ,@args) :=> fast-result))
 406                                     (error "oops: ~S, ~S" args call-args)))))))))))