X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=5435c431a8819e2009979bd153ada346550a31f7;hb=0a15b6bbf9d5d3a64b5ac08bb96b6e5ec221d2ae;hp=ff16e82159606354347ec3dea762638359fdb670;hpb=d9824d93818d7b212acd2bfda2c5fe0fd150c093;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index ff16e82..5435c43 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -2676,6 +2676,14 @@ (assert (eq 'list type)) (assert derivedp))) +(with-test (:name :rest-list-type-derivation2) + (multiple-value-bind (type derivedp) + (funcall (funcall (compile nil `(lambda () + (lambda (&rest args) + (ctu:compiler-derived-type args)))))) + (assert (eq 'list type)) + (assert derivedp))) + (with-test (:name :base-char-typep-elimination) (assert (eq (funcall (lambda (ch) (declare (type base-char ch) (optimize (speed 3) (safety 0))) @@ -3253,14 +3261,27 @@ (truncate x)))) (d (compile nil `(lambda (x) (declare (double-float x)) - (truncate x))))) + (truncate x)))) + (s-inlined (compile nil '(lambda (x) + (declare (type (single-float 0.0s0 1.0s0) x)) + (truncate x)))) + (d-inlined (compile nil '(lambda (x) + (declare (type (double-float 0.0d0 1.0d0) x)) + (truncate x))))) ;; Check that there is no generic arithmetic (assert (not (search "GENERIC" (with-output-to-string (out) (disassemble s :stream out))))) (assert (not (search "GENERIC" (with-output-to-string (out) - (disassemble d :stream out))))))) + (disassemble d :stream out))))) + ;; Check that we actually inlined the call when we were supposed to. + (assert (not (search "UNARY-TRUNCATE" + (with-output-to-string (out) + (disassemble s-inlined :stream out))))) + (assert (not (search "UNARY-TRUNCATE" + (with-output-to-string (out) + (disassemble d-inlined :stream out))))))) (with-test (:name :make-array-unnamed-dimension-leaf) (let ((fun (compile nil `(lambda (stuff) @@ -3288,3 +3309,284 @@ (test 'not-a-float) (when (member name '(decode-float integer-decode-float)) (test sb-ext:single-float-positive-infinity)))))) + +(with-test (:name :sap-ref-16) + (let* ((fun (compile nil `(lambda (x y) + (declare (type sb-sys:system-area-pointer x) + (type (integer 0 100) y)) + (sb-sys:sap-ref-16 x (+ 4 y))))) + (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15) + '(simple-array (unsigned-byte 8) (*)))) + (sap (sb-sys:vector-sap vector)) + (ret (funcall fun sap 0))) + ;; test for either endianness + (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5)))))) + +(with-test (:name :coerce-type-warning) + (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32) + (signed-byte 8) (signed-byte 16) (signed-byte 32))) + (multiple-value-bind (fun warningsp failurep) + (compile nil `(lambda (x) + (declare (type simple-vector x)) + (coerce x '(vector ,type)))) + (assert (null warningsp)) + (assert (null failurep)) + (assert (typep (funcall fun #(1)) `(simple-array ,type (*))))))) + +(with-test (:name :truncate-double-float) + (let ((fun (compile nil `(lambda (x) + (multiple-value-bind (q r) + (truncate (coerce x 'double-float)) + (declare (type unsigned-byte q) + (type double-float r)) + (list q r)))))) + (assert (equal (funcall fun 1.0d0) '(1 0.0d0))))) + +(with-test (:name :set-slot-value-no-warning) + (let ((notes 0)) + (handler-bind ((warning #'error) + (sb-ext:compiler-note (lambda (c) + (declare (ignore c)) + (incf notes)))) + (compile nil `(lambda (x y) + (declare (optimize speed safety)) + (setf (slot-value x 'bar) y)))) + (assert (= 1 notes)))) + +(with-test (:name :concatenate-string-opt) + (flet ((test (type grep) + (let* ((fun (compile nil `(lambda (a b c d e) + (concatenate ',type a b c d e)))) + (args '("foo" #(#\.) "bar" (#\-) "quux")) + (res (apply fun args))) + (assert (search grep (with-output-to-string (out) + (disassemble fun :stream out)))) + (assert (equal (apply #'concatenate type args) + res)) + (assert (typep res type))))) + (test 'string "%CONCATENATE-TO-STRING") + (test 'simple-string "%CONCATENATE-TO-STRING") + (test 'base-string "%CONCATENATE-TO-BASE-STRING") + (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING"))) + +(with-test (:name :satisfies-no-local-fun) + (let ((fun (compile nil `(lambda (arg) + (labels ((local-not-global-bug (x) + t) + (bar (x) + (typep x '(satisfies local-not-global-bug)))) + (bar arg)))))) + (assert (eq 'local-not-global-bug + (handler-case + (funcall fun 42) + (undefined-function (c) + (cell-error-name c))))))) + +;;; Prior to 1.0.32.x, dumping a fasl with a function with a default +;;; argument that is a complex structure (needing make-load-form +;;; processing) failed an AVER. The first attempt at a fix caused +;;; doing the same in-core to break. +(with-test (:name :bug-310132) + (compile nil '(lambda (&optional (foo #p"foo/bar"))))) + +(with-test (:name :bug-309129) + (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v)))) + (warningp nil) + (fun (handler-bind ((warning (lambda (c) + (setf warningp t) (muffle-warning c)))) + (compile nil src)))) + (assert warningp) + (handler-case (funcall fun #(1)) + (type-error (c) + ;; we used to put simply VECTOR into EXPECTED-TYPE, rather + ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY)) + (assert (not (typep (type-error-datum c) (type-error-expected-type c))))) + (:no-error (&rest values) + (declare (ignore values)) + (error "no error"))))) + +(with-test (:name :unary-round-type-derivation) + (let* ((src '(lambda (zone) + (multiple-value-bind (h m) (truncate (abs zone) 1.0) + (declare (ignore h)) + (round (* 60.0 m))))) + (fun (compile nil src))) + (assert (= (funcall fun 0.5) 30)))) + +(with-test (:name :bug-525949) + (let* ((src '(lambda () + (labels ((always-one () 1) + (f (z) + (let ((n (funcall z))) + (declare (fixnum n)) + (the double-float (expt n 1.0d0))))) + (f #'always-one)))) + (warningp nil) + (fun (handler-bind ((warning (lambda (c) + (setf warningp t) (muffle-warning c)))) + (compile nil src)))) + (assert (not warningp)) + (assert (= 1.0d0 (funcall fun))))) + +(with-test (:name :%array-data-vector-type-derivation) + (let* ((f (compile nil + `(lambda (ary) + (declare (type (simple-array (unsigned-byte 32) (3 3)) ary)) + (setf (aref ary 0 0) 0)))) + (text (with-output-to-string (s) + (disassemble f :stream s)))) + (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text))))) + +(with-test (:name :array-storage-vector-type-derivation) + (let ((f (compile nil + `(lambda (ary) + (declare (type (simple-array (unsigned-byte 32) (3 3)) ary)) + (ctu:compiler-derived-type (array-storage-vector ary)))))) + (assert (equal '(simple-array (unsigned-byte 32) (9)) + (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32))))))) + +(with-test (:name :bug-523612) + (let ((fun + (compile nil + `(lambda (&key toff) + (make-array 3 :element-type 'double-float + :initial-contents + (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0))))))) + (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil))) + (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0))))) + +(with-test (:name :bug-309788) + (let ((fun + (compile nil + `(lambda (x) + (declare (optimize speed)) + (let ((env nil)) + (typep x 'fixnum env)))))) + (assert (not (ctu:find-named-callees fun))))) + +(with-test (:name :bug-309124) + (let ((fun + (compile nil + `(lambda (x) + (declare (integer x)) + (declare (optimize speed)) + (cond ((typep x 'fixnum) + "hala") + ((typep x 'fixnum) + "buba") + ((typep x 'bignum) + "hip") + (t + "zuz")))))) + (assert (equal (list "hala" "hip") + (sort (ctu:find-code-constants fun :type 'string) + #'string<))))) + +(with-test (:name :bug-316078) + (let ((fun + (compile nil + `(lambda (x) + (declare (type (and simple-bit-vector (satisfies bar)) x) + (optimize speed)) + (elt x 5))))) + (assert (not (ctu:find-named-callees fun))) + (assert (= 1 (funcall fun #*000001))) + (assert (= 0 (funcall fun #*000010))))) + +(with-test (:name :mult-by-one-in-float-acc-zero) + (assert (eql 1.0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x 1.0))) + 1))) + (assert (eql -1.0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x -1.0))) + 1))) + (assert (eql 1.0d0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x 1.0d0))) + 1))) + (assert (eql -1.0d0 (funcall (compile nil `(lambda (x) + (declare (optimize (sb-c::float-accuracy 0))) + (* x -1.0d0))) + 1)))) + +(with-test (:name :dotimes-non-integer-counter-value) + (assert (raises-error? (dotimes (i 8.6)) type-error))) + +(with-test (:name :bug-454681) + ;; This used to break due to reference to a dead lambda-var during + ;; inline expansion. + (assert (compile nil + `(lambda () + (multiple-value-bind (iterator+977 getter+978) + (does-not-exist-but-does-not-matter) + (flet ((iterator+976 () + (funcall iterator+977))) + (declare (inline iterator+976)) + (let ((iterator+976 #'iterator+976)) + (funcall iterator+976)))))))) + +(with-test (:name :complex-float-local-fun-args) + ;; As of 1.0.27.14, the lambda below failed to compile due to the + ;; compiler attempting to pass unboxed complex floats to Z and the + ;; MOVE-ARG method not expecting the register being used as a + ;; temporary frame pointer. Reported by sykopomp in #lispgames, + ;; reduced test case provided by _3b`. + (compile nil '(lambda (a) + (labels ((z (b c) + (declare ((complex double-float) b c)) + (* b (z b c)))) + (loop for i below 10 do + (setf a (z a a))))))) + +(with-test (:name :bug-309130) + (assert (eq :warning + (handler-case + (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (declare (optimize (debug 0))) + (declare (type vector x)) + (list (fill-pointer x) (svref x 1)))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (list (vector-push (svref x 0) x)))) + ((and warning (not style-warning)) () + :warning)))) + (assert (eq :warning + (handler-case + (compile nil `(lambda (x) + (list (vector-push-extend (svref x 0) x)))) + ((and warning (not style-warning)) () + :warning))))) + +(with-test (:name :bug-646796) + (assert 42 + (funcall + (compile nil + `(lambda () + (load-time-value (the (values fixnum) 42))))))) + +(with-test (:name :bug-654289) + (let* ((big (labels ((make-tree (n acc) + (cond ((zerop n) acc) + (t (make-tree (1- n) (cons acc acc)))))) + (make-tree 10000 nil))) + (small '((1) (2) (3))) + (t0 (get-internal-run-time)) + (f1 (compile nil `(lambda (x) (eq x (quote ,big))))) + (t1 (get-internal-run-time)) + (f2 (compile nil `(lambda (x) (eq x (quote ,small))))) + (t2 (get-internal-run-time))) + (assert (funcall f1 big)) + (assert (funcall f2 small)) + ;; Compile time should not explode just because there's a big constant + ;; object in the source. + (assert (> 10 (abs (- (- t1 t0) (- t2 t1)))))))