X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.impure.lisp;h=70b7bc795ca297ed87bd4ca237ff8badcccba385;hb=a28478f4f22bf6753eb18c44d5205726f87a0ead;hp=9b509c2e0246900e1e0eaf7e2d566515678594df;hpb=c6e249ac371fae7bf2d04defa9433720108376e4;p=sbcl.git diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp index 9b509c2..70b7bc7 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") @@ -1099,6 +1100,89 @@ (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))))) ;;;; tests not in the problem domain, but of the consistency of the ;;;; compiler machinery itself @@ -1818,7 +1902,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)) @@ -1826,12 +1910,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))) @@ -1850,37 +1934,4 @@ (setf *mystery* :mystery) (assert (eq :ok (test-mystery (make-thing :slot :mystery)))) -;;; optimizing make-array -(defun count-code-callees (f) - (let ((code (sb-kernel:fun-code-header f)) - (n 0)) - (loop for i from sb-vm::code-constants-offset below (sb-kernel:get-header-data code) - for c = (sb-kernel:code-header-ref code i) - do (when (typep c 'fdefn) - (print c) - (incf n))) - n)) -(assert (zerop (count-code-callees - (compile nil - `(lambda (x y z) - (make-array '(3) :initial-contents (list x y z))))))) -(assert (zerop (count-code-callees - (compile nil - `(lambda (x y z) - (make-array '3 :initial-contents (vector x y z))))))) -(assert (zerop (count-code-callees - (compile nil - `(lambda (x y z) - (make-array '3 :initial-contents `(,x ,y ,z))))))) - -;;; optimizing (EXPT -1 INTEGER) -(test-util:with-test (:name (expt minus-one integer)) - (dolist (x '(-1 -1.0 -1.0d0)) - (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x)))))) - (assert (zerop (count-code-callees fun))) - (dotimes (i 12) - (if (oddp i) - (assert (eql x (funcall fun i))) - (assert (eql (- x) (funcall fun i)))))))) - ;;; success