X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=b5df3b989988b0e8781c22013d69449b237a23d3;hb=7024c08bf4d44b8eb0c555bc45783bdcefd9eb88;hp=7db4d3ae7022e2990708f89005b05f4fd9397273;hpb=89c9285a01e9ccb247198b77552d48f007d20e06;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 7db4d3a..b5df3b9 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -528,11 +528,19 @@ (funcall f y 1) (assert (equal y #*10)))) +;;; use of declared array types (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda (x) - (declare (type (simple-array (simple-string 3) (5)) x)) + (declare (type (simple-array (simple-string 3) (5)) x) + (optimize speed)) (aref (aref x 0) 0)))) +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x) + (declare (type (simple-array (simple-array bit (10)) (10)) x) + (optimize speed)) + (1+ (aref (aref x 0) 0))))) + ;;; compiler failure (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0))))))) (assert (funcall f 1d0))) @@ -774,6 +782,35 @@ (declare (type (integer 4303063 101130078) a)) (mask-field (byte 18 2) (ash a 77)))) 57132532))) +;;; rewrite the test case to get the unsigned-byte 32/64 +;;; implementation even after implementing some modular arithmetic +;;; with signed-byte 30: +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (mask-field (byte 30 2) (ash a 77)))) + 57132532))) +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (mask-field (byte 64 2) (ash a 77)))) + 57132532))) +;;; and a similar test case for the signed masking extension (not the +;;; final interface, so change the call when necessary): +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (sb-c::mask-signed-field 30 (ash a 77)))) + 57132532))) +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (sb-c::mask-signed-field 61 (ash a 77)))) + 57132532))) ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for ;;; type check regeneration @@ -1947,7 +1984,7 @@ (bit #*1001101001001 (min 12 (max 0 lv3)))))))))))) -;;; MISC.624: erronous AVER in x86's %LOGBITP VOPs +;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs (assert (eql 0 (funcall (compile @@ -2043,6 +2080,30 @@ (compiler-note () (throw :note nil))) (error "Unreachable code undetected."))) +(with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1)) + (catch :note + (handler-case + (compile nil '(lambda (x y) + (when (typep y 'fixnum) + (when (eql x y) + (unless (typep x 'fixnum) + (error "This is unreachable")) + (setq y nil))))) + (compiler-note () (throw :note nil))) + (error "Unreachable code undetected."))) + +(with-test (:name (:compiler :constraint-propagation :var-eql-to-var-2)) + (catch :note + (handler-case + (compile nil '(lambda (x y) + (when (typep y 'fixnum) + (when (eql y x) + (unless (typep x 'fixnum) + (error "This is unreachable")) + (setq y nil))))) + (compiler-note () (throw :note nil))) + (error "Unreachable code undetected."))) + ;; Reported by John Wiseman, sbcl-devel ;; Subject: [Sbcl-devel] float type derivation bug? ;; Date: Tue, 4 Apr 2006 15:28:15 -0700 @@ -2154,3 +2215,138 @@ ;;; ;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023. (compile nil '(lambda () (let* () (declare (values list))))) + + +;;; test for some problems with too large immediates in x86-64 modular +;;; arithmetic vops +(compile nil '(lambda (x) (declare (fixnum x)) + (logand most-positive-fixnum (logxor x most-positive-fixnum)))) + +(compile nil '(lambda (x) (declare (fixnum x)) + (logand most-positive-fixnum (+ x most-positive-fixnum)))) + +(compile nil '(lambda (x) (declare (fixnum x)) + (logand most-positive-fixnum (* x most-positive-fixnum)))) + +;;; bug 256.b +(assert (let (warned-p) + (handler-bind ((warning (lambda (w) (setf warned-p t)))) + (compile nil + '(lambda (x) + (list (let ((y (the real x))) + (unless (floatp y) (error "")) + y) + (integer-length x))))) + warned-p)) + +;; Dead / in safe code +(with-test (:name :safe-dead-/) + (assert (eq :error + (handler-case + (funcall (compile nil + '(lambda (x y) + (declare (optimize (safety 3))) + (/ x y) + (+ x y))) + 1 + 0) + (division-by-zero () + :error))))) + +;;; Dead unbound variable (bug 412) +(with-test (:name :dead-unbound) + (assert (eq :error + (handler-case + (funcall (compile nil + '(lambda () + #:unbound + 42))) + (unbound-variable () + :error))))) + +;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR. +(handler-bind ((sb-ext:compiler-note 'error)) + (assert + (equalp #(2 3) + (funcall (compile nil `(lambda (s p e) + (declare (optimize speed) + (simple-vector s)) + (subseq s p e))) + (vector 1 2 3 4) + 1 + 3)))) + +;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR. +(handler-bind ((sb-ext:compiler-note 'error)) + (assert + (equalp #(1 2 3 4) + (funcall (compile nil `(lambda (s) + (declare (optimize speed) + (simple-vector s)) + (copy-seq s))) + (vector 1 2 3 4))))) + +;;; bug in adding DATA-VECTOR-REF-WITH-OFFSET to x86-64 +(assert (not (mismatch #(1.0f0 2.0f0) (make-array 2 :element-type 'single-float :initial-contents (list 1.0f0 2.0f0))))) + +;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too +;;; large bignums to floats +(dolist (op '(* / + -)) + (let ((fun (compile + nil + `(lambda (x) + (declare (type (integer 0 #.(* 2 (truncate most-positive-double-float))) x)) + (,op 0.0d0 x))))) + (loop repeat 10 + do (let ((arg (random (truncate most-positive-double-float)))) + (assert (eql (funcall fun arg) + (funcall op 0.0d0 arg))))))) + +(with-test (:name :high-debug-known-function-inlining) + (let ((fun (compile nil + '(lambda () + (declare (optimize (debug 3)) (inline append)) + (let ((fun (lambda (body) + (append + (first body) + nil)))) + (funcall fun + '((foo (bar))))))))) + (funcall fun))) + +(with-test (:name :high-debug-known-function-transform-with-optional-arguments) + (compile nil '(lambda (x y) + (declare (optimize sb-c::preserve-single-use-debug-variables)) + (if (block nil + (some-unknown-function + (lambda () + (return (member x y)))) + t) + t + (error "~a" y))))) + +;;; Compiling W-P-O when the pinned objects are known to be fixnums +;;; or characters. +(compile nil '(lambda (x y) + (declare (fixnum y) (character x)) + (sb-sys:with-pinned-objects (x y) + (some-random-function)))) + +;;; *CHECK-CONSISTENCY* and TRULY-THE + +(with-test (:name :bug-423) + (let ((sb-c::*check-consistency* t)) + (handler-bind ((warning #'error)) + (flet ((make-lambda (type) + `(lambda (x) + ((lambda (z) + (if (listp z) + (let ((q (truly-the list z))) + (length q)) + (if (arrayp z) + (let ((q (truly-the vector z))) + (length q)) + (error "oops")))) + (the ,type x))))) + (compile nil (make-lambda 'list)) + (compile nil (make-lambda 'vector))))))