X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=81fc0f711f5d295d99dd35fc592581411fe0b696;hb=d7e55b414d180341d79e0eddc957e1aa52551c38;hp=5f24fbeeab2afa4b2e5c790f9c27ba2ae583dda8;hpb=86d50ba6266c823eedd444c4e1c5a55e9dc7f46a;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 5f24fbe..81fc0f7 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2082,6 +2082,31 @@ (compiler-note () (throw :note nil))) (error "Unreachable code undetected."))) +(with-test (:name (:compiler :constraint-propagation :float-bounds-3 + :LP-894498)) + (catch :note + (handler-case + (compile nil '(lambda (x) + (declare (type (single-float 0.0) x)) + (when (> x 0.0) + (when (zerop x) + (error "This is unreachable."))))) + (compiler-note () (throw :note nil))) + (error "Unreachable code undetected."))) + +(with-test (:name (:compiler :constraint-propagation :float-bounds-4 + :LP-894498)) + (catch :note + (handler-case + (compile nil '(lambda (x y) + (declare (type (single-float 0.0) x) + (type (single-float (0.0)) y)) + (when (> x y) + (when (zerop x) + (error "This is unreachable."))))) + (compiler-note () (throw :note nil))) + (error "Unreachable code undetected."))) + (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1)) (catch :note (handler-case @@ -3690,6 +3715,7 @@ ;; 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 (compile nil lambda)) (end (get-internal-run-time)) @@ -3973,3 +3999,171 @@ (declare (optimize (safety 0))) (apply #'cons rest))))) (assert (equal '(car . cdr) (funcall fun 'car 'cdr))))) + +(with-test (:name :bug-826970) + (let ((fun (compile nil `(lambda (a b c) + (declare (type (member -2 1) b)) + (array-in-bounds-p a 4 b c))))) + (assert (funcall fun (make-array '(5 2 2)) 1 1)))) + +(with-test (:name :bug-826971) + (let* ((foo "foo") + (fun (compile nil `(lambda (p1 p2) + (schar (the (eql ,foo) p1) p2))))) + (assert (eql #\f (funcall fun foo 0))))) + +(with-test (:name :bug-738464) + (multiple-value-bind (fun warn fail) + (compile nil `(lambda () + (flet ((foo () 42)) + (declare (ftype non-function-type foo)) + (foo)))) + (assert (eql 42 (funcall fun))) + (assert (and warn (not fail))))) + +(with-test (:name :bug-832005) + (let ((fun (compile nil `(lambda (x) + (declare (type (complex single-float) x)) + (+ #C(0.0 1.0) x))))) + (assert (= (funcall fun #C(1.0 2.0)) + #C(1.0 3.0))))) + +;; A refactoring 1.0.12.18 caused lossy computation of primitive +;; types for member types. +(with-test (:name :member-type-primitive-type) + (let ((fun (compile nil `(lambda (p1 p2 p3) + (if p1 + (the (member #c(1.2d0 1d0)) p2) + (the (eql #c(1.0 1.0)) p3)))))) + (assert (eql (funcall fun 1 #c(1.2d0 1d0) #c(1.0 1.0)) + #c(1.2d0 1.0d0))))) + +;; Fall-through jump elimination made control flow fall through to trampolines. +;; Reported by Eric Marsden on sbcl-devel@ 2011.10.26, with a test case +;; reproduced below (triggered a corruption warning and a memory fault). +(with-test (:name :bug-883500) + (funcall (compile nil `(lambda (a) + (declare (type (integer -50 50) a)) + (declare (optimize (speed 0))) + (mod (mod a (min -5 a)) 5))) + 1)) + +;; Test for literals too large for the ISA (e.g. (SIGNED-BYTE 13) on SPARC). +#+sb-unicode +(with-test (:name :bug-883519) + (compile nil `(lambda (x) + (declare (type character x)) + (eql x #\U0010FFFF)))) + +;; Wide fixnum platforms had buggy address computation in atomic-incf/aref +(with-test (:name :bug-887220) + (let ((incfer (compile + nil + `(lambda (vector index) + (declare (type (simple-array sb-ext:word (4)) + vector) + (type (mod 4) index)) + (sb-ext:atomic-incf (aref vector index) 1) + vector)))) + (assert (equalp (funcall incfer + (make-array 4 :element-type 'sb-ext:word + :initial-element 0) + 1) + #(0 1 0 0))))) + +(with-test (:name :catch-interferes-with-debug-names) + (let ((fun (funcall + (compile nil + `(lambda () + (catch 'out + (flet ((foo () + (throw 'out (lambda () t)))) + (foo)))))))) + (assert (equal '(lambda () :in foo) (sb-kernel:%fun-name fun))))) + +(with-test (:name :interval-div-signed-zero) + (let ((fun (compile nil + `(Lambda (a) + (declare (type (member 0 -272413371076) a)) + (ffloor (the number a) -63243.127451934015d0))))) + (multiple-value-bind (q r) (funcall fun 0) + (assert (eql -0d0 q)) + (assert (eql 0d0 r))))) + +(with-test (:name :non-constant-keyword-typecheck) + (let ((fun (compile nil + `(lambda (p1 p3 p4) + (declare (type keyword p3)) + (tree-equal p1 (cons 1 2) (the (member :test) p3) p4))))) + (assert (funcall fun (cons 1.0 2.0) :test '=)))) + +(with-test (:name :truncate-wild-values) + (multiple-value-bind (q r) + (handler-bind ((warning #'error)) + (let ((sb-c::*check-consistency* t)) + (funcall (compile nil + `(lambda (a) + (declare (type (member 1d0 2d0) a)) + (block return-value-tag + (funcall + (the function + (catch 'debug-catch-tag + (return-from return-value-tag + (progn (truncate a))))))))) + 2d0))) + (assert (eql 2 q)) + (assert (eql 0d0 r)))) + +(with-test (:name :boxed-fp-constant-for-full-call) + (let ((fun (compile nil + `(lambda (x) + (declare (double-float x)) + (unknown-fun 1.0d0 (+ 1.0d0 x)))))) + (assert (equal '(1.0d0) (ctu:find-code-constants fun :type 'double-float))))) + +(with-test (:name :only-one-boxed-constant-for-multiple-uses) + (let* ((big (1+ most-positive-fixnum)) + (fun (compile nil + `(lambda (x) + (unknown-fun ,big (+ ,big x)))))) + (assert (= 1 (length (ctu:find-code-constants fun :type `(eql ,big))))))) + +(with-test (:name :fixnum+float-coerces-fixnum + :skipped-on :x86) + (let ((fun (compile nil + `(lambda (x y) + (declare (fixnum x) + (single-float y)) + (+ x y))))) + (assert (not (ctu:find-named-callees fun))) + (assert (not (search "GENERIC" + (with-output-to-string (s) + (disassemble fun :stream s))))))) + +(with-test (:name :bug-803508) + (compile nil `(lambda () + (print + (lambda (bar) + (declare (dynamic-extent bar)) + (foo bar)))))) + +(with-test (:name :bug-803508-b) + (compile nil `(lambda () + (list + (lambda (bar) + (declare (dynamic-extent bar)) + (foo bar)))))) + +(with-test (:name :bug-803508-c) + (compile nil `(lambda () + (list + (lambda (bar &optional quux) + (declare (dynamic-extent bar quux)) + (foo bar quux)))))) + +(with-test (:name :cprop-with-constant-but-assigned-to-closure-variable) + (compile nil `(lambda (b c d) + (declare (type (integer -20545789 207590862) c)) + (declare (type (integer -1 -1) d)) + (let ((i (unwind-protect 32 (shiftf d -1)))) + (or (if (= d c) 2 (= 3 b)) 4)))))