X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=544810257700c49eba102e98c2d0ade3e982e23e;hb=8643c93d4db277f6e1cb880a42407ff29e19f618;hp=7e53ee2d5612f878fc8f9b1b11270c8a20164c24;hpb=93db5c1b87b1cf58533c503c78401b817d7208d8;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 7e53ee2..5448102 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -1375,8 +1375,12 @@ (handler-case (compile nil '(lambda (x) (declare (optimize (speed 3) (safety 0))) (the double-float (sqrt (the double-float x))))) - (sb-ext:compiler-note () - (error "Compiler does not trust result type assertion."))) + (sb-ext:compiler-note (c) + ;; Ignore the note for the float -> pointer conversion of the + ;; return value. + (unless (string= (car (last (sb-c::simple-condition-format-arguments c))) + "") + (error "Compiler does not trust result type assertion.")))) (let ((f (compile nil '(lambda (x) (declare (optimize speed (safety 0))) @@ -1901,14 +1905,15 @@ (compile nil '(lambda (x) (declare (optimize (speed 3))) (1+ x)))) - ;; forced-to-do GENERIC-+, etc - (assert (> count0 0)) + ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note + (assert (> count0 1)) (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1)))) (compile nil '(lambda (x) (declare (optimize (speed 3))) (check-type x fixnum) (1+ x)))) - (assert (= count1 0))) + ;; Only the posssible word -> bignum conversion note + (assert (= count1 1))) ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs. @@ -1942,7 +1947,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 @@ -2038,6 +2043,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 @@ -2130,15 +2159,131 @@ ;;; overconfident primitive type computation leading to bogus type ;;; checking. -(let* ((form1 '(lambda (x) - (declare (type (and condition function) x)) +(let* ((form1 '(lambda (x) + (declare (type (and condition function) x)) x)) (fun1 (compile nil form1)) - (form2 '(lambda (x) - (declare (type (and standard-object function) x)) + (form2 '(lambda (x) + (declare (type (and standard-object function) x)) x)) (fun2 (compile nil form2))) (assert (raises-error? (funcall fun1 (make-condition 'error)))) (assert (raises-error? (funcall fun1 fun1))) (assert (raises-error? (funcall fun2 fun2))) (assert (eq (funcall fun2 #'print-object) #'print-object))) + +;;; LET* + VALUES declaration: while the declaration is a non-standard +;;; and possibly a non-conforming extension, as long as we do support +;;; it, we might as well get it right. +;;; +;;; 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)))))