X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=577c4346e29a2f17cb8a8bc1633b984114529f7f;hb=19319c931fc1636835dbef71808cc10e252bcf45;hp=ee6905e866a6fdfc2ef5735e506a5d9b9a5809b8;hpb=20102d9bd3c62691cc2c27725ff7ffdcab54ab2b;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index ee6905e..577c434 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1,4 +1,5 @@ + ;;;; various compiler tests without side effects ;;;; This software is part of the SBCL system. See the README file for @@ -3718,63 +3719,64 @@ ;; 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) @@ -4843,19 +4845,115 @@ ;; 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)))) + (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)))