tests/arith-slow.pure.lisp

   1 ;;; These two tests are by themselves because they consume more run time
   2 ;;; than all other tests in arith.pure combined.
   3
   4 (defmacro test-guts ()
   5   #+sb-thread '(let ((t1 (sb-thread:make-thread #'doit :arguments '(-8 0)))
   6                      (t2 (sb-thread:make-thread #'doit :arguments '(1 8))))
   7                 (sb-thread:join-thread t1)
   8                 (sb-thread:join-thread t2))
   9   #-sb-thread '(doit -8 8))
  10
  11 (with-test (:name (logand :complicated-identity)
  12                   :skipped-on :mips) ; too slow
  13   (flet ((doit (k-lo k-hi)
  14   (loop for k from k-lo upto k-hi do
  15     (loop for min from -16 upto 16 do
  16       (loop for max from min upto 16 do
  17         (let ((f (checked-compile `(lambda (x)
  18                                      (declare (type (integer ,min ,max) x))
  19                                      (logand x ,k)))))
  20           (loop for x from min upto max do
  21             (assert (eql (logand x k) (funcall f x))))))))))
  22     (test-guts)))
  23
  24 (with-test (:name (logior :complicated-identity)
  25                   :skipped-on :mips) ; too slow
  26   (flet ((doit (k-lo k-hi)
  27   (loop for k from k-lo upto k-hi do
  28     (loop for min from -16 upto 16 do
  29       (loop for max from min upto 16 do
  30         (let ((f (checked-compile `(lambda (x)
  31                                      (declare (type (integer ,min ,max) x))
  32                                      (logior x ,k)))))
  33           (loop for x from min upto max do
  34             (assert (eql (logior x k) (funcall f x))))))))))
  35     (test-guts)))
  36
  37 (defun type-derivation (op u-l u-h s-l s-h)
  38   (let ((type (sb-kernel:specifier-type (cadr (caddr (sb-kernel:%simple-fun-type
  39                                                       (compile nil `(lambda (u s)
  40                                                                       (,op (truly-the (integer ,u-l ,u-h) u)
  41                                                                            (truly-the (integer ,s-l ,s-h) s))))))))))
  42     (loop for u from u-l to u-h
  43           always (assert (sb-kernel:ctypep (loop for s from s-l to s-h
  44                                                  minimize (funcall op u s))
  45                                            type)))))
  46
  47 (defun type-derivation1 (op l h)
  48   (let ((interval (sb-c::numeric-type->interval
  49                    (sb-kernel:specifier-type (cadr (caddr (sb-kernel:%simple-fun-type
  50                                                            (compile nil `(lambda (u)
  51                                                                            (,op (truly-the (integer ,l ,h) u)))))))))))
  52     (values (loop for u from l to h
  53                   minimize (funcall op u))
  54             (loop for u from l to h
  55                   maximize (funcall op u))
  56             (sb-c::interval-low interval)
  57             (sb-c::interval-high interval))))
  58
  59 (with-test (:name :logical-type-derivation)
  60   (loop
  61     for low1 from -4 to 5
  62     do
  63     (loop
  64       for high1 from low1 to 5
  65       do
  66       (loop
  67         for low2 from -4 to 5
  68         do
  69         (loop
  70           for high2 from low2 to 5
  71           do
  72           (loop for op in '(logand logior logxor)
  73                 do
  74                 (type-derivation op low1 high1 low2 high2)))))))
  75
  76 (with-test (:name :bit-type-derivation)
  77   (loop
  78     for low from -18 to 17
  79     do
  80     (loop
  81       for high from low to 17
  82       do (loop for op in '(logcount integer-length)
  83                do
  84                (multiple-value-bind (low high r-low r-high) (type-derivation1 op low high)
  85                  (assert (>= low r-low))
  86                  (assert (<= high r-high)))))))