1.0.29.54: Inline unboxed constants on x86[-64]

[sbcl.git] / tests / arith.pure.lisp

diff --git a/tests/arith.pure.lisp b/tests/arith.pure.lisp
index 630c0a8..af1932c 100644 (file)
--- a/tests/arith.pure.lisp
+++ b/tests/arith.pure.lisp
@@ -21,9 +21,9 @@
              `(progn
                (assert (= (,op 4 2) ,res1))
                (assert (= (,op 2 4) ,res2))
-               (assert (= (funcall (compile nil (lambda (x y) (,op x y))) 4 2)
+               (assert (= (funcall (compile nil '(lambda (x y) (,op x y))) 4 2)
                         ,res1))
-               (assert (= (funcall (compile nil (lambda (x y) (,op x y))) 2 4)
+               (assert (= (funcall (compile nil '(lambda (x y) (,op x y))) 2 4)
                         ,res2)))))
   (test + 6 6)
   (test - 2 -2)
@@ -264,3 +264,98 @@
            (funcall (lambda ()
                       (declare (notinline logxor))
                       (min (logxor 0 0 0 286142502))))))
+
+;; Small bugs in LOGCOUNT can still allow SBCL to be built and thus go
+;; unnoticed, so check more thoroughly here.
+(with-test (:name :logcount)
+  (flet ((test (x n)
+           (unless (= (logcount x) n)
+             (error "logcount failure for ~a" x))))
+    ;; Test with some patterns with well known number of ones/zeroes ...
+    (dotimes (i 128)
+      (let ((x (ash 1 i)))
+        (test x 1)
+        (test (- x) i)
+        (test (1- x) i)))
+    ;; ... and with some random integers of varying length.
+    (flet ((test-logcount (x)
+             (declare (type integer x))
+             (do ((result 0 (1+ result))
+                  (x (if (minusp x)
+                         (lognot x)
+                         x)
+                     (logand x (1- x))))
+                 ((zerop x) result))))
+      (dotimes (i 200)
+        (let ((x (random (ash 1 i))))
+          (test x (test-logcount x))
+          (test (- x) (test-logcount (- x))))))))
+
+;; 1.0 had a broken ATANH on win32
+(with-test (:name :atanh)
+  (assert (= (atanh 0.9d0) 1.4722194895832204d0)))
+
+;; Test some cases of integer operations with constant arguments
+(with-test (:name :constant-integers)
+  (labels ((test-forms (op x y header &rest forms)
+             (let ((val (funcall op x y)))
+               (dolist (form forms)
+                 (let ((new-val (funcall (compile nil (append header form)) x y)))
+                   (unless (eql val new-val)
+                     (error "~S /= ~S: ~S ~S ~S~%" val new-val (append header form) x y))))))
+           (test-case (op x y type)
+             (test-forms op x y `(lambda (x y &aux z)
+                                   (declare (type ,type x y)
+                                            (ignorable x y z)
+                                            (notinline identity)
+                                            (optimize speed (safety 0))))
+                         `((,op x ,y))
+                         `((setf z (,op x ,y))
+                           (identity x)
+                           z)
+                         `((values (,op x ,y) x))
+                         `((,op ,x y))
+                         `((setf z (,op ,x y))
+                           (identity y)
+                           z)
+                         `((values (,op ,x y) y))
+
+                         `((identity x)
+                           (,op x ,y))
+                         `((identity x)
+                           (setf z (,op x ,y))
+                           (identity x)
+                           z)
+                         `((identity x)
+                           (values (,op x ,y) x))
+                         `((identity y)
+                           (,op ,x y))
+                         `((identity y)
+                           (setf z (,op ,x y))
+                           (identity y)
+                           z)
+                         `((identity y)
+                           (values (,op ,x y) y))))
+           (test-op (op)
+             (let ((ub `(unsigned-byte ,sb-vm:n-word-bits))
+                   (sb `(signed-byte ,sb-vm:n-word-bits)))
+               (loop for (x y type) in `((2 1 fixnum)
+                                         (2 1 ,ub)
+                                         (2 1 ,sb)
+                                         (,(1+ (ash 1 28)) ,(1- (ash 1 28)) fixnum)
+                                         (,(+ 3 (ash 1 30)) ,(+ 2 (ash 1 30)) ,ub)
+                                         (,(- -2 (ash 1 29)) ,(- 3 (ash 1 29)) ,sb)
+                                         ,@(when (> sb-vm:n-word-bits 32)
+                                             `((,(1+ (ash 1 29)) ,(1- (ash 1 29)) fixnum)
+                                               (,(1+ (ash 1 31)) ,(1- (ash 1 31)) ,ub)
+                                               (,(- -2 (ash 1 31)) ,(- 3 (ash 1 30)) ,sb)
+                                               (,(ash 1 40) ,(ash 1 39) fixnum)
+                                               (,(ash 1 40) ,(ash 1 39) ,ub)
+                                               (,(ash 1 40) ,(ash 1 39) ,sb))))
+                     do
+                  (test-case op x y type)
+                  (test-case op x x type)))))
+    (mapc #'test-op '(+ - * truncate
+                      < <= = >= >
+                      eql
+                      eq))))