tests/arith-2.pure.lisp

   1 ;;;; arithmetic tests without 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 (defmacro define-compiled-fun (fun name)
  15   `(progn
  16     (declaim (notinline ,name))
  17     (defun ,name (&rest args)
  18      (declare (optimize safety))
  19      (case (length args)
  20        (1 (,fun (car args)))
  21        (2 (,fun (car args) (cadr args)))
  22        (t (apply #',fun args))))))
  23
  24 (define-compiled-fun min compiled-min)
  25 (define-compiled-fun max compiled-max)
  26 (define-compiled-fun + compiled-+)
  27 (define-compiled-fun * compiled-*)
  28 (define-compiled-fun logand compiled-logand)
  29 (define-compiled-fun logior compiled-logior)
  30 (define-compiled-fun logxor compiled-logxor)
  31
  32 (assert (null (ignore-errors (compiled-min '(1 2 3)))))
  33 (assert (= (compiled-min -1) -1))
  34 (assert (null (ignore-errors (compiled-min 1 #(1 2 3)))))
  35 (assert (= (compiled-min 10 11) 10))
  36 (assert (null (ignore-errors (compiled-min (find-package "CL") -5.0))))
  37 (assert (= (compiled-min 5.0 -3) -3))
  38 (assert (null (ignore-errors (compiled-max #c(4 3)))))
  39 (assert (= (compiled-max 0) 0))
  40 (assert (null (ignore-errors (compiled-max "MIX" 3))))
  41 (assert (= (compiled-max -1 10.0) 10.0))
  42 (assert (null (ignore-errors (compiled-max 3 #'max))))
  43 (assert (= (compiled-max -3 0) 0))
  44
  45 (assert (null (ignore-errors (compiled-+ "foo"))))
  46 (assert (= (compiled-+ 3f0) 3f0))
  47 (assert (null (ignore-errors (compiled-+ 1 #p"tmp"))))
  48 (assert (= (compiled-+ 1 2) 3))
  49 (assert (null (ignore-errors (compiled-+ '(1 2 3) 3))))
  50 (assert (= (compiled-+ 3f0 4f0) 7f0))
  51 (assert (null (ignore-errors (compiled-* "foo"))))
  52 (assert (= (compiled-* 3f0) 3f0))
  53 (assert (null (ignore-errors (compiled-* 1 #p"tmp"))))
  54 (assert (= (compiled-* 1 2) 2))
  55 (assert (null (ignore-errors (compiled-* '(1 2 3) 3))))
  56 (assert (= (compiled-* 3f0 4f0) 12f0))
  57
  58 (assert (null (ignore-errors (compiled-logand #(1)))))
  59 (assert (= (compiled-logand 1) 1))
  60 (assert (null (ignore-errors (compiled-logior 3f0))))
  61 (assert (= (compiled-logior 4) 4))
  62 (assert (null (ignore-errors (compiled-logxor #c(2 3)))))
  63 (assert (= (compiled-logxor -6) -6))
  64
  65 (with-test (:name (coerce :overflow))
  66   (checked-compile-and-assert
  67       ()
  68       '(lambda (n) (coerce n 'single-float))
  69     (((expt 10 1000)) (condition 'floating-point-overflow))))
  70 \f
  71 (defun are-we-getting-ash-right (x y)
  72   (declare (optimize speed)
  73            (type (unsigned-byte 32) x)
  74            (type (integer -40 0) y))
  75   (ash x y))
  76 (defun what-about-with-constants (x)
  77   (declare (optimize speed) (type (unsigned-byte 32) x))
  78   (ash x -32))
  79
  80 (dotimes (i 41)
  81   (assert (= (are-we-getting-ash-right (1- (ash 1 32)) (- i))
  82              (if (< i 32)
  83                  (1- (ash 1 (- 32 i)))
  84                  0))))
  85 (assert (= (what-about-with-constants (1- (ash 1 32))) 0))
  86
  87 (defun one-more-test-case-to-catch-sparc (x y)
  88   (declare (optimize speed (safety 0))
  89            (type (unsigned-byte 32) x) (type (integer -40 2) y))
  90   (the (unsigned-byte 32) (ash x y)))
  91 (assert (= (one-more-test-case-to-catch-sparc (1- (ash 1 32)) -40) 0))
  92
  93
  94 (eval-when (:compile-toplevel :load-toplevel :execute)
  95   (defvar *n-fixnum-bits* (- sb-vm:n-word-bits sb-vm::n-fixnum-tag-bits))
  96   (defvar *shifts* (let ((list (list 0
  97                                      1
  98                                      (1- sb-vm:n-word-bits)
  99                                      sb-vm:n-word-bits
 100                                      (1+ sb-vm:n-word-bits))))
 101                      (append list (mapcar #'- list)))))
 102
 103 (macrolet ((nc-list ()
 104              `(list ,@(loop for i from 0 below (length *shifts*)
 105                          collect `(frob (nth ,i *shifts*)))))
 106            (c-list ()
 107              `(list ,@(loop for i from 0 below (length *shifts*)
 108                          collect `(frob ,(nth i *shifts*))))))
 109   (defun nc-ash (x)
 110     (macrolet ((frob (y)
 111                  `(list x ,y (ash x ,y))))
 112       (nc-list)))
 113   (defun c-ash (x)
 114     (macrolet ((frob (y)
 115                  `(list x ,y (ash x ,y))))
 116       (c-list)))
 117   (defun nc-modular-ash-ub (x)
 118     (macrolet ((frob (y)
 119                  `(list x ,y (logand most-positive-fixnum (ash x ,y)))))
 120       (nc-list)))
 121   (defun c-modular-ash-ub (x)
 122     (declare (type (and fixnum unsigned-byte) x)
 123              (optimize speed))
 124     (macrolet ((frob (y)
 125                  `(list x ,y (logand most-positive-fixnum (ash x ,y)))))
 126       (c-list))))
 127
 128 (let* ((values (list 0 1 most-positive-fixnum))
 129        (neg-values (cons most-negative-fixnum
 130                          (mapcar #'- values))))
 131   (labels ((test (value fun1 fun2)
 132              (let ((res1 (funcall fun1 value))
 133                    (res2 (funcall fun2 value)))
 134                (mapcar (lambda (a b)
 135                          (unless (equalp a b)
 136                            (error "ash failure for ~A vs ~A: ~A not EQUALP ~A"
 137                                   fun1 fun2
 138                                   a b)))
 139                        res1 res2))))
 140     (loop for x in values do
 141          (test x 'nc-ash 'c-ash)
 142          (test x 'nc-modular-ash-ub 'c-modular-ash-ub))
 143     (loop for x in neg-values do
 144          (test x 'nc-ash 'c-ash))))
 145
 146 \f
 147 (declaim (inline ppc-ldb-2))
 148
 149 (defun ppc-ldb-2 (fun value)
 150   (declare (type (signed-byte 32) value)
 151            (optimize (speed 3) (safety 0) (space 1) (debug 1)
 152                      (compilation-speed 0)))
 153   (funcall fun (ldb (byte 8 24) value))
 154   (funcall fun (ldb (byte 8 16) value))
 155   (funcall fun (ldb (byte 8 8) value))
 156   (funcall fun (ldb (byte 8 0) value))
 157   (values))
 158
 159 (defun ppc-ldb-1 (fun)
 160   (declare (optimize (speed 3) (safety 0) (space 1) (debug 1)
 161                      (compilation-speed 0)))
 162   (loop
 163      for param :across (make-array 1 :initial-element nil)
 164      for size :across (make-array 1 :element-type 'fixnum :initial-element 3)
 165      do (ppc-ldb-2 fun (if param size -1))))
 166
 167 (with-test (:name :ppc-ldb)
 168  (let ((acc '()))
 169    (ppc-ldb-1 (lambda (x)
 170                 (push x acc)))
 171    (assert (equal acc '(#xff #xff #xff #xff)))))
 172
 173 (with-test (:name :ldb-word-cast)
 174   (checked-compile-and-assert
 175       ()
 176       `(lambda (x y)
 177          (truly-the fixnum (ldb (byte x y) 100)))
 178     ((100 0) 100)))
 179
 180 (with-test (:name :logbitp-negative-error)
 181   (checked-compile-and-assert
 182       (:optimize :safe)
 183       `(lambda (x y)
 184          (logbitp x y))
 185     ((-1 0) (condition 'type-error))
 186     ((-2 (1+ most-positive-fixnum)) (condition 'type-error))
 187     (((1- most-negative-fixnum) 1) (condition 'type-error))))
 188
 189 (with-test (:name :*-overflow-ratio)
 190   (checked-compile-and-assert
 191       (:optimize :safe)
 192       `(lambda (a)
 193          (the fixnum (* 8 a)))
 194     ((1/8) 1)))
 195
 196 #+64-bit
 197 (with-test (:name :bignum-float)
 198   (checked-compile-and-assert
 199       ()
 200       `(lambda (d)
 201          (sb-sys:without-gcing
 202            (let ((res (sb-bignum:%allocate-bignum 2)))
 203              (setf (sb-bignum:%bignum-ref res 1) 529
 204                    (sb-bignum:%bignum-ref res 0) 9223372036854775807)
 205              (sb-bignum:%bignum-set-length res 1)
 206              (unwind-protect
 207                   (< res d)
 208                (sb-bignum:%bignum-set-length res 2)))))
 209     ((-9.223372036854776d18) nil)
 210     ((9.223372036854776d18) t)))
 211
 212 (with-test (:name :overflow-transform-nil)
 213   (checked-compile-and-assert
 214       (:allow-warnings t)
 215       `(lambda (v)
 216          (let ((i 0))
 217            (flet ((f (i)
 218                     (the fixnum i)
 219                     (svref v (+ i 26387449082611642302))))
 220              (f i)
 221              (incf i)
 222              (f i)
 223              (incf i)))))
 224   (checked-compile-and-assert
 225       (:allow-style-warnings t)
 226       `(lambda (s e)
 227          (subseq s 0 (when e
 228                        (- (length s) 12129535698721845515))))))
 229
 230 (with-test (:name :integer-length-union-derivation)
 231   (checked-compile-and-assert
 232       ()
 233       `(lambda (b)
 234          (integer-length
 235           (if (>= b 0)
 236               b
 237               -2)))
 238     ((-1) 1)
 239     ((0) 0)
 240     ((15) 4)))
 241
 242 (with-test (:name :isqrt-union)
 243   (assert-type
 244    (lambda (x)
 245      (declare ((or (integer 1 5) (integer 9 10)) x))
 246      (isqrt x))
 247    (integer 1 3)))
 248
 249 (with-test (:name :integer-length-union)
 250   (assert-type
 251    (lambda (x)
 252      (declare ((or (integer 1 5) (integer 9 10)) x))
 253      (integer-length x))
 254    (integer 1 4)))
 255
 256 (with-test (:name :rem-transform-erase-types)
 257   (checked-compile-and-assert
 258    ()
 259    `(lambda (a)
 260       (declare ((integer * 0) a))
 261       (zerop (rem a 2)))
 262    ((-1) nil)
 263    ((-2) t))
 264   (checked-compile-and-assert
 265    ()
 266    `(lambda (a)
 267       (declare ((member 7 -9) a))
 268       (zerop (rem a 8)))
 269    ((7) nil)
 270    ((-9) nil)))
 271
 272 (with-test (:name :unexpected-immediates-in-vops)
 273   (checked-compile
 274    `(lambda (n)
 275       (declare (fixnum n))
 276       (loop for i below 2
 277             do (print (logbitp i n))
 278                (the (satisfies minusp) i))))
 279   (checked-compile
 280    `(lambda ()
 281       (loop for i below 2
 282             do (print (lognot i))
 283                (the (satisfies minusp) i))))
 284   (checked-compile
 285    `(lambda ()
 286       (loop for i below 2
 287             do (print (- i))
 288                (the (satisfies minusp) i))))
 289   (checked-compile
 290    `(lambda ()
 291       (loop for i below 2
 292             do (print (* i 3))
 293                (the (satisfies minusp) i))))
 294   (checked-compile
 295    `(lambda ()
 296       (loop for i below 2
 297             do (print (* i 3))
 298                (the (satisfies minusp) i))))
 299   (checked-compile
 300    `(lambda ()
 301       (loop for i of-type fixnum below 2
 302             do (print (logand most-positive-word (* i 4)))
 303                (the (satisfies minusp) i)))))
 304
 305 (with-test (:name :/-by-integer-type)
 306   (assert-type
 307    (lambda (x y)
 308      (declare ((integer 1 9) x)
 309               (integer y))
 310      (/ x y))
 311    (or (rational -9 (0)) (rational (0) 9)))
 312   (assert-type
 313    (lambda (x y)
 314      (declare ((integer 1 9) x)
 315               ((integer 0) y))
 316      (/ x y))
 317    (rational (0) 9))
 318   (assert-type
 319    (lambda (x y)
 320      (declare ((rational 0 9) x)
 321               ((integer 0) y))
 322      (/ x y))
 323    (rational 0 9)))
 324
 325 (with-test (:name :truncate-unused-q)
 326   (checked-compile-and-assert
 327    ()
 328    `(lambda (a)
 329       (declare (fixnum a))
 330       (rem a 4))
 331    ((3) 3)
 332    ((-3) -3)
 333    ((4) 0)
 334    ((-4) 0)))
 335
 336 (with-test (:name :*-by-integer-type)
 337   (assert-type
 338    (lambda (x)
 339      (declare (integer x))
 340      (* x 5))
 341    (or (integer 5) (integer * -5) (integer 0 0))))
 342
 343 (with-test (:name :truncate-transform-unused-result)
 344   (assert-type
 345    (lambda (c)
 346      (declare ((integer -1000 0) c)
 347               (optimize speed))
 348      (values
 349       (truncate (truncate (rem c -89) -16) 20)))
 350    (or (integer 0 0))))
 351
 352 (with-test (:name :rem^2)
 353   (checked-compile-and-assert
 354    ()
 355    `(lambda (a)
 356       (declare (fixnum a))
 357       (rem a 2))
 358    ((-2) 0)
 359    ((-3) -1)
 360    ((2) 0)
 361    ((3) 1)))
 362
 363 (with-test (:name :deposit-field-derive-type)
 364   (assert-type
 365    (lambda (s)
 366      (declare ((member 8 10) s))
 367      (deposit-field -21031455 (byte s 9) 1565832649825))
 368    (or (integer 1565832320097 1565832320097) (integer 1565832713313 1565832713313))))
 369
 370 (with-test (:name :logior-negative-bound)
 371   (checked-compile-and-assert
 372    ()
 373    `(lambda (b c)
 374       (declare ((integer 7703 1903468060) c))
 375       (logandc1 (/ (logorc2 c b) -1) c))
 376    ((-1 7703) 7702)))
 377
 378 (with-test (:name :set-numeric-contagion)
 379   (assert-type
 380    (lambda (n)
 381      (loop for i below n
 382            sum (coerce n 'single-float)))
 383    (or (integer 0 0) single-float)))
 384
 385 (with-test (:name :overflow-transform-order)
 386   (checked-compile-and-assert
 387       (:optimize :safe)
 388       `(lambda (a m)
 389          (declare (fixnum a))
 390          (let ((j (* 44 a)))
 391            (when m
 392              (the fixnum j))))
 393     ((most-positive-fixnum nil) nil)
 394     ((most-positive-fixnum t) (condition 'type-error))))
 395
 396 (with-test (:name :logtest-memref-boxed)
 397   (checked-compile-and-assert
 398       ()
 399       `(lambda (b)
 400          (declare (sb-vm:word b))
 401          (when (oddp b)
 402            (lambda (m)
 403              (when m
 404                (setf b 1))
 405              b)))
 406     (((expt 2 (1- sb-vm:n-word-bits))) nil)
 407     (((1+ (expt 2 (1- sb-vm:n-word-bits)))) t :test (lambda (x y)
 408                                                       y
 409                                                       (functionp (car x))))))
 410
 411 (with-test (:name :range-unsigned)
 412   (assert-type
 413    (lambda (d)
 414      (declare (type (integer 1 109) d))
 415      (typep (- d) '(integer -47727025476642942 -2593702250735)))
 416    null))
 417
 418 (with-test (:name :signed-byte-8-p-unsigned)
 419   (checked-compile
 420    `(lambda (a)
 421       (declare (type (simple-array sb-vm:word (*)) a)
 422                (optimize speed))
 423       (the (signed-byte 8) (aref a 0)))
 424    :allow-notes nil))
 425
 426 (with-test (:name :or-chain)
 427   (checked-compile-and-assert
 428    ()
 429    `(lambda (b)
 430       (declare (fixnum b))
 431       (case b ((0 -3) 1) (t 2)))
 432    ((0) 1)
 433    ((-3) 1)
 434    ((3) 2)
 435    ((1) 2)))
 436
 437 (with-test (:name :or-chain-types)
 438   (checked-compile-and-assert
 439    ()
 440    `(lambda (b)
 441       (declare ((integer -1 1) b))
 442       (case b
 443         ((-1 0) 0)
 444         (t 1)))
 445    ((-1) 0)
 446    ((0) 0)
 447    ((1) 1)))
 448
 449 (with-test (:name :or-chain-tagging)
 450   (checked-compile-and-assert
 451    ()
 452    `(lambda (x)
 453       (or (eq x -6)
 454           (eq x -2)))
 455    ((-6) t)
 456    ((-2) t)
 457    ((6) nil)
 458    ((2) nil)
 459    ((-12) nil)
 460    ((-4) nil))
 461   (checked-compile-and-assert
 462    ()
 463    `(lambda (x)
 464       (or (eq x 0)
 465           (eq x -4)))
 466    ((0) t)
 467    ((-4) t)
 468    ((4) nil)
 469    ((-8) nil))
 470   (checked-compile-and-assert
 471    ()
 472    `(lambda (x)
 473       (or (eq x 97)
 474           (eq x 65)))
 475    ((-4611686018427387807) nil)
 476    ((97) t)
 477    ((65) t))
 478   (checked-compile-and-assert
 479    ()
 480    `(lambda (x)
 481       (or (eq x -65)
 482           (eq x -97)))
 483    ((-97) t)
 484    ((-65) t))
 485   (checked-compile-and-assert
 486    ()
 487    `(lambda (x)
 488       (case x ((-3 -2 17) t)))
 489    ((4611686018427387902) nil)
 490    ((-3) t)
 491    ((-2) t)
 492    ((17) t)))
 493
 494 (with-test (:name :range<=-same)
 495   (checked-compile-and-assert
 496    ()
 497    `(lambda (a c)
 498       (declare (type fixnum a))
 499       (let ((v7 (if c
 500                     4611686018427387904
 501                     -6)))
 502         (if (> v7 a)
 503             a
 504             (if (<= a v7)
 505                 0
 506                 a))))
 507     ((-7 nil) -7)
 508     ((-7 t) -7)
 509     ((-6 nil) 0)
 510     ((-6 t) -6)
 511     ((-3 nil) -3)))
 512
 513 (with-test (:name :/-folding)
 514   (checked-compile-and-assert
 515       (:optimize :safe)
 516       `(lambda (a)
 517          (declare (bit a))
 518          (/ 1 a))
 519     ((1) 1)
 520     ((0) (condition 'division-by-zero)))
 521   (checked-compile-and-assert
 522       (:optimize :safe)
 523       `(lambda (a)
 524          (declare (bit a))
 525          (= (/ 5 a) 5))
 526     ((1) t)
 527     ((0) (condition 'division-by-zero))))
 528
 529 (with-test (:name :dpb-size-overflow)
 530   (checked-compile-and-assert
 531    ()
 532    `(lambda (a)
 533       (declare ((unsigned-byte 8) a))
 534       (dpb a (byte 63 8)
 535            81))
 536    ((90) 23121)))
 537
 538 (with-test (:name :mask-field-size-overflow)
 539   (checked-compile-and-assert
 540    ()
 541    `(lambda (a)
 542       (truly-the fixnum
 543                  (mask-field (byte 78 0) a)))
 544    ((35) 35)))