X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=21adaf5066ca99464073dc4e6ab40312b501fc88;hb=062283b901155792f65775491aea51481c56faaa;hp=f50322ee32cc462b6194f2494b03648d789554db;hpb=f32ee7df37cdc62596e849c079f365000424a712;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index f50322e..21adaf5 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1,3 +1,4 @@ + ;;;; various compiler tests without side effects ;;;; This software is part of the SBCL system. See the README file for @@ -149,10 +150,11 @@ ;;; 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.) @@ -1441,7 +1443,9 @@ (declare (type (alien (* (unsigned 8))) a) (type (unsigned-byte 32) i)) (deref a i)))) - (compiler-note () (error "The code is not optimized."))) + (compiler-note (c) + (unless (search "%ASH/RIGHT" (first (simple-condition-format-arguments c))) + (error "The code is not optimized.")))) (handler-case (compile nil '(lambda (x) @@ -1771,7 +1775,7 @@ (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) @@ -2982,8 +2986,8 @@ (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) @@ -3087,7 +3091,7 @@ (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))) @@ -4402,12 +4406,494 @@ (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) + (let ((p1 #'upper-case-p)) + (funcall + (lambda (g) + (funcall p1 g)))) + (let ((p2 #'(lambda (char) (upper-case-p char)))) + (funcall p2 s))))) + +(with-test (:name (:bug-504121 :optional-missing)) + (compile nil `(lambda (s) + (let ((p1 #'upper-case-p)) + (funcall + (lambda (g &optional x) + (funcall p1 g)))) + (let ((p2 #'(lambda (char) (upper-case-p char)))) + (funcall p2 s))))) + +(with-test (:name (:bug-504121 :optional-superfluous)) + (compile nil `(lambda (s) + (let ((p1 #'upper-case-p)) + (funcall + (lambda (g &optional x) + (funcall p1 g)) + #\1 2 3)) + (let ((p2 #'(lambda (char) (upper-case-p char)))) + (funcall p2 s))))) + +(with-test (:name (:bug-504121 :key-odd)) + (compile nil `(lambda (s) + (let ((p1 #'upper-case-p)) + (funcall + (lambda (g &key x) + (funcall p1 g)) + #\1 :x)) + (let ((p2 #'(lambda (char) (upper-case-p char)))) + (funcall p2 s))))) + +(with-test (:name (:bug-504121 :key-unknown)) + (compile nil `(lambda (s) + (let ((p1 #'upper-case-p)) + (funcall + (lambda (g &key x) + (funcall p1 g)) + #\1 :y 2)) + (let ((p2 #'(lambda (char) (upper-case-p char)))) + (funcall p2 s))))) + +(with-test (:name :bug-1181684) + (compile nil `(lambda () + (let ((hash #xD13CCD13)) + (setf hash (logand most-positive-word + (ash hash 5))))))) + +(with-test (:name (:local-&optional-recursive-inline :bug-1180992)) + (compile nil + `(lambda () + (labels ((called (&optional a)) + (recursed (&optional b) + (called) + (recursed))) + (declare (inline recursed called)) + (recursed))))) + +(with-test (:name :constant-fold-logtest) + (assert (equal (sb-kernel:%simple-fun-type + (compile nil `(lambda (x) + (declare (type (mod 1024) x) + (optimize speed)) + (logtest x 2048)))) + '(function ((unsigned-byte 10)) (values null &optional))))) + +;; type mismatches on LVARs with multiple potential sources used to +;; 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)) + (block nil + (handler-bind ((sb-int:type-warning + (lambda (c) + (assert + (not (search "Constant " + (simple-condition-format-control + c)))) + (return)))) + (compile nil `(lambda (x y z) + (declare (type fixnum y z)) + (aref (if x y z) 0)))) + (error "Where's my warning?"))) + +(with-test (:name (:multiple-use-lvar-interpreted-as-NIL catch)) + (block nil + (handler-bind ((style-warning + (lambda (c) + (assert + (not (position + nil + (simple-condition-format-arguments c)))) + (return)))) + (compile nil `(lambda (x y z f) + (declare (type fixnum y z)) + (catch (if x y z) (funcall f))))) + (error "Where's my style-warning?"))) + +;; Smoke test for rightward shifts +(with-test (:name (:ash/right-signed)) + (let* ((f (compile nil `(lambda (x y) + (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y) + (type sb-vm:signed-word x) + (optimize speed)) + (ash x (- y))))) + (max (ash most-positive-word -1)) + (min (- -1 max))) + (flet ((test (x y) + (assert (= (ash x (- y)) + (funcall f x y))))) + (dotimes (x 32) + (dotimes (y (* 2 sb-vm:n-word-bits)) + (test x y) + (test (- x) y) + (test (- max x) y) + (test (+ min x) y)))))) + +(with-test (:name (:ash/right-unsigned)) + (let ((f (compile nil `(lambda (x y) + (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y) + (type word x) + (optimize speed)) + (ash x (- y))))) + (max most-positive-word)) + (flet ((test (x y) + (assert (= (ash x (- y)) + (funcall f x y))))) + (dotimes (x 32) + (dotimes (y (* 2 sb-vm:n-word-bits)) + (test x y) + (test (- max x) y)))))) + +(with-test (:name (:ash/right-fixnum)) + (let ((f (compile nil `(lambda (x y) + (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y) + (type fixnum x) + (optimize speed)) + (ash x (- y)))))) + (flet ((test (x y) + (assert (= (ash x (- y)) + (funcall f x y))))) + (dotimes (x 32) + (dotimes (y (* 2 sb-vm:n-word-bits)) + (test x y) + (test (- x) y) + (test (- most-positive-fixnum x) y) + (test (+ most-negative-fixnum x) y)))))) + +;; expected failure +(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)) + (error "foo")))))) + (funcall f -31))) + +;; 5d3a728 broke something like this in CL-PPCRE +(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. + (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))))