+
;;;; various compiler tests without side effects
;;;; This software is part of the SBCL system. See the README file for
;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
;;; a while; fixed by CSR 2002-07-18
-(multiple-value-bind (value error)
- (ignore-errors (some-undefined-function))
- (assert (null value))
- (assert (eq (cell-error-name error) 'some-undefined-function)))
+(with-test (:name :undefined-function-error)
+ (multiple-value-bind (value error)
+ (ignore-errors (some-undefined-function))
+ (assert (null value))
+ (assert (eq (cell-error-name error) 'some-undefined-function))))
;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
(error "bad RANDOM event"))))
;;; 0.8.17.28-sma.1 lost derived type information.
-(with-test (:name "0.8.17.28-sma.1" :fails-on :sparc)
+(with-test (:name :0.8.17.28-sma.1 :fails-on :sparc)
(handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c))))
(compile nil
'(lambda (x y v)
(compile nil `(lambda (x)
(declare (character x) (optimize speed))
(,name x))))
- (dolist (name '(char= char/= char< char> char<= char>= char-equal
- char-not-equal char-lessp char-greaterp char-not-greaterp
+ (dolist (name '(char= char/= char< char> char<= char>=
+ char-lessp char-greaterp char-not-greaterp
char-not-lessp))
(setf current name)
(compile nil `(lambda (x y)
(array-in-bounds-p a 5 2))))))
;;; optimizing (EXPT -1 INTEGER)
-(test-util:with-test (:name (expt minus-one integer))
+(with-test (:name (expt -1 integer))
(dolist (x '(-1 -1.0 -1.0d0))
(let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x))))))
(assert (not (ctu:find-named-callees fun)))
(let ((test-cases
'((lambda () (append 10)) (integer 10 10)
(lambda () (append nil 10)) (integer 10 10)
- (lambda (x) (append x 10)) t
+ (lambda (x) (append x 10)) (or (integer 10 10) cons)
(lambda (x) (append x (cons 1 2))) cons
(lambda (x y) (append x (cons 1 2) y)) cons
(lambda (x y) (nconc x (the list y) x)) t
- (lambda (x y) (print (length y)) (append x y)) sequence)))
+ (lambda (x y) (nconc (the atom x) y)) t
+ (lambda (x y) (nconc (the (or null (eql 10)) x) y)) t
+ (lambda (x y) (nconc (the (or cons vector) x) y)) cons
+ (lambda (x y) (nconc (the sequence x) y)) t
+ (lambda (x y) (print (length y)) (append x y)) sequence
+ (lambda (x y) (print (length y)) (append x y)) sequence
+ (lambda (x y) (append (the (member (a) (b)) x) y)) cons
+ (lambda (x y) (append (the (member (a) (b) c) x) y)) cons
+ (lambda (x y) (append (the (member (a) (b) nil) x) y)) t)))
(loop for (function result-type) on test-cases by #'cddr
- do (assert (equal (car (cdaddr (sb-kernel:%simple-fun-type
- (compile nil function))))
- result-type)))))
+ do (assert (sb-kernel:type= (sb-kernel:specifier-type
+ (car (cdaddr (sb-kernel:%simple-fun-type
+ (compile nil function)))))
+ (sb-kernel:specifier-type result-type))))))
(with-test (:name :bug-504121)
(compile nil `(lambda (s)
(setf hash (logand most-positive-word
(ash hash 5)))))))
-(with-test (:name (local-&optional-recursive-inline :bug-1180992))
+(with-test (:name (:local-&optional-recursive-inline :bug-1180992))
(compile nil
`(lambda ()
(labels ((called (&optional a))
;; be reported as mismatches with the value NIL. Make sure we get
;; a warning, but that it doesn't complain about a constant NIL ...
;; of type FIXNUM.
-(with-test (:name (:multiple-use-lvar-interpreted-as-NIL cast))
+(with-test (:name (:multiple-use-lvar-interpreted-as-NIL :cast))
(block nil
(handler-bind ((sb-int:type-warning
(lambda (c)
(test (+ most-negative-fixnum x) y))))))
;; expected failure
-(test-util:with-test (:name :fold-index-addressing-positive-offset
- :fails-on '(and))
+(with-test (:name :fold-index-addressing-positive-offset)
(let ((f (compile nil `(lambda (i)
(if (typep i '(integer -31 31))
(aref #. (make-array 63) (+ i 31))
(funcall f -31)))
;; 5d3a728 broke something like this in CL-PPCRE
-(test-util:with-test (:name :fold-index-addressing-potentially-negative-index)
+(with-test (:name :fold-index-addressing-potentially-negative-index)
(compile nil `(lambda (index vector)
(declare (optimize speed (safety 0))
((simple-array character (*)) vector)
((unsigned-byte 24) index))
(aref vector (1+ (mod index (1- (length vector))))))))
+
+(with-test (:name :constant-fold-ash/right-fixnum)
+ (compile nil `(lambda (a b)
+ (declare (type fixnum a)
+ (type (integer * -84) b))
+ (ash a b))))
+
+(with-test (:name :constant-fold-ash/right-word)
+ (compile nil `(lambda (a b)
+ (declare (type word a)
+ (type (integer * -84) b))
+ (ash a b))))
+
+(with-test (:name :nconc-derive-type)
+ (let ((function (compile nil `(lambda (x y)
+ (declare (type (or cons fixnum) x))
+ (nconc x y)))))
+ (assert (equal (sb-kernel:%simple-fun-type function)
+ '(function ((or cons fixnum) t) (values cons &optional))))))
+
+;; make sure that all data-vector-ref-with-offset VOPs are either
+;; specialised on a 0 offset or accept signed indices
+(with-test (:name :data-vector-ref-with-offset-signed-index)
+ (let ((dvr (find-symbol "DATA-VECTOR-REF-WITH-OFFSET" "SB-KERNEL")))
+ (when dvr
+ (assert
+ (null
+ (loop for info in (sb-c::fun-info-templates
+ (sb-c::fun-info-or-lose dvr))
+ for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
+ unless (or (typep second-arg '(cons (eql :constant)))
+ (find '(integer 0 0) third-arg :test 'equal)
+ (equal second-arg
+ `(:or ,(sb-c::primitive-type-or-lose
+ 'sb-vm::positive-fixnum)
+ ,(sb-c::primitive-type-or-lose
+ 'fixnum))))
+ collect info))))))
+
+(with-test (:name :data-vector-set-with-offset-signed-index)
+ (let ((dvr (find-symbol "DATA-VECTOR-SET-WITH-OFFSET" "SB-KERNEL")))
+ (when dvr
+ (assert
+ (null
+ (loop for info in (sb-c::fun-info-templates
+ (sb-c::fun-info-or-lose dvr))
+ for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
+ unless (or (typep second-arg '(cons (eql :constant)))
+ (find '(integer 0 0) third-arg :test 'equal)
+ (equal second-arg
+ `(:or ,(sb-c::primitive-type-or-lose
+ 'sb-vm::positive-fixnum)
+ ,(sb-c::primitive-type-or-lose
+ 'fixnum))))
+ collect info))))))
+
+(with-test (:name :maybe-inline-ref-to-dead-lambda)
+ (compile nil `(lambda (string)
+ (declare (optimize speed (space 0)))
+ (cond ((every #'digit-char-p string)
+ nil)
+ ((some (lambda (c)
+ (digit-char-p c))
+ string))))))
+
+;; the x87 backend used to sometimes signal FP errors during boxing,
+;; because converting between double and single float values was a
+;; noop (fixed), and no doubt many remaining issues. We now store
+;; the value outside pseudo-atomic, so any SIGFPE should be handled
+;; corrrectly.
+;;
+;; When it fails, this test lands into ldb.
+(with-test (:name :no-overflow-during-allocation)
+ (handler-case (eval '(cosh 90))
+ (floating-point-overflow ()
+ t)))
+
+;; unbounded integer types could break integer arithmetic.
+(with-test (:name :bug-1199127)
+ (compile nil `(lambda (b)
+ (declare (type (integer -1225923945345 -832450738898) b))
+ (declare (optimize (speed 3) (space 3) (safety 2)
+ (debug 0) (compilation-speed 1)))
+ (loop for lv1 below 3
+ sum (logorc2
+ (if (>= 0 lv1)
+ (ash b (min 25 lv1))
+ 0)
+ -2)))))
+
+;; non-trivial modular arithmetic operations would evaluate to wider results
+;; than expected, and never be cut to the right final bitwidth.
+(with-test (:name :bug-1199428-1)
+ (let ((f1 (compile nil `(lambda (a c)
+ (declare (type (integer -2 1217810089) a))
+ (declare (type (integer -6895591104928 -561736648588) c))
+ (declare (optimize (speed 2) (space 0) (safety 2) (debug 0)
+ (compilation-speed 3)))
+ (logandc1 (gcd c)
+ (+ (- a c)
+ (loop for lv2 below 1 count t))))))
+ (f2 (compile nil `(lambda (a c)
+ (declare (notinline - + gcd logandc1))
+ (declare (optimize (speed 1) (space 1) (safety 0) (debug 1)
+ (compilation-speed 3)))
+ (logandc1 (gcd c)
+ (+ (- a c)
+ (loop for lv2 below 1 count t)))))))
+ (let ((a 530436387)
+ (c -4890629672277))
+ (assert (eql (funcall f1 a c)
+ (funcall f2 a c))))))
+
+(with-test (:name :bug-1199428-2)
+ (let ((f1 (compile nil `(lambda (a b)
+ (declare (type (integer -1869232508 -6939151) a))
+ (declare (type (integer -11466348357 -2645644006) b))
+ (declare (optimize (speed 1) (space 0) (safety 2) (debug 2)
+ (compilation-speed 2)))
+ (logand (lognand a -6) (* b -502823994)))))
+ (f2 (compile nil `(lambda (a b)
+ (logand (lognand a -6) (* b -502823994))))))
+ (let ((a -1491588365)
+ (b -3745511761))
+ (assert (eql (funcall f1 a b)
+ (funcall f2 a b))))))
+
+;; win32 is very specific about the order in which catch blocks
+;; must be allocated on the stack
+(with-test (:name :bug-1072739)
+ (let ((f (compile nil
+ `(lambda ()
+ (STRING=
+ (LET ((% 23))
+ (WITH-OUTPUT-TO-STRING (G13908)
+ (PRINC
+ (LET ()
+ (DECLARE (OPTIMIZE (SB-EXT:INHIBIT-WARNINGS 3)))
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13909) (PRINC %A%B% G13909) G13909)
+ (UNBOUND-VARIABLE NIL
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13914)
+ (PRINC %A%B% G13914)
+ (PRINC "" G13914)
+ G13914)
+ (UNBOUND-VARIABLE NIL
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13913)
+ (PRINC %A%B G13913)
+ (PRINC "%" G13913)
+ G13913)
+ (UNBOUND-VARIABLE NIL
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13912)
+ (PRINC %A% G13912)
+ (PRINC "b%" G13912)
+ G13912)
+ (UNBOUND-VARIABLE NIL
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13911)
+ (PRINC %A G13911)
+ (PRINC "%b%" G13911)
+ G13911)
+ (UNBOUND-VARIABLE NIL
+ (HANDLER-CASE
+ (WITH-OUTPUT-TO-STRING (G13910)
+ (PRINC % G13910)
+ (PRINC "a%b%" G13910)
+ G13910)
+ (UNBOUND-VARIABLE NIL
+ (ERROR "Interpolation error in \"%a%b%\"
+"))))))))))))))
+ G13908)))
+ "23a%b%")))))
+ (assert (funcall f))))
+
+(with-test (:name :equal-equalp-transforms)
+ (let* ((s "foo")
+ (bit-vector #*11001100)
+ (values `(nil 1 2 "test"
+ ;; Floats duplicated here to ensure we get newly created instances
+ (read-from-string "1.1") (read-from-string "1.2d0")
+ (read-from-string "1.1") (read-from-string "1.2d0")
+ 1.1 1.2d0 '("foo" "bar" "test")
+ #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file"
+ ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)
+ ,(make-hash-table) #\a #\b #\A #\C
+ ,(make-random-state) 1/2 2/3)))
+ ;; Test all permutations of different types
+ (assert
+ (loop
+ for x in values
+ always (loop
+ for y in values
+ always
+ (and (eq (funcall (compile nil `(lambda (x y)
+ (equal (the ,(type-of x) x)
+ (the ,(type-of y) y))))
+ x y)
+ (equal x y))
+ (eq (funcall (compile nil `(lambda (x y)
+ (equalp (the ,(type-of x) x)
+ (the ,(type-of y) y))))
+ x y)
+ (equalp x y))))))
+ (assert
+ (funcall (compile
+ nil
+ `(lambda (x y)
+ (equal (the (cons (or simple-bit-vector simple-base-string))
+ x)
+ (the (cons (or (and bit-vector (not simple-array))
+ (simple-array character (*))))
+ y))))
+ (list (string 'list))
+ (list "LIST")))
+ (assert
+ (funcall (compile
+ nil
+ `(lambda (x y)
+ (equalp (the (cons (or simple-bit-vector simple-base-string))
+ x)
+ (the (cons (or (and bit-vector (not simple-array))
+ (simple-array character (*))))
+ y))))
+ (list (string 'list))
+ (list "lisT")))))
+
+(with-test (:name (restart-case optimize speed compiler-note))
+ (handler-bind ((compiler-note #'error))
+ (compile nil '(lambda ()
+ (declare (optimize speed))
+ (restart-case () (c ()))))
+ (compile nil '(lambda ()
+ (declare (optimize speed))
+ (let (x)
+ (restart-case (setf x (car (compute-restarts)))
+ (c ()))
+ x)))))
+
+(with-test (:name :copy-more-arg
+ :fails-on '(not (or :x86 :x86-64)))
+ ;; copy-more-arg might not copy in the right direction
+ ;; when there are more fixed args than stack frame slots,
+ ;; and thus end up splatting a single argument everywhere.
+ ;; Fixed on x86oids only, but other platforms still start
+ ;; their stack frames at 8 slots, so this is less likely
+ ;; to happen.
+ (labels ((iota (n)
+ (loop for i below n collect i))
+ (test-function (function skip)
+ ;; function should just be (subseq x skip)
+ (loop for i from skip below (+ skip 16) do
+ (let* ((values (iota i))
+ (f (apply function values))
+ (subseq (subseq values skip)))
+ (assert (equal f subseq)))))
+ (make-function (n)
+ (let ((gensyms (loop for i below n collect (gensym))))
+ (compile nil `(lambda (,@gensyms &rest rest)
+ (declare (ignore ,@gensyms))
+ rest)))))
+ (dotimes (i 16)
+ (test-function (make-function i) i))))