Fix (run-program) to cleanup fd handlers
[sbcl.git] / tests / arith.pure.lisp
index aa39251..d58da25 100644 (file)
 ;; 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))))
+
+;; GCD used to sometimes return negative values. The following did, on 32 bit
+;; builds.
+(with-test (:name :gcd)
+  (assert (plusp (gcd 20286123923750474264166990598656
+                      680564733841876926926749214863536422912))))
+
+(with-test (:name :expt-zero-zero)
+  ;; Check that (expt 0.0 0.0) and (expt 0 0.0) signal error, but (expt 0.0 0)
+  ;; returns 1.0
+  (assert (raises-error? (expt 0.0 0.0) sb-int:arguments-out-of-domain-error))
+  (assert (raises-error? (expt 0 0.0) sb-int:arguments-out-of-domain-error))
+  (assert (eql (expt 0.0 0) 1.0)))
+
+(with-test (:name :multiple-constant-folding)
+  (let ((*random-state* (make-random-state t)))
+    (flet ((make-args ()
+             (let (args vars)
+               (loop repeat (1+ (random 12))
+                     do (if (zerop (random 2))
+                            (let ((var (gensym)))
+                              (push var args)
+                              (push var vars))
+                            (push (- (random 21) 10) args)))
+               (values args vars))))
+      (dolist (op '(+ * logior logxor logand logeqv gcd lcm - /))
+        (loop repeat 10
+              do (multiple-value-bind (args vars) (make-args)
+                   (let ((fast (compile nil `(lambda ,vars
+                                               (,op ,@args))))
+                         (slow (compile nil `(lambda ,vars
+                                               (declare (notinline ,op))
+                                               (,op ,@args)))))
+                     (loop repeat 3
+                           do (let* ((call-args (loop repeat (length vars)
+                                                      collect (- (random 21) 10)))
+                                     (fast-result (handler-case
+                                                      (apply fast call-args)
+                                                    (division-by-zero () :div0)))
+                                     (slow-result (handler-case
+                                                      (apply slow call-args)
+                                                    (division-by-zero () :div0))))
+                                (if (eql fast-result slow-result)
+                                    (print (list :ok `(,op ,@args) :=> fast-result))
+                                    (error "oops: ~S, ~S" args call-args)))))))))))
+
+;;; (TRUNCATE <unsigned-word> <constant unsigned-word>) is optimized
+;;; to use multiplication instead of division. This propagates to FLOOR,
+;;; MOD and REM. Test that the transform is indeed triggered and test
+;;; several cases for correct results.
+(with-test (:name (:integer-division-using-multiplication :used)
+                  :skipped-on '(not (or :x86-64 :x86)))
+  (dolist (fun '(truncate floor ceiling mod rem))
+    (let* ((foo (compile nil `(lambda (x)
+                                (declare (optimize (speed 3)
+                                                   (space 1)
+                                                   (compilation-speed 0))
+                                         (type (unsigned-byte
+                                                ,sb-vm:n-word-bits) x))
+                                (,fun x 9))))
+           (disassembly (with-output-to-string (s)
+                          (disassemble foo :stream s))))
+      ;; KLUDGE copied from test :float-division-using-exact-reciprocal
+      ;; in compiler.pure.lisp.
+      (assert (and (not (search "DIV" disassembly))
+                   (search "MUL" disassembly))))))
+
+(with-test (:name (:integer-division-using-multiplication :correctness))
+  (let ((*random-state* (make-random-state t)))
+    (dolist (dividend-type `((unsigned-byte ,sb-vm:n-word-bits)
+                             (and fixnum unsigned-byte)
+                             (integer 10000 10100)))
+      (dolist (divisor `(;; Some special cases from the paper
+                         7 10 14 641 274177
+                         ;; Range extremes
+                         3
+                         ,most-positive-fixnum
+                         ,(1- (expt 2 sb-vm:n-word-bits))
+                         ;; Some random values
+                         ,@(loop for i from 8 to sb-vm:n-word-bits
+                                 for r = (random (expt 2 i))
+                                 ;; We don't want 0, 1 and powers of 2.
+                                 when (not (zerop (logand r (1- r))))
+                                 collect r)))
+        (dolist (fun '(truncate ceiling floor mod rem))
+          (let ((foo (compile nil `(lambda (x)
+                                     (declare (optimize (speed 3)
+                                                        (space 1)
+                                                        (compilation-speed 0))
+                                              (type ,dividend-type x))
+                                     (,fun x ,divisor)))))
+            (dolist (dividend `(0 1 ,most-positive-fixnum
+                                ,(1- divisor) ,divisor
+                                ,(1- (* divisor 2)) ,(* divisor 2)
+                                ,@(loop repeat 4
+                                        collect (+ 10000 (random 101)))
+                                ,@(loop for i from 4 to sb-vm:n-word-bits
+                                        for pow = (expt 2 (1- i))
+                                        for r = (+ pow (random pow))
+                                        collect r)))
+              (when (typep dividend dividend-type)
+                (multiple-value-bind (q1 r1)
+                    (funcall foo dividend)
+                  (multiple-value-bind (q2 r2)
+                      (funcall fun dividend divisor)
+                    (unless (and (= q1 q2)
+                                 (eql r1 r2))
+                      (error "bad results for ~s with dividend type ~s"
+                             (list fun dividend divisor)
+                             dividend-type))))))))))))