+
;;;; 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)
(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)))
;; 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=
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))))
projects / sbcl.git / blobdiff