common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity
sbcl.sbcl/tests/arith-2.pure.lisp
Stas Boukarev a42c09f297 Fix cut-to-width 
The logand mask has to be checked to be unsigned

Fixes lp#2166725
2026-09-08 06:07:34 +03:00

2666 lines
77 KiB
Common Lisp
Raw Blame History

This file contains invisible Unicode characters

This file contains invisible Unicode characters that are indistinguishable to humans but may be processed differently by a computer. If you think that this is intentional, you can safely ignore this warning. Use the Escape button to reveal them.

;;;; arithmetic tests without side effects
;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; While most of SBCL is derived from the CMU CL system, the test
;;;; files (like this one) were written from scratch after the fork
;;;; from CMU CL.
;;;;
;;;; This software is in the public domain and is provided with
;;;; absolutely no warranty. See the COPYING and CREDITS files for
;;;; more information.
(defmacro define-compiled-fun (fun name)
`(progn
(declaim (notinline ,name))
(defun ,name (&rest args)
(declare (optimize safety))
(case (length args)
(1 (,fun (car args)))
(2 (,fun (car args) (cadr args)))
(t (apply #',fun args))))))
(define-compiled-fun min compiled-min)
(define-compiled-fun max compiled-max)
(define-compiled-fun + compiled-+)
(define-compiled-fun * compiled-*)
(define-compiled-fun logand compiled-logand)
(define-compiled-fun logior compiled-logior)
(define-compiled-fun logxor compiled-logxor)
(assert (null (ignore-errors (compiled-min '(1 2 3)))))
(assert (= (compiled-min -1) -1))
(assert (null (ignore-errors (compiled-min 1 #(1 2 3)))))
(assert (= (compiled-min 10 11) 10))
(assert (null (ignore-errors (compiled-min (find-package "CL") -5.0))))
(assert (= (compiled-min 5.0 -3) -3))
(assert (null (ignore-errors (compiled-max #c(4 3)))))
(assert (= (compiled-max 0) 0))
(assert (null (ignore-errors (compiled-max "MIX" 3))))
(assert (= (compiled-max -1 10.0) 10.0))
(assert (null (ignore-errors (compiled-max 3 #'max))))
(assert (= (compiled-max -3 0) 0))
(assert (null (ignore-errors (compiled-+ "foo"))))
(assert (= (compiled-+ 3f0) 3f0))
(assert (null (ignore-errors (compiled-+ 1 #p"tmp"))))
(assert (= (compiled-+ 1 2) 3))
(assert (null (ignore-errors (compiled-+ '(1 2 3) 3))))
(assert (= (compiled-+ 3f0 4f0) 7f0))
(assert (null (ignore-errors (compiled-* "foo"))))
(assert (= (compiled-* 3f0) 3f0))
(assert (null (ignore-errors (compiled-* 1 #p"tmp"))))
(assert (= (compiled-* 1 2) 2))
(assert (null (ignore-errors (compiled-* '(1 2 3) 3))))
(assert (= (compiled-* 3f0 4f0) 12f0))
(assert (null (ignore-errors (compiled-logand #(1)))))
(assert (= (compiled-logand 1) 1))
(assert (null (ignore-errors (compiled-logior 3f0))))
(assert (= (compiled-logior 4) 4))
(assert (null (ignore-errors (compiled-logxor #c(2 3)))))
(assert (= (compiled-logxor -6) -6))
(with-test (:name (coerce :overflow))
(checked-compile-and-assert
()
'(lambda (n) (coerce n 'single-float))
(((expt 10 1000)) #+no-float-traps sb-ext:single-float-positive-infinity
#-no-float-traps (condition 'floating-point-overflow))))
(defun are-we-getting-ash-right (x y)
(declare (optimize speed)
(type (unsigned-byte 32) x)
(type (integer -40 0) y))
(ash x y))
(defun what-about-with-constants (x)
(declare (optimize speed) (type (unsigned-byte 32) x))
(ash x -32))
(dotimes (i 41)
(assert (= (are-we-getting-ash-right (1- (ash 1 32)) (- i))
(if (< i 32)
(1- (ash 1 (- 32 i)))
0))))
(assert (= (what-about-with-constants (1- (ash 1 32))) 0))
(defun one-more-test-case-to-catch-sparc (x y)
(declare (optimize speed (safety 0))
(type (unsigned-byte 32) x) (type (integer -40 2) y))
(the (unsigned-byte 32) (ash x y)))
(assert (= (one-more-test-case-to-catch-sparc (1- (ash 1 32)) -40) 0))
(eval-when (:compile-toplevel :load-toplevel :execute)
(defvar *n-fixnum-bits* (- sb-vm:n-word-bits sb-vm::n-fixnum-tag-bits))
(defvar *shifts* (let ((list (list 0
1
(1- sb-vm:n-word-bits)
sb-vm:n-word-bits
(1+ sb-vm:n-word-bits))))
(append list (mapcar #'- list)))))
(macrolet ((nc-list ()
`(list ,@(loop for i from 0 below (length *shifts*)
collect `(frob (nth ,i *shifts*)))))
(c-list ()
`(list ,@(loop for i from 0 below (length *shifts*)
collect `(frob ,(nth i *shifts*))))))
(defun nc-ash (x)
(macrolet ((frob (y)
`(list x ,y (ash x ,y))))
(nc-list)))
(defun c-ash (x)
(macrolet ((frob (y)
`(list x ,y (ash x ,y))))
(c-list)))
(defun nc-modular-ash-ub (x)
(macrolet ((frob (y)
`(list x ,y (logand most-positive-fixnum (ash x ,y)))))
(nc-list)))
(defun c-modular-ash-ub (x)
(declare (type (and fixnum unsigned-byte) x)
(optimize speed))
(macrolet ((frob (y)
`(list x ,y (logand most-positive-fixnum (ash x ,y)))))
(c-list))))
(let* ((values (list 0 1 most-positive-fixnum))
(neg-values (cons most-negative-fixnum
(mapcar #'- values))))
(labels ((test (value fun1 fun2)
(let ((res1 (funcall fun1 value))
(res2 (funcall fun2 value)))
(mapcar (lambda (a b)
(unless (equalp a b)
(error "ash failure for ~A vs ~A: ~A not EQUALP ~A"
fun1 fun2
a b)))
res1 res2))))
(loop for x in values do
(test x 'nc-ash 'c-ash)
(test x 'nc-modular-ash-ub 'c-modular-ash-ub))
(loop for x in neg-values do
(test x 'nc-ash 'c-ash))))
(declaim (inline ppc-ldb-2))
(defun ppc-ldb-2 (fun value)
(declare (type (signed-byte 32) value)
(optimize (speed 3) (safety 0) (space 1) (debug 1)
(compilation-speed 0)))
(funcall fun (ldb (byte 8 24) value))
(funcall fun (ldb (byte 8 16) value))
(funcall fun (ldb (byte 8 8) value))
(funcall fun (ldb (byte 8 0) value))
(values))
(defun ppc-ldb-1 (fun)
(declare (optimize (speed 3) (safety 0) (space 1) (debug 1)
(compilation-speed 0)))
(loop
for param :across (make-array 1 :initial-element nil)
for size :across (make-array 1 :element-type 'fixnum :initial-element 3)
do (ppc-ldb-2 fun (if param size -1))))
(with-test (:name :ppc-ldb)
(let ((acc '()))
(ppc-ldb-1 (lambda (x)
(push x acc)))
(assert (equal acc '(#xff #xff #xff #xff)))))
(with-test (:name :ldb-word-cast)
(checked-compile-and-assert
()
`(lambda (x y)
(truly-the fixnum (ldb (byte x y) 100)))
((100 0) 100)))
(with-test (:name :logbitp-negative-error)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (x y)
(logbitp x y))
((-1 0) (condition 'type-error))
((-2 (1+ most-positive-fixnum)) (condition 'type-error))
(((1- most-negative-fixnum) 1) (condition 'type-error))))
(with-test (:name :*-overflow-ratio)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (a)
(the fixnum (* 8 a)))
((1/8) 1)))
#+64-bit
(with-test (:name :bignum-float)
(checked-compile-and-assert
()
`(lambda (d)
(sb-sys:without-gcing
(let ((res (sb-bignum:%allocate-bignum 2)))
(setf (sb-bignum:%bignum-ref res 1) 529
(sb-bignum:%bignum-ref res 0) 9223372036854775807)
(sb-kernel:set-header-data res 1)
(unwind-protect
(< res d)
(sb-kernel:set-header-data res 2)))))
((-9.223372036854776d18) nil)
((9.223372036854776d18) t)))
(with-test (:name :overflow-transform-nil)
(checked-compile-and-assert
(:allow-warnings t)
`(lambda (v)
(let ((i 0))
(flet ((f (i)
(the fixnum i)
(svref v (+ i 26387449082611642302))))
(f i)
(incf i)
(f i)
(incf i)))))
(checked-compile-and-assert
(:allow-style-warnings t)
`(lambda (s e)
(subseq s 0 (when e
(- (length s) 12129535698721845515))))))
(with-test (:name :integer-length-union-derivation)
(checked-compile-and-assert
()
`(lambda (b)
(integer-length
(if (>= b 0)
b
-2)))
((-1) 1)
((0) 0)
((15) 4)))
(with-test (:name :isqrt-union)
(assert-type
(lambda (x)
(declare ((or (integer 1 5) (integer 9 10)) x))
(isqrt x))
(integer 1 3)))
(with-test (:name :integer-length-union)
(assert-type
(lambda (x)
(declare ((or (integer 1 5) (integer 9 10)) x))
(integer-length x))
(integer 1 4)))
(with-test (:name :rem-transform-erase-types)
(checked-compile-and-assert
()
`(lambda (a)
(declare ((integer * 0) a))
(zerop (rem a 2)))
((-1) nil)
((-2) t))
(checked-compile-and-assert
()
`(lambda (a)
(declare ((member 7 -9) a))
(zerop (rem a 8)))
((7) nil)
((-9) nil)))
(with-test (:name :unexpected-immediates-in-vops)
(checked-compile
`(lambda (n)
(declare (fixnum n))
(loop for i below 2
do (print (logbitp i n))
(the (satisfies minusp) i))))
(checked-compile
`(lambda ()
(loop for i below 2
do (print (lognot i))
(the (satisfies minusp) i))))
(checked-compile
`(lambda ()
(loop for i below 2
do (print (- i))
(the (satisfies minusp) i))))
(checked-compile
`(lambda ()
(loop for i below 2
do (print (* i 3))
(the (satisfies minusp) i))))
(checked-compile
`(lambda ()
(loop for i below 2
do (print (* i 3))
(the (satisfies minusp) i))))
(checked-compile
`(lambda ()
(loop for i of-type fixnum below 2
do (print (logand most-positive-word (* i 4)))
(the (satisfies minusp) i)))))
(with-test (:name :/-by-integer-type)
(assert-type
(lambda (x y)
(declare ((integer 1 9) x)
(integer y))
(/ x y))
(or (rational -9 (0)) (rational (0) 9)))
(assert-type
(lambda (x y)
(declare ((integer 1 9) x)
((integer 0) y))
(/ x y))
(rational (0) 9))
(assert-type
(lambda (x y)
(declare ((rational 0 9) x)
((integer 0) y))
(/ x y))
(rational 0 9)))
(with-test (:name :truncate-unused-q)
(checked-compile-and-assert
()
`(lambda (a)
(declare (fixnum a))
(rem a 4))
((3) 3)
((-3) -3)
((4) 0)
((-4) 0)))
(with-test (:name :*-by-integer-type)
(assert-type
(lambda (x)
(declare (integer x))
(* x 5))
(or (integer 5) (integer * -5) (integer 0 0))))
(with-test (:name :truncate-transform-unused-result)
(assert-type
(lambda (c)
(declare ((integer -1000 0) c)
(optimize speed))
(values
(truncate (truncate (rem c -89) -16) 20)))
(or (integer 0 0))))
(with-test (:name :rem^2)
(checked-compile-and-assert
()
`(lambda (a)
(declare (fixnum a))
(rem a 2))
((-2) 0)
((-3) -1)
((2) 0)
((3) 1)))
(with-test (:name :deposit-field-derive-type)
(assert-type
(lambda (s)
(declare ((member 8 10) s))
(deposit-field -21031455 (byte s 9) 1565832649825))
(or (integer 1565832320097 1565832320097) (integer 1565832713313 1565832713313))))
(with-test (:name :logior-negative-bound)
(checked-compile-and-assert
()
`(lambda (b c)
(declare ((integer 7703 1903468060) c))
(logandc1 (/ (logorc2 c b) -1) c))
((-1 7703) 7702)))
(with-test (:name :set-numeric-contagion)
(assert-type
(lambda (n)
(loop for i below n
sum (coerce n 'single-float)))
(or (integer 0 0) single-float)))
(with-test (:name :overflow-transform-order)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (a m)
(declare (fixnum a))
(let ((j (* 44 a)))
(when m
(the fixnum j))))
((most-positive-fixnum nil) nil)
((most-positive-fixnum t) (condition 'type-error))))
(with-test (:name :logtest-memref-boxed)
(checked-compile-and-assert
()
`(lambda (b)
(declare (sb-vm:word b))
(when (oddp b)
(lambda (m)
(when m
(setf b 1))
b)))
(((expt 2 (1- sb-vm:n-word-bits))) nil)
(((1+ (expt 2 (1- sb-vm:n-word-bits)))) t :test (lambda (x y)
y
(functionp (car x))))))
(with-test (:name :range-unsigned)
(assert-type
(lambda (d)
(declare (type (integer 1 109) d))
(typep (- d) '(integer -47727025476642942 -2593702250735)))
null))
(with-test (:name :signed-byte-8-p-unsigned
;; these lack the necessary RANGE<= vop
:fails-on (:or :mips :ppc :ppc64 :sparc :riscv :loongarch64))
(checked-compile
`(lambda (a)
(declare (type (simple-array sb-vm:word (*)) a)
(optimize speed))
(the (signed-byte 8) (aref a 0)))
:allow-notes nil))
(with-test (:name :or-chain)
(checked-compile-and-assert
()
`(lambda (b)
(declare (fixnum b))
(case b ((0 -3) 1) (t 2)))
((0) 1)
((-3) 1)
((3) 2)
((1) 2)))
(with-test (:name :or-chain-types)
(checked-compile-and-assert
()
`(lambda (b)
(declare ((integer -1 1) b))
(case b
((-1 0) 0)
(t 1)))
((-1) 0)
((0) 0)
((1) 1)))
(with-test (:name :or-chain-tagging)
(checked-compile-and-assert
()
`(lambda (x)
(or (eq x -6)
(eq x -2)))
((-6) t)
((-2) t)
((6) nil)
((2) nil)
((-12) nil)
((-4) nil))
(checked-compile-and-assert
()
`(lambda (x)
(or (eq x 0)
(eq x -4)))
((0) t)
((-4) t)
((4) nil)
((-8) nil))
(checked-compile-and-assert
()
`(lambda (x)
(or (eq x 97)
(eq x 65)))
((-4611686018427387807) nil)
((97) t)
((65) t))
(checked-compile-and-assert
()
`(lambda (x)
(or (eq x -65)
(eq x -97)))
((-97) t)
((-65) t))
(checked-compile-and-assert
()
`(lambda (x)
(case x ((-3 -2 17) t)))
((4611686018427387902) nil)
((-3) t)
((-2) t)
((17) t)))
(with-test (:name :range<=-same)
(checked-compile-and-assert
()
`(lambda (a c)
(declare (type fixnum a))
(let ((v7 (if c
4611686018427387904
-6)))
(if (> v7 a)
a
(if (<= a v7)
0
a))))
((-7 nil) -7)
((-7 t) -7)
((-6 nil) 0)
((-6 t) -6)
((-3 nil) -3)))
(with-test (:name :/-folding)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (a)
(declare (bit a))
(/ 1 a))
(:return-type (values (eql 1) &optional))
((1) 1)
((0) (condition 'division-by-zero)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (a)
(declare (bit a))
(= (/ 5 a) 5))
(:return-type (values (eql t) &optional))
((1) t)
((0) (condition 'division-by-zero)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (a)
(declare (integer a))
(/ 0 a))
(:return-type (values (eql 0) &optional))
((1) 0)
((0) (condition 'division-by-zero)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (a)
(declare (integer a))
(floor 0 a))
(:return-type (values (eql 0) (eql 0) &optional))
((1) (values 0 0))
((0) (condition 'division-by-zero)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (a)
(floor 0 a))
((1.0) (values 0 0.0))
((0) (condition 'division-by-zero))))
(with-test (:name :dpb-size-overflow)
(checked-compile-and-assert
()
`(lambda (a)
(declare ((unsigned-byte 8) a))
(dpb a (byte 63 8)
81))
((90) 23121))
(checked-compile-and-assert
()
`(lambda (a)
(declare ((unsigned-byte 8) a))
(dpb a (byte 32 32)
1))
((1) 4294967297)))
(with-test (:name :mask-field-size-overflow)
(checked-compile-and-assert
()
`(lambda (a)
(truly-the fixnum
(mask-field (byte 78 0) a)))
((35) 35)))
(with-test (:name :ash-count-integr)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (a b)
(ash a b))
((1 -1.0) (condition 'type-error))
(((expt 2 74) -1.0) (condition 'type-error))
((0 1.0) (condition 'type-error))
(((expt 2 74) 1.0) (condition 'type-error))
((1 1d0) (condition 'type-error))
(((expt 2 74) 1d0) (condition 'type-error))
((0 -3d0) (condition 'type-error))
(((expt 2 74) -2d0) (condition 'type-error))))
(with-test (:name :log-integer-derive-type)
(assert-type
(lambda (x)
(declare ((integer 1) x))
(log x))
(single-float 0.0))
(assert-type
(lambda (x)
(declare ((integer 0) x))
(log x))
single-float)
(assert-type
(lambda (x)
(declare (integer x))
(log x))
(or (complex single-float) single-float)))
(with-test (:name :floor-derive-type)
(assert-type
(lambda (a b)
(declare ((integer -10 0) b)
((unsigned-byte 8) a))
(floor a b))
(values (integer -255 0) (integer -9 0) &optional)))
(with-test (:name :logbitp-on-integers
:implemented-on (:vop-existsp logbitp))
(assert (not (ctu:ir1-named-calls `(lambda (x)
(logbitp 20 x))))))
(with-test (:name :bt-negative-bit)
(checked-compile-and-assert
()
`(lambda (c)
(declare ((signed-byte 64) c))
(logtest c -2199023255553))
((-2049990302793354782) t)
((0) nil)
(((ash 1 41)) nil))
(checked-compile-and-assert
()
`(lambda (b)
(declare (fixnum b))
(logior b -4611686018427387905))
((-6) -1)))
(with-test (:name :float-cmp)
(checked-compile-and-assert
()
`(lambda (a b)
(declare ((unsigned-byte 20) a)
(float b))
(< a b))
((6 4.0) nil)
((1 1.1) t)))
(with-test (:name :complex+non-complex-type)
(assert-type
(lambda (a)
(+ a #c(1.0 3.0)))
(or (complex single-float) (complex double-float)))
(assert-type
(lambda (a)
(* a #c(1d0 0d0)))
(complex double-float)))
(with-test (:name :bignum-ash-modarith)
(checked-compile-and-assert
()
`(lambda (a)
(declare (bignum a))
(logand (ash a -1) 1))
(((expt 2 129)) 0)
(((+ (expt 2 129) 2)) 1)))
(with-test (:name :two-fixnum-eq-mask)
(checked-compile-and-assert
()
`(lambda (x)
(declare (fixnum x))
(typep x '(member -1 ,most-positive-fixnum)))
((-1) t)
((most-positive-fixnum) t)
((1) nil)
((0) nil)
((most-negative-fixnum) nil)
(((1+ most-negative-fixnum)) nil)
(((1- most-positive-fixnum)) nil)))
(with-test (:name :logior-derive-negative)
(assert-type
(lambda (x)
(declare (fixnum x))
(logior x 1))
(or (integer #.(1+ most-negative-fixnum) -1)
(integer 1 #.most-positive-fixnum)))
(assert-type
(lambda (x y)
(declare (fixnum x)
((and (signed-byte 16) (not (eql 0))) y))
(logior y x))
(or (integer #.(1+ most-negative-fixnum) -1)
(integer 1 #.most-positive-fixnum)))
(assert-type
(lambda (x)
(declare (fixnum x))
(logior x 10))
(or (integer #.(+ most-negative-fixnum 10) -1)
(integer 10 #.most-positive-fixnum))))
(with-test (:name :range<=low-address)
(checked-compile-and-assert
()
`(lambda (a)
(typep a '(integer 1 13)))
((0.0) nil)
((0) nil)
((1) t)
((6) t)
((13) t)
((14) nil)))
(with-test (:name :ratio+integer-type)
(assert-type
(lambda (x r)
(declare (integer x)
(ratio r))
(+ x r))
ratio)
(assert-type
(lambda (x r)
(declare (integer x)
(ratio r))
(+ r x))
ratio)
(assert-type
(lambda (x r)
(declare (integer x)
(ratio r))
(/ r x))
ratio))
(with-test (:name :fixnum-gcd-overflow)
(checked-compile-and-assert
()
`(lambda (a b)
(gcd a b))
((most-negative-fixnum most-negative-fixnum) (- most-negative-fixnum))
((most-negative-fixnum 48) 16)))
(with-test (:name :signed-word-minus1-division)
(checked-compile-and-assert
()
`(lambda (a b)
(truncate
(the sb-vm:signed-word a)
(the (member -8 -1) b)))
((-2 -1) (values 2 0))
((-2 -8) (values 0 -2))
(((- #1=(expt 2 (1- sb-vm:n-word-bits))) -1) (values #1# 0))
(((- #1#) -8) (values (- (ash (- #1#) -3))
0))))
(with-test (:name :integer-length-minus1)
(checked-compile-and-assert
()
`(lambda (c)
(declare ((and sb-vm:signed-word (integer * -1)) c))
(integer-length c))
((-1) 0)
((-2) 1)))
(with-test (:name :truncate-rem-zerop-types)
(checked-compile `(sb-int:named-lambda f (start end)
(declare (optimize (speed 3))
(type (unsigned-byte 8) start end))
(let ((half (/ (+ end start) 2)))
(f start half)
half))
:allow-notes nil))
(with-test (:name :dpb-computed-posn)
(assert-type
(lambda (n j count)
(declare ((unsigned-byte 64) n))
(dpb
j
(byte count (- 64 count))
n))
(unsigned-byte 64))
(assert-type
(lambda (n j count)
(declare ((unsigned-byte 32) n))
(dpb
j
(byte count (- 64 count))
n))
(unsigned-byte 64))
(assert-type
(lambda (n j count)
(declare ((unsigned-byte 54) n))
(dpb
j
(byte count (- 32 count))
n))
(unsigned-byte 54)))
(with-test (:name :ldb-computed-posn
:fails-on (or :ppc64 :riscv :loongarch64))
(assert-type
(lambda (x y)
(ldb (byte y (- 32 y)) x))
(unsigned-byte 32))
#+64-bit
(assert (not (ctu:ir1-named-calls `(lambda (x y)
(ldb (byte y (- 32 y)) x))))))
(with-test (:name :modarith-unknown)
(checked-compile-and-assert
()
`(lambda (a)
(declare ((rational 6435247825949752037) a))
(logand (1+ a) 138))
((6435247825949752037) 130))
(checked-compile-and-assert
()
`(lambda (x)
(declare ((member 813472 -183 -1.0) x))
(evenp (1+ x)))
((813472) nil)
((-183) t))
(checked-compile-and-assert
()
`(lambda (c)
(logand (+ c (multiple-value-prog1 0)) 1))
((1) 1)
((2) 0))
(checked-compile-and-assert
()
`(lambda (a)
(oddp (1+ (read-from-string a))))
(("1") nil)
(("-2") t)))
(with-test (:name :logtest-lognot)
(checked-compile-and-assert
()
`(lambda (a)
(logtest -3 (lognot a)))
((5) t)
((-3) nil)))
(with-test (:name :transform-deleted-casts)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (x y)
(declare ((integer 0 30) y))
(dpb 3 (byte 2 y) (the (integer * 300) x)))
((400 2) (condition 'type-error))
((300 0) 303)))
(with-test (:name :truncate-unknown-integer
:fails-on (or :arm :riscv :loongarch64))
(assert (not (ctu:ir1-named-calls `(lambda (x)
(declare (integer x))
(values (the (signed-byte 25) (floor x 2)))))))
(assert (not (ctu:ir1-named-calls `(lambda (x)
(declare (unsigned-byte x))
(values (the (signed-byte 25) (floor x 2)))))))
(assert (not (ctu:ir1-named-calls `(lambda (x)
(declare (integer x))
(values (the (signed-byte 25) (truncate x 2)))))))
(assert (not (ctu:ir1-named-calls `(lambda (x)
(declare (unsigned-byte x))
(values (the (signed-byte 25) (truncate x 2)))))))
(assert (not (ctu:ir1-named-calls `(lambda (x)
(declare (integer x))
(values (the (signed-byte 25) (ceiling x 2)))))))
(assert (not (ctu:ir1-named-calls `(lambda (x)
(declare (unsigned-byte x))
(values (the (signed-byte 25) (ceiling x 2))))))))
(with-test (:name :word-floor-ceiling
:fails-on (or :ppc :arm :riscv :loongarch64 :sparc))
(assert (not (ctu:ir1-named-calls `(lambda (x y)
(declare (sb-vm:signed-word x y))
(floor x y)))))
(assert (not (ctu:ir1-named-calls `(lambda (x y)
(declare (sb-vm:signed-word x y))
(ceiling x y)))))
(assert (not (ctu:ir1-named-calls `(lambda (x y)
(declare (sb-vm:word x y))
(ceiling x y)))))
(assert (not (ctu:ir1-named-calls `(lambda (x y)
(declare (sb-vm:word x y))
(floor x y))))))
(with-test (:name :fixnum-*-by-unknown-overflow
:implemented-on (:vop-existsp overflow*))
(assert (not (ctu:ir1-named-calls `(lambda (x y)
(declare (integer x)
(fixnum y))
(the fixnum (* x y))))))
(assert (not (ctu:ir1-named-calls `(lambda (x y)
(declare (integer x)
(fixnum y))
(the fixnum (* y x))))))
(assert (not (ctu:ir1-named-calls `(lambda (x y)
(declare (integer x y))
(the fixnum (* x y))))))
(assert (equal (ctu:ir1-named-calls `(lambda (x)
(the fixnum (* x 2))))
'(sb-kernel:*-by-fixnum-to-fixnum))))
(with-test (:name :fixnum-*-by-unknown)
(assert (equal (ctu:ir1-named-calls `(lambda (x)
(the fixnum (* x 2))))
'(sb-kernel:*-by-fixnum-to-fixnum)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (a)
(declare ((integer -1 11094097273866491717) a))
(the (integer 1)
(truncate a 2305843009213693949)))
((11094097273866491717) (values 4 1870725237011715921))))
(with-test (:name :logxor-1-type)
(assert-type
(lambda (x)
(logxor x (1- x)))
(integer -1))
(assert-type
(lambda (x)
(declare ((integer 1) x))
(logxor x (1- x)))
(integer 1))
(assert-type
(lambda (x)
(logxor x (1+ x)))
(integer -1))
(assert-type
(lambda (x)
(unless (eql x -1)
(logxor x (1+ x))))
(or null (integer 1))))
(with-test (:name :logior--type)
(assert-type
(lambda (n)
(logior n (- n)))
(integer * 0))
(assert-type
(lambda (n)
(declare ((unsigned-byte 64) n))
(logior n (- n)))
(integer -9223372036854775808 0))
(assert-type
(lambda (n)
(declare ((signed-byte 64) n))
(logior n (- n)))
(integer -9223372036854775808 0))
(assert-type
(lambda (n)
(declare ((integer -16 1024) n))
(logior n (- n)))
(integer -1024 0))
(assert-type
(lambda (n)
(declare ((integer #.(1+ (- (ash 1 63))) 0) n))
(logior n (- n)))
(integer -4611686018427387904 0))
(assert-type
(lambda (n)
(declare ((integer -100 -10) n))
(logior n (- n)))
(integer -64 -1))
(assert-type
(lambda (n)
(declare ((integer 1) n))
(logior n (- n)))
(integer * -1)))
(with-test (:name :logand--type)
(assert-type
(lambda (n)
(logand n (- n)))
(integer 0 *))
(assert-type
(lambda (n)
(declare ((unsigned-byte 64) n))
(logand n (- n)))
(integer 0 9223372036854775808))
(assert-type
(lambda (n)
(declare ((signed-byte 64) n))
(logand n (- n)))
(integer 0 9223372036854775808))
(assert-type
(lambda (n)
(declare ((integer -16 1024) n))
(logand n (- n)))
(integer 0 1024))
(assert-type
(lambda (n)
(declare ((integer #.(1+ (- (ash 1 63))) 0) n))
(logand n (- n)))
(integer 0 4611686018427387904))
(assert-type
(lambda (n)
(declare ((integer -100 -10) n))
(logand n (- n)))
(integer 1 64))
(assert-type
(lambda (n)
(declare ((integer 1) n))
(logand n (- n)))
(integer 1 *)))
(with-test (:name :logxor--type)
(assert-type
(lambda (n)
(logxor n (- n)))
(integer * 0))
(assert-type
(lambda (n)
(declare ((unsigned-byte 64) n))
(logxor n (- n)))
(integer -18446744073709551616 0))
(assert-type
(lambda (n)
(declare ((signed-byte 64) n))
(logxor n (- n)))
(integer -18446744073709551616 0))
(assert-type
(lambda (n)
(declare ((integer -16 1024) n))
(logxor n (- n)))
(integer -2048 0))
(assert-type
(lambda (n)
(declare ((integer -1 0) n))
(logxor n (- n)))
(integer -2 0))
(assert-type
(lambda (n)
(declare ((integer -2 -1) n))
(logxor n (- n)))
(integer -4 -2))
(assert-type
(lambda (n)
(declare ((integer 1) n))
(logxor n (- n)))
(integer * -2))
(assert-type
(lambda (n)
(declare ((integer * -1) n))
(logxor n (- n)))
(integer * -2)))
(with-test (:name :logxor-ash-type)
(assert-type
(lambda (n)
(declare ((signed-byte 64) n))
(logxor n (ash n -63)))
(unsigned-byte 63))
(assert-type
(lambda (x)
(declare ((and (signed-byte 64) (not (integer -1 0))) x))
(logxor x (ash x (- 63))))
(unsigned-byte 63)))
(with-test (:name :unsigned-byte-x-p)
(checked-compile-and-assert
()
`(lambda (a)
(typep a '(unsigned-byte 128)))
((1) t)
((-1) nil)
(((1- (expt 2 128))) t)
(((expt 2 128)) nil)
(((- (expt 2 128))) nil)
(('a) nil))
(checked-compile-and-assert
()
`(lambda (a)
(declare (unsigned-byte a))
(typep a '(unsigned-byte 128)))
((1) t)
(((1- (expt 2 128))) t)
(((expt 2 128)) nil))
(checked-compile-and-assert
()
`(lambda (a)
(declare (integer a))
(typep a '(unsigned-byte 128)))
((1) t)
((-1) nil)
(((1- (expt 2 128))) t)
(((expt 2 128)) nil)
(((- (expt 2 128))) nil))
(checked-compile-and-assert
()
`(lambda (a)
(declare (bignum a))
(typep a '(unsigned-byte 128)))
(((1- (expt 2 128))) t)
(((expt 2 128)) nil)
(((- (expt 2 128))) nil))
(checked-compile-and-assert
()
`(lambda (a)
(typep a '(unsigned-byte 80)))
((1) t)
((-1) nil)
(((1- (expt 2 80))) t)
(((expt 2 80)) nil)
(((- (expt 2 80))) nil)
(('a) nil))
(checked-compile-and-assert
()
`(lambda (a)
(typep a '(unsigned-byte 160)))
((1) t)
((-1) nil)
(((expt 2 80)) t)
(((1- (expt 2 160))) t)
(((expt 2 160)) nil)
(((- (expt 2 160))) nil)
(('a) nil)))
(with-test (:name :signed-byte-x-p)
(checked-compile-and-assert
()
`(lambda (a)
(typep a '(signed-byte 128)))
((1) t)
((-2) t)
(((1- (expt 2 127))) t)
(((- (expt 2 127))) t)
(((expt 2 127)) nil)
(('a) nil))
(checked-compile-and-assert
()
`(lambda (a)
(declare (integer a))
(typep a '(signed-byte 128)))
((1) t)
((-2) t)
(((1- (expt 2 127))) t)
(((- (expt 2 127))) t)
(((expt 2 127)) nil))
(checked-compile-and-assert
()
`(lambda (a)
(declare (bignum a))
(typep a '(signed-byte 128)))
(((1- (expt 2 127))) t)
(((- (expt 2 127))) t)
(((expt 2 127)) nil)))
(with-test (:name :%bignum-length-type)
(assert-type
(lambda (x)
(declare (sb-vm:signed-word x))
(sb-bignum:%bignum-length x))
(integer 1 1))
(assert-type
(lambda (x)
(declare (word x))
(sb-bignum:%bignum-length x))
(integer 1 2)))
(with-test (:name :minus-eql-to-eq-reduction)
(checked-compile-and-assert
()
`(lambda (a c)
(declare (integer c))
(when (integerp a)
(eql (- a c) 0)))
(((eval '(expt 2 64)) (eval '(expt 2 64))) t)
((1 2) nil)))
(with-test (:name :unsigned-byte-64-p-move-to-word)
(checked-compile-and-assert
()
`(lambda (a m)
(if (typep a '(unsigned-byte 64))
(let ((j a))
(declare ((unsigned-byte 64) j))
(loop repeat 2
sum
(+ (funcall m (logand j #xFFFFFF))
(funcall m (logand j #xFFFFFF)))))))
((1234 #'+) 4936)
((3 #'-) -12)))
(with-test (:name :arith-negative-zero)
(assert-type
(lambda (x)
(declare (double-float x))
(+ (abs x) 0d0))
(or (member 0.0d0) (double-float (0.0d0))))
(assert-type
(lambda (x)
(declare (double-float x))
(- (abs x) -0d0))
(or (member 0.0d0) (double-float (0.0d0))))
(assert-type
(lambda (x)
(declare (double-float x))
(- -0d0 (abs x)))
(or (member -0.0d0) (double-float * (0.0d0))))
(assert-type
(lambda (x)
(declare (double-float x))
(* (abs x) 2d0))
(or (member 0.0d0) (double-float (0.0d0))))
(assert-type
(lambda (x y)
(declare (double-float x y))
(/ (abs x) (abs y)))
(or (member 0.0d0) (double-float (0.0d0))))
(assert-type
(lambda (x)
(declare ((double-float * -1d0) x))
(/ 10d0 x))
(or (member -0.0d0) (double-float -10.0d0 (0.0d0))))
(assert-type
(lambda (x y)
(declare (double-float x y))
(expt (abs x) y))
(or (member 0.0d0) (double-float (0.0d0))))
(assert-type
(lambda (x)
(declare (double-float x))
(- (abs x)))
(or (member -0.0d0) (double-float * (0.0d0)))))
(with-test (:name :truncate-type)
(assert-type
(lambda (x)
(declare (double-float x))
(nth-value 1 (truncate x)))
(double-float -1.0d0 1.0d0))
(assert-type
(lambda (x)
(declare (float x))
(nth-value 1 (truncate (abs x))))
(or (float (0.0) 1.0) (member 0f0 0d0)))
(assert-type
(lambda (x)
(declare (double-float x))
(nth-value 1 (floor x)))
(double-float 0d0 1.0d0))
(assert-type
(lambda (x)
(declare (double-float x))
(nth-value 1 (floor (abs x))))
(or (double-float (0d0) 1.0d0) (eql 0d0)))
(assert-type
(lambda (x)
(declare (double-float x))
(nth-value 1 (ceiling x)))
(double-float -1.0d0 0d0))
(assert-type
(lambda (x)
(declare (double-float x))
(nth-value 1 (ceiling (abs x))))
(double-float -1.0d0 0d0))
(assert-type
(lambda (x)
(declare (float x))
(nth-value 1 (ftruncate x)))
(float -1.0 1.0))
(assert-type
(lambda (x)
(declare (double-float x))
(ftruncate (abs x)))
(values (or (member 0.0d0) (double-float (0.0d0)))
(or (member 0.0d0) (double-float (0.0d0) 1.0d0)) &optional))
(assert-type
(lambda (x)
(declare (double-float x))
(fceiling (abs x)))
(values (or (member 0.0d0) (double-float (0.0d0)))
(double-float -1.0d0 0.0d0) &optional))
(assert-type
(lambda (x)
(declare (double-float x))
(ffloor (abs x)))
(values (or (member 0.0d0) (double-float (0.0d0)))
(double-float 0.0d0 1.0d0) &optional))
(assert-type
(lambda ()
(ffloor 0 -1))
(values (eql -0.0) (eql 0) &optional))
(assert-type
(lambda (x)
(declare ((integer 6671 6672) x))
(values (ffloor -1333621864366 x)))
(single-float -1.9991334e8 -1.9988338e8)))
(with-test (:name :reduce-logior-type)
(assert-type
(lambda (a)
(reduce 'logior (the (simple-array (unsigned-byte 8)) a) :initial-value -7))
(integer -7 -1)))
(with-test (:name :atanh-type)
(assert-type
(lambda (n)
(atanh (the (real -1 1) n)))
float))
(with-test (:name :unknown-*-transform)
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f n)
(declare (fixnum f)
((unsigned-byte 65) n))
(the fixnum (* f n)))
((0 (expt 2 64)) 0)
((1 (expt 2 64)) (condition 'type-error))
((2 2) 4))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f)
(declare (type fixnum f))
(the fixnum (* f 25152445588928537400)))
((0) 0)
((1) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (a b)
(declare (integer a b))
(the fixnum (* a b)))
((0 (expt 2 64)) 0)
((1 (expt 2 64)) (condition 'type-error))
((2 2) 4))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (f)
(declare (integer f))
(the fixnum (* f 25152445588928537400)))
((0) 0)
((1) (condition 'type-error))))
(with-test (:name :ash-negative-type)
(assert-type
(lambda (x y)
(declare ((real * 0) x))
(ash x y))
(integer * 0)))
(with-test (:name :ash-overflow
:fails-on (or :sparc :ppc :ppc64))
(checked-compile-and-assert
()
`(lambda (a)
(declare (fixnum a))
(truly-the bit (ash a 90)))
((0) 0)
((1) 0)))
(with-test (:name :range-unsigned-comparison)
(checked-compile-and-assert
()
`(lambda (a)
(typep a '(integer 1 2147483647)))
((-1) nil)
((1) t)
((2147483647) t)
((2147483648) nil)
((0.0) nil)))
(with-test (:name :ash-right-two-word)
(checked-compile-and-assert
()
`(lambda (a)
(logand 4611686018427387903
(ash a -2)))
((10) 2)
((310805698068689180651640983330128115679) 585623305860541943)
((-7514499718243589878) 2733061088866490434)))
(with-test (:name :ash-left-add)
(checked-compile-and-assert
()
`(lambda (p d)
(declare ((signed-byte 64) p)
((unsigned-byte 63) d))
(+ (ash p 63) d))
((0 5) 5)
((4 4) 36893488147419103236)
((-5 5) -46116860184273879035))
(checked-compile-and-assert
()
`(lambda (p d)
(declare ((signed-byte #.sb-vm:n-word-bits) p)
((unsigned-byte 8) d))
(+ (ash p 8) d))
((0 5) 5)
((4 4) 1028)
((-5 4) -1276))
(checked-compile-and-assert
()
`(lambda (p d)
(declare ((unsigned-byte 63) d))
(+ (ash p 63) d))
((0 5) 5)
((4 4) 36893488147419103236)
((-5 5) -46116860184273879035))
(checked-compile-and-assert
()
`(lambda (p d)
(declare ((unsigned-byte 8) d))
(+ (ash p 8) d))
((0 5) 5)
((4 4) 1028)
((-5 4) -1276))
(checked-compile-and-assert
()
`(lambda (p d)
(declare ((unsigned-byte 64) d))
(+ (ash p 64) d))
((-1 17757265153539649207) -689478920169902409)
((-1 0) -18446744073709551616)))
(with-test (:name :remove-negate)
(flet ((test (form count)
(assert (= (count 'sb-kernel:%negate
(ctu:ir1-named-calls form nil))
count))))
(test `(lambda (x y)
(declare (integer x y))
(- (* x (- 5 y))))
0)
(test `(lambda (x y)
(- (truncate (- x) y)))
0)
(test `(lambda (x y)
(- (if x
(- x)
(- y))))
0)
(test `(lambda (x y)
(- (if x
4
(- y))))
0)
(test `(lambda (x y)
(declare (optimize (sb-c::float-accuracy 0)))
(- (* (/ x 4) (- y))))
0)
(test `(lambda (x y)
(- (truncate (- y) (* x 4))))
0)
(test `(lambda (a b)
(the integer (- (* a (- b)))))
0)
(test `(lambda (a b)
(+ (- (* a (- b))) 10))
0)
(test `(lambda (x a b)
(multiple-value-bind (a b) (if x
(funcall x)
(values 10 (- (* a (- b)))))
(values a
(+ b 10))))
0)
(test `(lambda (x a b)
(multiple-value-bind (a b)
(the (values t real)
(if x
(funcall x)
(values 10 (- (* a (- b))))))
(values a
(+ b 10))))
0)
(test `(lambda (x a b)
(multiple-value-bind (a b)
(the (values t integer)
(if x
(funcall x)
(values 10 (- (* a (- b))))))
(values a b)))
0)
(checked-compile-and-assert
()
`(lambda (a)
(- (* (if a 1 2)
(if a 3 4)
-2)))
((nil) 16)
((t) 6))
(test `(lambda (a) (- (* a 0))) 1)
(test `(lambda (a) (- (* a 0.0))) 0)
(checked-compile-and-assert
()
`(lambda (a)
(- (* a 0)))
((10.0) -0.0)
((10) 0))
(checked-compile-and-assert
()
`(lambda (a b c)
(- (* 4
(if a
(- b)
(- c)))))
((1 2 3) 8)
((nil 2 3) 12))
(checked-compile-and-assert
()
`(lambda (a c d)
(declare ((integer 4 9) d))
(-
(if c
(+
(if a 0 1)
(if a 0 1)
1)
(+ d 2))))
((nil t 5) -3)
((t nil 5) -7)
((t t 4) -1)
((nil nil 4) -6))
(checked-compile-and-assert
()
`(lambda (e f j)
(-
(if f
(truncate
(if e 0 100)
(if j j -96))
1)))
((nil 2 3) -33)
((nil nil 5) -1)
((nil t nil) 1))
(checked-compile-and-assert
()
`(lambda (a b c)
(- (if a -3 (* (truncate 4 b) c))))
((nil 2 3) -6)
((t 4 5) 3))
(checked-compile-and-assert
()
`(lambda (a b)
(- (* (* a 3) b)))
((0 4.0) -0.0))
(checked-compile-and-assert
()
`(lambda (a b)
(- (* a (- b))))
((4.0 0) -0.0))
(checked-compile-and-assert
()
`(lambda (a b)
(declare (integer b))
(- (- (+ a 5)) b))
((-5.0 0) -0.0))
(checked-compile-and-assert
()
`(lambda (a)
(cos (- a)))
((#C(0 2)) (cos #C(0 -2))))))
(with-test (:name :remove-negate.2)
(flet ((test (form count)
(assert (= (count 'sb-kernel:%negate
(ctu:ir1-named-calls form nil))
count))))
(test `(lambda (x y)
(declare (optimize (sb-c::float-accuracy 0)))
(* (- x) (- y)))
0)
(test `(lambda (x y)
(> (* (- x) (- y)) 10))
0)
(test `(lambda (a b d)
(declare (optimize (sb-c::float-accuracy 0)))
(- d (* a (- b))))
0)
(test `(lambda (x y)
(abs (* (- x) y)))
0)
(test `(lambda (x y)
(abs (if x
(- x)
y)))
0)
(test `(lambda (x)
(lognot (- x)))
0)
(test `(lambda (x)
(- (lognot x)))
0)
(test `(lambda (x)
(- (the integer (- x))))
0)
(test `(lambda (a)
(- (truncate a)))
0)
(test `(lambda (a)
(declare (integer a))
(- (ash (- a) -2)))
0)
(checked-compile-and-assert
()
`(lambda (m a)
(declare (integer a))
(abs (if m
(ash (abs a) -5)
-9)))
((t 63) 1)
((nil 1) 9))
(checked-compile-and-assert
()
`(lambda (r)
(declare (rational r))
(values (fceiling (- r) 2)))
((0) 0.0))
(checked-compile-and-assert
()
`(lambda (r)
(- (- r) 5))
((#C(.0 0)) #C(-5 -0.0)))
(checked-compile-and-assert
()
`(lambda (c)
(- (* #C(4.0 3) c)))
((#C(-0.0 0)) #C(0 -0.0)))
(checked-compile-and-assert
()
`(lambda (a b)
(declare ((complex float) a b))
(- (* (- a) b)))
((#C(-4.0 -3) #C(-0.0 0)) #C(0 -0.0)))
(checked-compile-and-assert
()
`(lambda (f i)
(- (* f (truncate i 20))))
((3.0 1) -0.0))
(checked-compile-and-assert
()
`(lambda (r c)
(+ (- (the (not (eql 0)) r)) c))
((-2 #c(1.0 -0.0)) #C(3.0 0.0))
((-3 #c(1.0 -0.0)) (+ (opaque-identity 3) (opaque-identity #c(1.0 -0.0)))))
(checked-compile-and-assert
()
`(lambda (r c)
(- c (- (the (not (eql 0)) r))))
((-1 #c(1.0 -0.0)) #C(0.0 -0.0))
((2.0 #c(1.0 -0.0)) (- (opaque-identity #c(1.0 -0.0)) (opaque-identity -2.0))))))
(with-test (:name :abs-match)
(flet ((test (form count)
(assert (= (count 'abs
(ctu:ir1-named-calls form nil))
count))))
(test `(lambda (x y)
(declare (real x))
(abs (* (abs x) y)))
1)
(test `(lambda (x y)
(declare (real x y))
(/ (abs y) (abs x)))
1)
(test `(lambda (x)
(declare (real x))
(abs (* x x)))
0)
(test `(lambda (x y)
(declare (real x))
(abs (/ (* (abs x) y) 4)))
1)
(test `(lambda (a b c)
(abs
(if a
(abs b)
c)))
1)
(test `(lambda (a)
(declare (real a))
(= (abs a) 10))
0)))
(with-test (:name :*-by-zero-type)
(assert-type
(lambda (d)
(* (the (double-float -10d0 10d0) d) 0.0d0))
(double-float 0d0 0d0))
(assert-type
(lambda (d)
(* (the (double-float * 10d0) d) 0.0d0))
(double-float * 0d0))
(assert-type
(lambda (x y)
(* (the (single-float 0.0 0.0) x)
(the (single-float -5.0 5.0) y)))
(single-float 0.0 0.0))
(assert-type
(lambda (x)
(* (the (integer -1 0) x) 4.0))
(single-float -4.0 0.0))
(assert-type
(lambda (x)
(* -0.0 (the (single-float 0.0 0.0) x)))
(single-float 0.0 0.0))
(assert-type
(lambda (x)
(abs (the (or (single-float -2.0 -1.0) (member -0.0)) x)))
(or (single-float 1.0 2.0) (member 0.0))))
(with-test (:name :logior-signed-unsigned=>integer)
(checked-compile-and-assert
()
`(lambda (s u)
(declare ((unsigned-byte 64) u))
(logior (the fixnum s) u))
((-54327132 24) -54327108)
((54327132 15028999435905310454) 15028999435923161086)))
(with-test (:name :dpb-bit-overshoot)
(checked-compile-and-assert
()
`(lambda (p)
(dpb 0 (byte 1 (the (mod 95) p)) #xFFFFFFFFFFF))
((0) #xFFFFFFFFFFE)
((63) #xFFFFFFFFFFF)
((64) #xFFFFFFFFFFF)
((79) #xFFFFFFFFFFF))
(checked-compile-and-assert
()
`(lambda (p)
(dpb 0 (byte 1 (the (mod 95) p)) #xFFFFFFFFFFFFFFFF))
((0) #xFFFFFFFFFFFFFFFE)
((63) #x7FFFFFFFFFFFFFFF)
((64) #xFFFFFFFFFFFFFFFF)
((79) #xFFFFFFFFFFFFFFFF))
(checked-compile-and-assert
()
`(lambda (p)
(dpb 1 (byte 1 (the (mod 95) p)) -10))
((0) -9)
((79) -10)))
(with-test (:name :ctz-transform
:implemented-on (:vop-existsp sb-kernel:count-trailing-zeros))
(assert (find 'sb-kernel:count-trailing-zeros
(ctu:ir1-named-calls `(lambda (n)
(declare ((unsigned-byte 64) n))
(integer-length (ldb (byte 64 0) (lognor n (- n)))))
nil)))
(assert (find 'sb-kernel:count-trailing-zeros
(ctu:ir1-named-calls `(lambda (n)
(declare ((signed-byte 64) n))
(integer-length (ldb (byte 64 0) (lognor n (- n)))))
nil)))
(assert (find 'sb-kernel:count-trailing-zeros
(ctu:ir1-named-calls `(lambda (n)
(declare (fixnum n))
(integer-length (ldb (byte 64 0) (lognor n (- n)))))
nil)))
(assert (find 'sb-kernel:count-trailing-zeros
(ctu:ir1-named-calls `(lambda (n)
(declare ((signed-byte 32) n))
(integer-length (ldb (byte 64 0) (lognor n (- n)))))
nil)))
(assert (find 'sb-kernel:count-trailing-zeros
(ctu:ir1-named-calls `(lambda (n)
(declare ((unsigned-byte 63) n))
(integer-length (ldb (byte 64 0) (lognor n (- n)))))
nil)))
(assert (find 'sb-kernel:count-trailing-zeros
(ctu:ir1-named-calls `(lambda (n)
(declare ((unsigned-byte 62) n))
(integer-length (ldb (byte 64 0) (lognor n (- n)))))
nil))))
(with-test (:name :ctz)
(checked-compile-and-assert
()
`(lambda (n)
(declare ((unsigned-byte 64) n))
(integer-length (ldb (byte 64 0) (lognor n (- n)))))
((0) 64)
((1) 0)
((2) 1)
(((ash 1 63)) 63))
(checked-compile-and-assert
()
`(lambda (n)
(declare ((signed-byte 64) n))
(integer-length (ldb (byte 64 0) (lognor n (- n)))))
((0) 64)
((1) 0)
((-1) 0)
((2) 1)
((-2) 1)
(((ash 1 62)) 62)
(((ash -1 63)) 63))
(checked-compile-and-assert
()
`(lambda (n)
(declare (fixnum n))
(integer-length (ldb (byte 64 0) (lognor n (- n)))))
((0) 64)
((1) 0)
((-1) 0)
((2) 1)
((-2) 1)
(((ash 1 (- sb-vm:n-fixnum-bits 2))) (- sb-vm:n-fixnum-bits 2))
(((ash -1 (- sb-vm:n-fixnum-bits 1))) (- sb-vm:n-fixnum-bits 1))))
(with-test (:name :ash-left-add
:implemented-on (:vop-existsp sb-kernel:ash-left-add))
(assert (find 'sb-kernel:ash-left-add
(ctu:ir1-named-calls `(lambda (n)
(declare (sb-vm:signed-word n))
(+ (ash n 8) 8))
nil)))
(assert (find 'sb-kernel:ash-left-add
(ctu:ir1-named-calls `(lambda (n)
(declare (sb-vm:word n))
(+ (ash n 8) 8))
nil)))
(assert (find 'sb-kernel:ash-left-add
(ctu:ir1-named-calls `(lambda (n)
(+ (ash n 8) 8))))))
(with-test (:name :ash-left-add)
(checked-compile-and-assert
()
`(lambda (n)
(declare ((unsigned-byte 64) n))
(+ (ash n 8) 8))
((0) 8)
((1) (+ (ash 1 8) 8))
((#xFFFFFFFFFFFFFFF) (+ (ash #xFFFFFFFFFFFFFFF 8) 8))
((#xFFFFFFFFFFFFFFFF) (+ (ash #xFFFFFFFFFFFFFFFF 8) 8)))
(checked-compile-and-assert
()
`(lambda (n)
(declare ((signed-byte 64) n))
(+ (ash n 8) 8))
((0) 8)
((1) (+ (ash 1 8) 8))
((-1) (+ (ash -1 8) 8))
((#xFFFFFFFFFFFFFFF) (+ (ash #xFFFFFFFFFFFFFFF 8) 8))
((#x-FFFFFFFFFFFFFFF) (+ (ash #x-FFFFFFFFFFFFFFF 8) 8))
((#x7FFFFFFFFFFFFFFF) (+ (ash #x7FFFFFFFFFFFFFFF 8) 8))
(((- (expt 2 63))) (+ (ash (- (expt 2 63)) 8) 8)))
(checked-compile-and-assert
()
`(lambda (n)
(+ (ash n 8) 8))
((0) 8)
((1) (+ (ash 1 8) 8))
((-1) (+ (ash -1 8) 8))
((#xFFFFFFFFFFFFFFF) (+ (ash #xFFFFFFFFFFFFFFF 8) 8))
((#x-FFFFFFFFFFFFFFF) (+ (ash #x-FFFFFFFFFFFFFFF 8) 8))
((#xFFFFFFFFFFFFFFFF) (+ (ash #xFFFFFFFFFFFFFFFF 8) 8))
((#x7FFFFFFFFFFFFFFF) (+ (ash #x7FFFFFFFFFFFFFFF 8) 8))
(((- (expt 2 63))) (+ (ash (- (expt 2 63)) 8) 8))))
(with-test (:name :ash-right-two-words-transform
:implemented-on (:vop-existsp sb-kernel:ash-right-two-words))
(assert (find 'sb-kernel:ash-right-two-words
(ctu:ir1-named-calls `(lambda (n)
(logand (ash n -8) most-positive-fixnum))
nil)))
(assert (find 'sb-kernel:ash-right-two-words
(ctu:ir1-named-calls `(lambda (n s)
(declare ((integer -64 -1) s))
(logand (ash n s) most-positive-fixnum))
nil)))
(assert (find 'sb-kernel:ash-right-two-words
(ctu:ir1-named-calls `(lambda (n)
(logand (ash n -8) most-positive-word))
nil)))
(assert (find 'sb-kernel:ash-right-two-words
(ctu:ir1-named-calls `(lambda (n s)
(declare ((integer -64 -1) s))
(logand (ash n s) most-positive-word))
nil))))
(with-test (:name :ash-right-two-words)
(checked-compile-and-assert
()
`(lambda (n)
(logand (ash n -8) most-positive-fixnum))
((0) 0)
(((ash 1 10)) (ash 1 2))
(((ash -1 10)) (logand (ash -1 2) most-positive-fixnum))
((20473335672995943448) (logand 79973967472640404 most-positive-fixnum)))
(checked-compile-and-assert
()
`(lambda (n s)
(declare ((integer -64 -1) s))
(logand (ash n s) most-positive-fixnum))
((0 -10) 0)
(((ash 1 12) -10) (ash 1 2))
(((ash -1 12) -10) (logand (ash -1 2) most-positive-fixnum))
((325822690411775662515259164035444996112 -64) (logand 17662883439475955428 most-positive-fixnum)))
(checked-compile-and-assert
()
`(lambda (n)
(logand (ash n -8) most-positive-word))
((0) 0)
(((ash 1 10)) (ash 1 2))
(((ash -1 10)) (logand (ash -1 2) most-positive-word))
((20473335672995943448) (logand 79973967472640404 most-positive-word)))
(checked-compile-and-assert
()
`(lambda (n s)
(declare ((integer -64 -1) s))
(logand (ash n s) most-positive-word))
((0 -10) 0)
(((ash 1 12) -10) (ash 1 2))
(((ash -1 12) -10) (logand (ash -1 2) most-positive-word))
((325822690411775662515259164035444996112 -64) (logand 17662883439475955428 most-positive-word))))
(with-test (:name :mask-signed-field-word-move)
(checked-compile-and-assert
()
`(lambda (n)
(declare (word n))
(logand (sb-c::mask-signed-field sb-vm:n-fixnum-bits n) most-positive-word))
(((* most-positive-fixnum 2))
(logand -2 most-positive-word))))
(with-test (:name :logand-cut-constants)
;; (assert (= (count-if
;; (lambda (c)
;; (member c '(logand logtest)))
;; (ctu:ir1-named-calls `(lambda (x m)
;; (declare ((unsigned-byte 32) x)
;; ((unsigned-byte 8) m))
;; (logtest m (logand x #xFF)))
;; nil))
;; 1))
(assert (= (count 'logand
(ctu:ir1-named-calls `(lambda (m)
(declare ((unsigned-byte 8) m))
(logand m #xFFFF))
nil))
0))
#+n
(assert (= (count 'sb-c::mask-signed-field
(ctu:ir1-named-calls `(lambda (n m)
(declare ((unsigned-byte 64) n)
((unsigned-byte 8) m))
(logand m (sb-c::mask-signed-field 63 n)))
nil))
0))
(assert (= (count 'logior
(ctu:ir1-named-calls `(lambda (n)
(logand #xF0 (logior n 1)))
nil))
0))
(assert (= (count 'logxor
(ctu:ir1-named-calls `(lambda (n)
(declare ((unsigned-byte 32) n))
(logand #xF (logxor n #xF0)))
nil))
0))
(assert-type
(lambda (n)
(logand #xFF (logior n #xFF)))
(eql #xFF))
(checked-compile-and-assert
()
`(lambda (b d)
(declare ((unsigned-byte 32) b d))
(logand (the bit b)
(logior d 1)))
((0 3) 0)
((1 3) 1))
(checked-compile-and-assert
()
`(lambda (d)
(logand
73786976294838206461
(logior
(the (integer -3 -1) d)
-288230376562614601)))
((-1) 73786976294838206461)
((-3) 73786976294838206461))
(checked-compile-and-assert
()
`(lambda (s)
(logand (logior -10 s) 29953653503380140701))
((0) 29953653503380140692)
((1) 29953653503380140693)))
(with-test (:name :logand-cut-constants.2
:fails-on (or :arm :mips :ppc :sparc))
(assert (= (count-if (lambda (c)
(member c '(logand sb-kernel:two-arg-and)))
(ctu:ir1-named-calls `(lambda (n m)
(declare ((unsigned-byte 64) n)
((unsigned-byte 8) m))
(logand m (logand n #xFFFF)))
nil))
1))
#-arm
(assert (= (count-if (lambda (c)
(member c '(logand sb-kernel:two-arg-and)))
(ctu:ir1-named-calls `(lambda (x m)
(declare ((unsigned-byte 32) x)
((unsigned-byte 8) m))
(logand m (logand x #xFF)))
nil))
1)))
(with-test (:name :lognot)
(assert (= (count 'lognot
(ctu:ir1-named-calls `(lambda (x)
(declare (integer x))
(lognot (lognot x)))
nil))
0)))
(with-test (:name :constant-association
:fails-on :sbcl)
(assert (= (count-if (lambda (c)
(member c '(+ sb-kernel:two-arg-+)))
(ctu:ir1-named-calls
`(lambda (x)
(+ (the integer (1+ x)) 20))
nil))
1))
(assert (= (count-if (lambda (c)
(member c '(* sb-kernel:two-arg-*)))
(ctu:ir1-named-calls
`(lambda (x)
(* (the integer (* x 3)) 5))
nil))
1)))
(with-test (:name :0/0)
(assert-error
(/ (opaque-identity 0) (opaque-identity 0))
division-by-zero))
(with-test (:name :assoc-*-const)
(flet ((test (names form count)
(assert (= (count-if (lambda (c)
(member c names))
(ctu:ir1-named-calls form nil))
count))))
(test '(* sb-kernel:two-arg-*)
`(lambda (a b)
(declare (rational a b))
(* (* a (* b 3)) 5))
2)
(test '(* sb-kernel:two-arg-*)
`(lambda (a b)
(declare (rational a b))
(* (/ (* b 5) a) 6))
1)
(test '(* sb-kernel:two-arg-*)
`(lambda (a)
(declare (rational a))
(* (/ (* a 5) 4) 6))
1)
(test '(* sb-kernel:two-arg-*)
`(lambda (a)
(declare (rational a))
(* (abs (* a 5)) 6))
1)
(test '(* sb-kernel:two-arg-*)
`(lambda (a b)
(declare (rational a b))
(* (* a 3) (* b 5)))
2)
(test '(/ sb-kernel:two-arg-/)
`(lambda (a)
(declare (rational a))
(* (/ a 3) 6))
0)
(test '(ash)
`(lambda (a)
(* (ash a 3) 5))
0)
;; (test '(* sb-kernel:two-arg-*)
;; `(lambda (a s)
;; (declare (unsigned-byte s))
;; (* (ash (* a 3) s) 5))
;; 1)
;; (test '(* sb-kernel:two-arg-* ash)
;; `(lambda (a)
;; (ash (* a 3) 2))
;; 1)
(test '(truncate sb-kernel::truncate1)
`(lambda (a)
(declare (integer a))
(values (truncate (* a 9) 3)))
0)
(test '(floor sb-kernel::floor1)
`(lambda (a)
(declare (integer a))
(values (floor (* a 9) 3)))
0)
(test '(* sb-kernel:two-arg-*)
`(lambda (a)
(declare (rational a))
(values (truncate (* a 3) 9)))
0)
(assert-type
(lambda (a)
(declare (integer a))
(rem (* a 20) 10))
(eql 0))
(test '(truncate sb-kernel::truncate1)
`(lambda (a)
(declare (integer a))
(values (truncate (truncate a 10) 20)))
1)
(test '(floor sb-kernel::floor1)
`(lambda (a)
(declare (integer a))
(values (floor (floor a 10) 20)))
1)
(checked-compile-and-assert
()
`(lambda (v)
(declare (integer v))
(values (round (round v -94) 40)))
((2396371438047407363) -637332829267928))
(checked-compile-and-assert
()
`(lambda (v)
(declare (integer v))
(values (ceiling (ceiling v 7) -3)))
((15) -1))
(checked-compile-and-assert
()
`(lambda (v)
(declare (integer v))
(values (floor (abs (floor v 5)) 4)))
((-19) 1))
(checked-compile-and-assert
()
`(lambda (v)
(declare (integer v))
(values (ceiling (abs (ceiling v -5)) 10)))
((1) 0))
(test '(floor sb-kernel::floor1)
`(lambda (a)
(declare (unsigned-byte a))
(values (floor (abs (floor a -10)) 20)))
1)
(test '(ceiling sb-kernel::ceiling1)
`(lambda (a)
(declare (unsigned-byte a))
(values (ceiling (abs (ceiling a 10)) 20)))
1)))
(with-test (:name :assoc-*-const.2)
(flet ((test (names form count)
(assert (= (count-if (lambda (c)
(member c names))
(ctu:ir1-named-calls form nil))
count))))
(test '(truncate sb-kernel::truncate1 ash sb-c::ash-right)
`(lambda (a)
(declare (unsigned-byte a))
(values (truncate (ash a -2) 5)))
1)
(test '(floor sb-kernel::floor1 ash sb-c::ash-right)
`(lambda (a)
(values (floor (ash a -2) 5)))
1)
(test '(ash sb-c::ash-right)
`(lambda (n)
(declare (integer n))
(ash (floor n 5) -2))
0)
(test '(ash sb-c::ash-right)
`(lambda (n)
(declare (unsigned-byte n))
(ash (truncate n 5) -2))
0)
(test '(truncate sb-kernel::truncate1)
`(lambda (a)
(declare (integer a))
(values (truncate (truncate 9 a) 3)))
1)
(checked-compile-and-assert
()
`(lambda (v)
(declare (integer v))
(values (truncate (abs (truncate 9 v)) -3)))
((2) -1)
((-10) 0))))
(with-test (:name :assoc-*-const.3)
(flet ((test (names form count)
(assert (= (count-if (lambda (c)
(member c names))
(ctu:ir1-named-calls form nil))
count))))
(test '(* sb-kernel:two-arg-*)
`(lambda (a)
(declare (rational a))
(* (+ (* a 3) 3) 5))
1)
(test '(* sb-kernel:two-arg-*)
`(lambda (a)
(declare (rational a))
(* (abs (- (* a 3) 3)) 5))
1)
(checked-compile-and-assert
()
`(lambda (a)
(declare (integer a))
(* (+ (abs (* -3 a)) 3) -5))
((5) -90))
(checked-compile-and-assert
()
`(lambda (a)
(declare (integer a))
(values (floor (abs (floor 10 a)) 5)))
((-9) 0))
(checked-compile-and-assert
()
`(lambda (p)
(declare (integer p))
(values (ceiling (ceiling (* 10 p) -31)
41/50)))
((-97) 40))
(checked-compile-and-assert
()
`(lambda (n)
(declare (integer n))
(values (truncate (truncate n 190) 16/25)))
((46945) 385))
(checked-compile-and-assert
()
`(lambda (n)
(declare (rational n))
(values (truncate (truncate 4 n) 3)))
((1/3) 4))
(checked-compile-and-assert
()
`(lambda (n)
(declare (integer n))
(* (/ 23 (* 37 n)) -12))
((2) -138/37))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (n)
(* (the integer (* #c(1 2) n)) 3))
((#c(1 -2)) 15)
((2) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (n)
(* (the integer (* n 4)) 3))
((1/2) 6))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (n)
(* (the integer (* #c(1 2) n)) 3))
((#c(1 -2)) 15)
((2) (condition 'type-error)))
(checked-compile-and-assert
(:optimize :safe)
`(lambda (n)
(* (the integer (* n 0)) 3))
((#c(1 -2)) 0))))
(with-test (:name :logtest-vop
:implemented-on (and (:vop-existsp logtest) (not :ppc64)))
(assert (= (count 'logtest
(ctu:ir1-named-calls `(lambda (a)
(zerop (logand a 1)))
nil))
1))
(assert (= (count 'logtest
(ctu:ir1-named-calls `(lambda (a)
(declare (fixnum a))
(plusp (logand a 6)))
nil))
1)))
(with-test (:name :logtest
:fails-on :ppc64)
(checked-compile-and-assert
()
`(lambda (p1)
(declare (type (integer -845794755782386 1048630) p1))
(logtest p1 12115639945877374832))
((-845794755782386) t)
((145551) nil))
(checked-compile-and-assert
()
`(lambda (a)
(logtest a (the (unsigned-byte 30) a)))
((8) t)
((0) nil)))
(with-test (:name :logtest-integer-fixnum
:implemented-on (or :arm64 :x86-64 :x86))
(assert (not (ctu:ir1-named-calls `(lambda (x y)
(declare (integer x)
(fixnum y))
(logtest x y))))))
(with-test (:name :ash-mod)
(checked-compile-and-assert
()
`(lambda (a b)
(declare ((integer -3 3) b))
(logand #xF (+ (ash a b) 1)))
((-1 3) 9)
((-1 -3) 0)
((1 -3) 1))
(checked-compile-and-assert
()
`(lambda (a b)
(declare (fixnum a b))
(logand most-positive-word (ash a b)))
((1 2) 4)
((10 -2) 2)
((1 sb-vm:n-word-bits) 0)
((-1 sb-vm:n-word-bits) 0)
((1 (- sb-vm:n-word-bits)) 0)
((-1 (- sb-vm:n-word-bits)) most-positive-word))
(checked-compile-and-assert
()
`(lambda (a b)
(declare (fixnum a b))
(logand most-positive-word (ash a (- b))))
((1 -2) 4)
((10 2) 2)
((1 (- sb-vm:n-word-bits)) 0)
((-1 (- sb-vm:n-word-bits)) 0)
((1 sb-vm:n-word-bits) 0)
((-1 sb-vm:n-word-bits) most-positive-word)))
(with-test (:name :division-float-0-type)
(assert-type
(lambda (x y)
(declare ((real 0) x y))
(/ x y))
(real 0)))
(with-test (:name :floor/ceiling-to-truncate)
(assert (= (count-if (lambda (c)
(member c '(truncate)))
(ctu:ir1-named-calls
`(lambda (x y)
(declare ((real 0 *) x y))
(floor x y))
nil))
1))
(assert (= (count-if (lambda (c)
(member c '(truncate)))
(ctu:ir1-named-calls
`(lambda (x y)
(declare ((real * 0) x y))
(floor x y))
nil))
1))
(assert (= (count-if (lambda (c)
(member c '(truncate)))
(ctu:ir1-named-calls
`(lambda (x y)
(declare ((real * 0) x)
((real 0 *) y))
(ceiling x y))
nil))
1)))
(with-test (:name :range<-empty)
(if (vop-existsp 'sb-kernel:range<<=)
(assert-type
(lambda (v)
(declare ((integer -50 0) v))
(> v
(if (> v -30)
1
-10)))
null)
(assert-type
(lambda (v)
(declare ((integer -50 0) v))
(> v
(if (> v -30)
1
-10)))
boolean)))
(with-test (:name :ash-left-bignum)
(checked-compile-and-assert
()
`(lambda (b s)
(declare (bignum b)
((member -40 25) s))
(logand #xffffffffffff (ash b s)))
((-1422907942930057474717222 25) 75401170780160)
((-1422907942930057474717222 -40) 280180849475450)))
(with-test (:name :truncate-ratios-by-float)
(assert-type
(lambda (r)
(declare ((rational 9241088767394112609508907202529414093/970467704224781278
9241088767394112609508907202529414093/970467704224781277)
r))
(truncate r 1.0))
(values (eql 9522303959679631360) (eql 0.0) &optional))
(assert-type
(lambda (x)
(declare ((single-float 0.0 0.0) x))
(nth-value 1 (truncate x)))
(single-float 0.0 0.0))
(assert-type
(lambda (v1)
(declare ((rational (96106637441700886132) (96106637441700886133)) v1))
(truncate v1 1.0))
(values (integer 96106640126225940480 96106640126225940480) (member 0.0) &optional)))
(with-test (:name :complex-division-minus-zero)
(loop for x in (opaque-identity '(0 0.0 #c(0.0 0.0)))
do (assert (eql (/ x #c(-1.0 3))
(opaque-identity #C(0.0 -0.0)))))
(loop for x in (opaque-identity '(2 2.0 #c(2.0 0.0)))
do (assert (eql (/ x #c(0.0 1.0))
(opaque-identity #C(0.0 -2.0)))))
(checked-compile-and-assert
()
`(lambda (f c)
(declare (single-float f)
((complex single-float) c))
(/ f c))
((-2.0 #c(0.0 1.0)) #C(0.0 2.0))
((0.0 #c(1 -3.0)) (/ 0 #c(1 -3.0))))
(checked-compile-and-assert
()
`(lambda (f c)
(declare (real f)
((complex single-float) c))
(/ f c))
((-2.0 #c(0.0 1.0)) #C(0.0 2.0))
((0.0 #c(1 -3.0)) (/ 0 #c(1 -3.0)))
((0 #C(3.0 -4)) (/ 0.0 #C(3.0 -4))))
(checked-compile-and-assert
()
`(lambda (c)
(- (/ -3.0 c)))
((#c(0 3.0)) (- (opaque-identity (/ (opaque-identity -3.0)
(opaque-identity #c(0 3.0)))))))
(checked-compile-and-assert
()
`(lambda (a b)
(declare ((complex float) a b))
(/ (- a) (- b)))
((#c(0.0 3.0) #c(0.0 3.0))
(/ (opaque-identity (- #c(0.0 3.0)))
(opaque-identity (- #c(0.0 3.0))))))
(checked-compile-and-assert
()
`(lambda (n)
(declare (double-float n))
(/ n #C(1.0 2.0)))
((5d0) #C(1.0d0 -2.0d0))))
(with-test (:name :truncate+/+complex)
(checked-compile-and-assert
()
`(lambda (a b)
(values (truncate (/ a b))))
((#C(3 6) #C(1 2)) 3)))
(with-test (:name :ash-into-word
:implemented-on (:vop-existsp sb-kernel:ash-right-two-words))
(assert (not (ctu:ir1-named-calls
`(lambda (x)
(ash (the (unsigned-byte ,(* 2 sb-vm:n-word-bits)) x)
,(- sb-vm:n-word-bits))))))
(assert (not (ctu:ir1-named-calls
`(lambda (x)
(ash (the (signed-byte ,(* 2 sb-vm:n-word-bits)) x)
,(- sb-vm:n-word-bits))))))
(assert (not (ctu:ir1-named-calls
`(lambda (x p3)
(declare (type (integer * ,(- sb-vm:n-word-bits)) p3)
((unsigned-byte ,(* (- sb-vm:n-word-bits 4) 2)) x))
(ash x p3))))))
(with-test (:name :truncate-by-zero-type)
(assert-type
(lambda (n x)
(declare ((integer -9 9) n)
((and integer (not (member 1 -1))) x))
(truncate n x))
(values (integer -4 4) (integer -9 9) &optional))
(assert-type
(lambda (n x)
(declare ((integer -9 9) n)
((and integer (not (member 1 -1))) x))
(/ n x))
(rational -9/2 9/2)))
(with-test (:name :floor-by-integer-type)
(assert-type
(lambda (n x)
(declare ((integer -5 5) n)
(integer x))
(floor n x))
(values (integer -5 5) integer &optional))
(assert-type
(lambda (n x)
(declare ((rational -6 5) n)
(integer x))
(ceiling n x))
(values (integer -6 6) rational &optional))
(assert-type
(lambda (a b)
(declare ((integer 4 5) a)
((integer -2 3) b))
(truncate a b))
(values (or (integer -5 -2) (integer 1 5)) (mod 3) &optional))
(assert-type
(lambda (a b)
(declare ((rational -5 4) a)
(integer b))
(truncate a b))
(values (integer -5 5) (rational -5 4) &optional)))
(with-test (:name :ash-modfx-constant-fold)
(checked-compile-and-assert
()
`(lambda (b)
(declare (fixnum b))
(when (eq b (1- sb-vm:n-fixnum-bits))
(ldb (byte sb-vm:n-fixnum-bits 0) (ash 1 b))))
(((1- sb-vm:n-fixnum-bits)) (ash 1 (1- sb-vm:n-fixnum-bits)))
((0) nil)))
(with-test (:name :mask-signed-field-fixnum-result)
(checked-compile-and-assert
()
`(lambda (x)
(truly-the fixnum (sb-c::mask-signed-field sb-vm:n-word-bits x)))
(((* most-positive-fixnum (ash 2 sb-vm:n-fixnum-tag-bits)))
(ash -2 sb-vm:n-fixnum-tag-bits))
((10)
10)))
(with-test (:name :ash-inverted)
(checked-compile-and-assert
()
`(lambda (x y)
(declare ((integer -5 5) y)
((signed-byte 16) x))
(ash x (- y)))
((1 -5) 32)))
(with-test (:name :+/-rationals
:skipped-on (not :arm64)) ;; FIXME: others translate to generic-+
(flet ((test (form &rest names)
(let ((calls (ctu:ir1-named-calls form)))
(if names
(loop for (name count) in names
do (assert (= (count name calls) count)))
(assert (not calls))))))
(test '(lambda (a b)
(declare (rational a b))
(- a (- a b))))
(test '(lambda (a b)
(declare (rational a b))
(+ a (- b a))))
(test '(lambda (a b)
(declare (rational a b))
(+ (- b a) a)))
(test '(lambda (a b)
(declare (rational a b))
(- (+ a b) a)))
(test '(lambda (a b)
(declare (rational a b))
(- (+ b a) a)))
(test '(lambda (a b)
(declare (rational a b))
(- (- a b) a))
'(sb-kernel:%negate 1))
(test '(lambda (a b)
(declare (rational a b))
(- a (+ a b)))
'(sb-kernel:%negate 1))
(test '(lambda (a b c)
(declare (rational a b c))
(- (+ a b) (+ a c)))
'(sb-kernel:two-arg-- 1)
'(sb-kernel:two-arg-+ 0))
(test '(lambda (a b c)
(declare (rational a b c))
(- (+ a b) (- a c)))
'(sb-kernel:two-arg-- 0)
'(sb-kernel:two-arg-+ 1))
(test '(lambda (a b c)
(declare (rational a b c))
(- (- a b) (- a c)))
'(sb-kernel:two-arg-- 1)
'(sb-kernel:two-arg-+ 0))
(test '(lambda (a b c)
(declare (rational a b c))
(+ (- b a) (- a c)))
'(sb-kernel:two-arg-- 1)
'(sb-kernel:two-arg-+ 0))
(test '(lambda (a b c)
(declare (rational a b c))
(- (- b a) (- c a)))
'(sb-kernel:two-arg-- 1)
'(sb-kernel:two-arg-+ 0))
(test '(lambda (a b c)
(declare (rational a b c))
(+ (+ a b) (- c a)))
'(sb-kernel:two-arg-- 0)
'(sb-kernel:two-arg-+ 1))
(test '(lambda (a b c)
(declare (rational a b c))
(- (- a b) (+ a c)))
'(sb-kernel:two-arg-- 0)
'(sb-kernel:%negate 1)
'(sb-kernel:two-arg-+ 1))
(test '(lambda (a b)
(declare (rational a b))
(- (- a) (- b a)))
'(sb-kernel:two-arg-- 0)
'(sb-kernel:%negate 1)
'(sb-kernel:two-arg-+ 0))))
(with-test (:name :overflow+-word
:implemented-on (:vop-existsp sb-c::overflow+))
(checked-compile-and-assert
(:allow-notes nil :optimize :safe)
`(lambda (x y)
(declare (type (integer 0 ,(ash 1 (- sb-vm:n-word-bits 2))) x)
(type (integer 0 5) y))
(the fixnum (+ x x y)))
((3 4) 10)
(('h 5) (condition 'type-error)))
(checked-compile-and-assert
(:allow-notes nil :optimize :safe)
`(lambda (x y)
(declare (type (integer 0 ,(ash 1 (- sb-vm:n-word-bits 2))) x)
(type (integer 0 5) y))
(the fixnum (- y (+ x x))))
((1 5) 3)
(('h 0) (condition 'type-error)))
(checked-compile-and-assert
(:allow-notes nil :optimize :safe)
`(lambda (x y)
(declare (sb-vm:word x y))
(< (the sb-vm:word (+ x x)) y))
((5 11) t)
((5 10) nil)
(((ash 1 (1- sb-vm:n-word-bits)) 0) (condition 'type-error))))
(with-test (:name :cut-to-width-omit-logand)
(checked-compile-and-assert
()
`(lambda (d)
(logand (lognot (logand d -3)) 1))
((-7726172277034401953) 0)
((0) 1)))
Reference in a new issue View git blame Copy permalink