+
;;;; various compiler tests without side effects
;;;; This software is part of the SBCL system. See the README file for
(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)
(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)))
+ (compile nil '(lambda ()
+ (make-array 10
+ :element-type '(or null an-undefined-type))))
+ (compile nil '(lambda ()
+ (make-array '(10 10)
+ :element-type '(or null an-undefined-type)))))
projects / sbcl.git / blobdiff