X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=8f9b132da7cebbc5a2827fc55f5780e2c96c7a16;hb=736f5ba61a8a87df309df7c51b05f0a27f42df4c;hp=a508073319033e8e7a303e6ce5f7f3315014d8be;hpb=960a9fbd48e695e5b970a01315aa687ab59dc3fe;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index a508073..8f9b132 100644 --- a/tests/compiler.impure.lisp +++ b/tests/compiler.impure.lisp @@ -19,6 +19,7 @@ (sb-ext:quit :unix-status 104)) (load "test-util.lisp") +(load "compiler-test-util.lisp") (load "assertoid.lisp") (use-package "TEST-UTIL") (use-package "ASSERTOID") @@ -618,7 +619,7 @@ (assert (equal (check-embedded-thes 3 0 2 :a) '(2 :a))) (assert (typep (check-embedded-thes 3 0 4 2.5f0) 'type-error)) -(assert (equal (check-embedded-thes 1 0 4 :b) '(4 :b))) +(assert (equal (check-embedded-thes 1 0 3 :b) '(3 :b))) (assert (typep (check-embedded-thes 1 0 1.0 2.5f0) 'type-error)) @@ -935,6 +936,263 @@ (declaim (cons *special-cons*)) (assert (raises-error? (set '*special-cons* "nope") type-error)) (assert (raises-error? (progv '(*special-cons*) '("no hope") (car *special-cons*)) type-error)) + +;;; No bogus warnings for calls to functions with complex lambda-lists. +(defun complex-function-signature (&optional x &rest y &key z1 z2) + (cons x y)) +(with-test (:name :complex-call-doesnt-warn) + (handler-bind ((warning #'error)) + (compile nil '(lambda (x) (complex-function-signature x :z1 1 :z2 2))))) + +(with-test (:name :non-required-args-update-info) + (let ((name (gensym "NON-REQUIRE-ARGS-TEST")) + (*evaluator-mode* :compile)) + (eval `(defun ,name (x) x)) + (assert (equal '(function (t) (values t &optional)) + (sb-kernel:type-specifier (sb-int:info :function :type name)))) + (eval `(defun ,name (x &optional y) (or x y))) + (assert (equal '(function (t &optional t) (values t &optional)) + (sb-kernel:type-specifier (sb-int:info :function :type name)))))) + +;;;; inline & maybe inline nested calls + +(defun quux-marker (x) x) +(declaim (inline foo-inline)) +(defun foo-inline (x) (quux-marker x)) +(declaim (maybe-inline foo-maybe-inline)) +(defun foo-maybe-inline (x) (quux-marker x)) +;; Pretty horrible, but does the job +(defun count-full-calls (name function) + (let ((code (with-output-to-string (s) + (disassemble function :stream s))) + (n 0)) + (with-input-from-string (s code) + (loop for line = (read-line s nil nil) + while line + when (search name line) + do (incf n))) + n)) + +(with-test (:name :nested-inline-calls) + (let ((fun (compile nil `(lambda (x) + (foo-inline (foo-inline (foo-inline x))))))) + (assert (= 0 (count-full-calls "FOO-INLINE" fun))) + (assert (= 3 (count-full-calls "QUUX-MARKER" fun))))) + +(with-test (:name :nested-maybe-inline-calls) + (let ((fun (compile nil `(lambda (x) + (declare (optimize (space 0))) + (foo-maybe-inline (foo-maybe-inline (foo-maybe-inline x))))))) + (assert (= 0 (count-full-calls "FOO-MAYBE-INLINE" fun))) + (assert (= 1 (count-full-calls "QUUX-MARKER" fun))))) + +(with-test (:name :inline-calls) + (let ((fun (compile nil `(lambda (x) + (list (foo-inline x) + (foo-inline x) + (foo-inline x)))))) + (assert (= 0 (count-full-calls "FOO-INLINE" fun))) + (assert (= 3 (count-full-calls "QUUX-MARKER" fun))))) + +(with-test (:name :maybe-inline-calls) + (let ((fun (compile nil `(lambda (x) + (declare (optimize (space 0))) + (list (foo-maybe-inline x) + (foo-maybe-inline x) + (foo-maybe-inline x)))))) + (assert (= 0 (count-full-calls "FOO-MAYBE-INLINE" fun))) + (assert (= 1 (count-full-calls "QUUX-MARKER" fun))))) + +(defun file-compile (toplevel-forms &key load) + (let* ((lisp "compile-impure-tmp.lisp") + (fasl (compile-file-pathname lisp))) + (unwind-protect + (progn + (with-open-file (f lisp :direction :output) + (dolist (form toplevel-forms) + (prin1 form f))) + (multiple-value-bind (fasl warn fail) (compile-file lisp) + (when load + (load fasl)) + (values warn fail))) + (ignore-errors (delete-file lisp)) + (ignore-errors (delete-file fasl))))) + +(with-test (:name :bug-405) + ;; These used to break with a TYPE-ERROR + ;; The value NIL is not of type SB-C::PHYSENV. + ;; in MERGE-LETS. + (file-compile + '((LET (outer-let-var) + (lambda () + (print outer-let-var) + (MULTIPLE-VALUE-CALL 'some-function + (MULTIPLE-VALUE-CALL (LAMBDA (a) 'foo) + 1)))))) + (file-compile + '((declaim (optimize (debug 3))) + (defstruct bug-405-foo bar) + (let () + (flet ((i (x) (frob x (bug-405-foo-bar foo)))) + (i :five)))))) + +;;; bug 235a +(declaim (ftype (function (cons) number) bug-235a-aux)) +(declaim (inline bug-235a-aux)) +(defun bug-235a-aux (c) + (the number (car c))) +(with-test (:name :bug-235a) + (let ((fun (compile nil + `(lambda (x y) + (values (locally (declare (optimize (safety 0))) + (bug-235a-aux x)) + (locally (declare (optimize (safety 3))) + (bug-235a-aux y))))))) + (assert + (eq :error + (handler-case + (funcall fun '(:one) '(:two)) + (type-error (e) + (assert (eq :two (type-error-datum e))) + (assert (eq 'number (type-error-expected-type e))) + :error)))))) + +(with-test (:name :compiled-debug-funs-leak) + (sb-ext:gc :full t) + (let ((usage-before (sb-kernel::dynamic-usage))) + (dotimes (x 10000) + (let ((f (compile nil '(lambda () + (error "X"))))) + (handler-case + (funcall f) + (error () nil)))) + (sb-ext:gc :full t) + (let ((usage-after (sb-kernel::dynamic-usage))) + (when (< (+ usage-before 2000000) usage-after) + (error "Leak"))))) + +;;; PROGV compilation and type checking when the declared type +;;; includes a FUNCTION subtype. +(declaim (type (or (function (t) (values boolean &optional)) string) + *hairy-progv-var*)) +(defvar *hairy-progv-var* #'null) +(with-test (:name :hairy-progv-type-checking) + (assert (eq :error + (handler-case + (progv '(*hairy-progv-var*) (list (eval 42)) + *hairy-progv-var*) + (type-error () :error)))) + (assert (equal "GOOD!" + (progv '(*hairy-progv-var*) (list (eval "GOOD!")) + *hairy-progv-var*)))) + +(with-test (:name :fill-complex-single-float) + (assert (every (lambda (x) (eql x #c(-1.0 -2.0))) + (funcall + (lambda () + (make-array 2 + :element-type '(complex single-float) + :initial-element #c(-1.0 -2.0))))))) + +(with-test (:name :make-array-symbol-as-initial-element) + (assert (every (lambda (x) (eq x 'a)) + (funcall + (compile nil + `(lambda () + (make-array 12 :initial-element 'a))))))) + +;;; This non-minimal test-case catches a nasty error when loading +;;; inline constants. +(deftype matrix () + `(simple-array single-float (16))) +(declaim (ftype (sb-int:sfunction (single-float single-float single-float single-float + single-float single-float single-float single-float + single-float single-float single-float single-float + single-float single-float single-float single-float) + matrix) + matrix) + (inline matrix)) +(defun matrix (m11 m12 m13 m14 + m21 m22 m23 m24 + m31 m32 m33 m34 + m41 m42 m43 m44) + (make-array 16 + :element-type 'single-float + :initial-contents (list m11 m21 m31 m41 + m12 m22 m32 m42 + m13 m23 m33 m43 + m14 m24 m34 m44))) +(declaim (ftype (sb-int:sfunction ((simple-array single-float (3)) single-float) matrix) + rotate-around)) +(defun rotate-around (a radians) + (let ((c (cos radians)) + (s (sin radians)) + ;; The 1.0 here was misloaded on x86-64. + (g (- 1.0 (cos radians)))) + (let* ((x (aref a 0)) + (y (aref a 1)) + (z (aref a 2)) + (gxx (* g x x)) (gxy (* g x y)) (gxz (* g x z)) + (gyy (* g y y)) (gyz (* g y z)) (gzz (* g z z))) + (matrix + (+ gxx c) (- gxy (* s z)) (+ gxz (* s y)) 0.0 + (+ gxy (* s z)) (+ gyy c) (- gyz (* s x)) 0.0 + (- gxz (* s y)) (+ gyz (* s x)) (+ gzz c) 0.0 + 0.0 0.0 0.0 1.0)))) +(with-test (:name :regression-1.0.29.54) + (assert (every #'= + '(-1.0 0.0 0.0 0.0 0.0 -1.0 0.0 0.0 0.0 0.0 -1.0 0.0 0.0 0.0 0.0 1.0) + (rotate-around + (make-array 3 :element-type 'single-float) (coerce pi 'single-float)))) + ;; Same bug manifests in COMPLEX-ATANH as well. + (assert (= (atanh #C(-0.7d0 1.1d0)) #C(-0.28715567731069275d0 0.9394245539093365d0)))) + +(with-test (:name :slot-value-on-structure) + (let ((f (compile nil `(lambda (x a b) + (declare (something-known-to-be-a-struct x)) + (setf (slot-value x 'x) a + (slot-value x 'y) b) + (list (slot-value x 'x) + (slot-value x 'y)))))) + (assert (equal '(#\x #\y) + (funcall f + (make-something-known-to-be-a-struct :x "X" :y "Y") + #\x #\y))) + (assert (not (ctu:find-named-callees f))))) + +(defclass some-slot-thing () + ((slot :initarg :slot))) +(with-test (:name :with-slots-the) + (let ((x (make-instance 'some-slot-thing :slot "foo"))) + (with-slots (slot) (the some-slot-thing x) + (assert (equal "foo" slot))))) + +;;; Missing &REST type in proclamation causing a miscompile. +(declaim (ftype + (function + (sequence unsigned-byte + &key (:initial-element t) (:initial-contents sequence)) + (values sequence &optional)) + bug-458354)) +(defun bug-458354 + (sequence length + &rest keys + &key (initial-element nil iep) (initial-contents nil icp)) + (declare (sb-ext:unmuffle-conditions style-warning)) + (declare (ignorable keys initial-element iep initial-contents icp)) + (apply #'sb-sequence:make-sequence-like sequence length keys)) +(with-test (:name :bug-458354) + (assert (equalp #((a b) (a b)) (bug-458354 #(1 2) 2 :initial-element '(a b))))) + +(with-test (:name :bug-542807) + (handler-bind ((style-warning #'error)) + (eval '(defstruct bug-542807 slot))) + (let (conds) + (handler-bind ((style-warning (lambda (c) + (push c conds)))) + (eval '(defstruct bug-542807 slot))) + (assert (= 1 (length conds))) + (assert (typep (car conds) 'sb-kernel::redefinition-with-defun)))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself @@ -1279,20 +1537,21 @@ ;;; FUNCALL forms in compiler macros, lambda-list parsing (define-compiler-macro test-cmacro-1 - (&whole whole a &optional b &rest c &key d) - (list whole a b c d)) + (&whole whole a (a2) &optional b &rest c &key d) + (list whole a a2 b c d)) -(macrolet ((test (form a b c d) +(macrolet ((test (form a a2 b c d) `(let ((form ',form)) - (destructuring-bind (whole a b c d) + (destructuring-bind (whole a a2 b c d) (funcall (compiler-macro-function 'test-cmacro-1) form nil) (assert (equal whole form)) (assert (eql a ,a)) + (assert (eql a2 ,a2)) (assert (eql b ,b)) (assert (equal c ,c)) (assert (eql d ,d))))) ) - (test (funcall 'test-cmacro-1 1 2 :d 3) 1 2 '(:d 3) 3) - (test (test-cmacro-1 11 12 :d 13) 11 12 '(:d 13) 13)) + (test (funcall 'test-cmacro-1 1 (x) 2 :d 3) 1 'x 2 '(:d 3) 3) + (test (test-cmacro-1 11 (y) 12 :d 13) 11 'y 12 '(:d 13) 13)) ;;; FUNCALL forms in compiler macros, expansions (define-compiler-macro test-cmacro-2 () ''ok) @@ -1653,7 +1912,7 @@ ;;; check that non-trivial constants are EQ across different files: this is ;;; not something ANSI either guarantees or requires, but we want to do it ;;; anyways. -(defconstant +share-me-1+ 123.456d0) +(defconstant +share-me-1+ #-inline-constants 123.456d0 #+inline-constants nil) (defconstant +share-me-2+ "a string to share") (defconstant +share-me-3+ (vector 1 2 3)) (defconstant +share-me-4+ (* 2 most-positive-fixnum)) @@ -1661,12 +1920,12 @@ +share-me-2+ +share-me-3+ +share-me-4+ - pi))) + #-inline-constants pi))) (multiple-value-bind (f2 c2) (compile2 '(lambda () (values +share-me-1+ +share-me-2+ +share-me-3+ +share-me-4+ - pi))) + #-inline-constants pi))) (flet ((test (fa fb) (mapc (lambda (a b) (assert (eq a b)))