+
;;;; various compiler tests without side effects
;;;; This software is part of the SBCL system. See the README file for
(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)
-(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)))
(ctu:assert-no-consing (funcall f))))
(with-test (:name :array-type-predicates)
- (dolist (et sb-kernel::*specialized-array-element-types*)
+ (dolist (et (list* '(integer -1 200) '(integer -256 1)
+ '(integer 0 128)
+ '(integer 0 (128))
+ '(double-float 0d0 (1d0))
+ '(single-float (0s0) (1s0))
+ '(or (eql 1d0) (eql 10d0))
+ '(member 1 2 10)
+ '(complex (member 10 20))
+ '(complex (member 10d0 20d0))
+ '(complex (member 10s0 20s0))
+ '(or integer double-float)
+ '(mod 1)
+ #+sb-unicode 'extended-char
+ sb-kernel::*specialized-array-element-types*))
(when et
(let* ((v (make-array 3 :element-type et))
(fun (compile nil `(lambda ()
;; Like all tests trying to verify that something doesn't blow up
;; compile-times this is bound to be a bit brittle, but at least
;; here we try to establish a decent baseline.
- (flet ((time-it (lambda want)
- (gc :full t) ; let's keep GCs coming from other code out...
- (let* ((start (get-internal-run-time))
- (fun (dotimes (internal-time-resolution-too-low-workaround
- #+win32 10
- #-win32 0
- (compile nil lambda))
- (compile nil lambda)))
- (end (get-internal-run-time))
- (got (funcall fun)))
- (unless (eql want got)
- (error "wanted ~S, got ~S" want got))
- (- end start))))
- (let ((time-1/simple
- ;; This is mostly identical as the next one, but doesn't create
- ;; hairy unions of numeric types.
- (time-it `(lambda ()
- (labels ((bar (baz bim)
- (let ((n (+ baz bim)))
- (* n (+ n 1) bim))))
- (let ((a (bar 1 1))
- (b (bar 1 1))
- (c (bar 1 1)))
- (- (+ a b) c))))
- 6))
- (time-1/hairy
- (time-it `(lambda ()
- (labels ((bar (baz bim)
- (let ((n (+ baz bim)))
- (* n (+ n 1) bim))))
- (let ((a (bar 1 1))
- (b (bar 1 5))
- (c (bar 1 15)))
- (- (+ a b) c))))
- -3864)))
- (assert (>= (* 10 (1+ time-1/simple)) time-1/hairy)))
- (let ((time-2/simple
- ;; This is mostly identical as the next one, but doesn't create
- ;; hairy unions of numeric types.
- (time-it `(lambda ()
- (labels ((sum-d (n)
- (let ((m (truncate 999 n)))
- (/ (* n m (1+ m)) 2))))
- (- (+ (sum-d 3)
- (sum-d 3))
- (sum-d 3))))
- 166833))
- (time-2/hairy
- (time-it `(lambda ()
- (labels ((sum-d (n)
- (let ((m (truncate 999 n)))
- (/ (* n m (1+ m)) 2))))
- (- (+ (sum-d 3)
- (sum-d 5))
- (sum-d 15))))
- 233168)))
- (assert (>= (* 10 (1+ time-2/simple)) time-2/hairy)))))
+ (labels ((time-it (lambda want &optional times)
+ (gc :full t) ; let's keep GCs coming from other code out...
+ (let* ((start (get-internal-run-time))
+ (iterations 0)
+ (fun (if times
+ (loop repeat times
+ for result = (compile nil lambda)
+ finally (return result))
+ (loop for result = (compile nil lambda)
+ do (incf iterations)
+ until (> (get-internal-run-time) (+ start 10))
+ finally (return result))))
+ (end (get-internal-run-time))
+ (got (funcall fun)))
+ (unless (eql want got)
+ (error "wanted ~S, got ~S" want got))
+ (values (- end start) iterations)))
+ (test-it (simple result1 complex result2)
+ (multiple-value-bind (time-simple iterations)
+ (time-it simple result1)
+ (assert (>= (* 10 (1+ time-simple))
+ (time-it complex result2 iterations))))))
+ ;; This is mostly identical as the next one, but doesn't create
+ ;; hairy unions of numeric types.
+ (test-it `(lambda ()
+ (labels ((bar (baz bim)
+ (let ((n (+ baz bim)))
+ (* n (+ n 1) bim))))
+ (let ((a (bar 1 1))
+ (b (bar 1 1))
+ (c (bar 1 1)))
+ (- (+ a b) c))))
+ 6
+ `(lambda ()
+ (labels ((bar (baz bim)
+ (let ((n (+ baz bim)))
+ (* n (+ n 1) bim))))
+ (let ((a (bar 1 1))
+ (b (bar 1 5))
+ (c (bar 1 15)))
+ (- (+ a b) c))))
+ -3864)
+ (test-it `(lambda ()
+ (labels ((sum-d (n)
+ (let ((m (truncate 999 n)))
+ (/ (* n m (1+ m)) 2))))
+ (- (+ (sum-d 3)
+ (sum-d 3))
+ (sum-d 3))))
+ 166833
+ `(lambda ()
+ (labels ((sum-d (n)
+ (let ((m (truncate 999 n)))
+ (/ (* n m (1+ m)) 2))))
+ (- (+ (sum-d 3)
+ (sum-d 5))
+ (sum-d 15))))
+ 233168)))
(with-test (:name :regression-1.0.44.34)
(compile nil '(lambda (z &rest args)
(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)
;; win32 is very specific about the order in which catch blocks
;; must be allocated on the stack
-(with-test (:name :bug-121581169)
+(with-test (:name :bug-1072739)
(let ((f (compile nil
`(lambda ()
(STRING=
"23a%b%")))))
(assert (funcall f))))
-(defvar *global-equal-function* #'equal
- "Global reference to the EQUAL function. This reference is funcalled
-in order to prevent the compiler from inlining the call.")
-
-(defmacro equal-reduction-macro ()
+(with-test (:name :equal-equalp-transforms)
(let* ((s "foo")
(bit-vector #*11001100)
(values `(nil 1 2 "test"
(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))))
+ ,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
- `(progn
- ,@(loop
- for x in values
- append (loop
- for y in values
- collect (let ((result1-sym (gensym "RESULT1-"))
- (result2-sym (gensym "RESULT2-")))
- `(let ((,result1-sym (equal ,x ,y))
- (,result2-sym (funcall *global-equal-function* ,x ,y)))
- (assert (or (and ,result1-sym ,result2-sym)
- (and (not ,result1-sym) (not ,result2-sym)))))))))))
-
-(with-test (:name :equal-reduction)
- (equal-reduction-macro))
+ (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.
+ (let ((limit 33))
+ (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 limit) 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 limit)
+ (test-function (make-function i) i)))))
+
+(with-test (:name :apply-aref)
+ (flet ((test (form)
+ (let (warning)
+ (handler-bind ((warning (lambda (c) (setf warning c))))
+ (compile nil `(lambda (x y) (setf (apply #'sbit x y) 10))))
+ (assert (not warning)))))
+ (test `(lambda (x y) (setf (apply #'aref x y) 21)))
+ (test `(lambda (x y) (setf (apply #'bit x y) 1)))
+ (test `(lambda (x y) (setf (apply #'sbit x y) 0)))))
+
+(with-test (:name :warn-on-the-values-constant)
+ (multiple-value-bind (fun warnings-p failure-p)
+ (compile nil
+ ;; The compiler used to elide this test without
+ ;; noting that the type demands multiple values.
+ '(lambda () (the (values fixnum fixnum) 1)))
+ (declare (ignore warnings-p))
+ (assert (functionp fun))
+ (assert failure-p)))
+
+;; quantifiers shouldn't cons themselves.
+(with-test (:name :quantifiers-no-consing)
+ (let ((constantly-t (lambda (x) x t))
+ (constantly-nil (lambda (x) x nil))
+ (list (make-list 1000 :initial-element nil))
+ (vector (make-array 1000 :initial-element nil)))
+ (macrolet ((test (quantifier)
+ (let ((function (make-symbol (format nil "TEST-~A" quantifier))))
+ `(flet ((,function (function sequence)
+ (,quantifier function sequence)))
+ (ctu:assert-no-consing (,function constantly-t list))
+ (ctu:assert-no-consing (,function constantly-nil vector))))))
+ (test some)
+ (test every)
+ (test notany)
+ (test notevery))))
+
+(with-test (:name :propagate-complex-type-tests)
+ (flet ((test (type value)
+ (let ((ftype (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (x)
+ (if (typep x ',type)
+ x
+ ',value))))))
+ (assert (typep ftype `(cons (eql function))))
+ (assert (= 3 (length ftype)))
+ (let* ((return (third ftype))
+ (rtype (second return)))
+ (assert (typep return `(cons (eql values)
+ (cons t
+ (cons (eql &optional)
+ null)))))
+ (assert (and (subtypep rtype type)
+ (subtypep type rtype)))))))
+ (mapc (lambda (params)
+ (apply #'test params))
+ `(((unsigned-byte 17) 0)
+ ((member 1 3 5 7) 5)
+ ((or symbol (eql 42)) t)))))
+
+(with-test (:name :constant-fold-complex-type-tests)
+ (assert (equal (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (x)
+ (if (typep x '(member 1 3))
+ (typep x '(member 1 3 15))
+ t))))
+ `(function (t) (values (member t) &optional))))
+ (assert (equal (sb-kernel:%simple-fun-type
+ (compile nil `(lambda (x)
+ (declare (type (member 1 3) x))
+ (typep x '(member 1 3 15)))))
+ `(function ((or (integer 1 1) (integer 3 3)))
+ (values (member t) &optional)))))
+
+(with-test (:name :quietly-row-major-index-no-dimensions)
+ (assert (handler-case
+ (compile nil `(lambda (x) (array-row-major-index x)))
+ (warning () nil))))
+
+(with-test (:name :array-rank-transform)
+ (compile nil `(lambda (a) (array-rank (the an-imaginary-type a)))))
+
+(with-test (:name (:array-rank-fold :bug-1252108))
+ (let (noted)
+ (handler-bind ((sb-ext::code-deletion-note
+ (lambda (x)
+ (setf noted x))))
+ (compile nil
+ `(lambda (a)
+ (typecase a
+ ((array t 2)
+ (when (= (array-rank a) 3)
+ (array-dimension a 2)))))))
+ (assert noted)))
+
+(with-test (:name :upgraded-array-element-type-undefined-type)
+ (raises-error? (upgraded-array-element-type 'an-undefined-type))
+ (raises-error? (upgraded-array-element-type '(and fixnum an-undefined-type))))