1.0.29.54.rc5: fix load-time-value regressions

[sbcl.git] / tests / compiler.impure.lisp

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index 9b509c2..f24c436 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1099,6 +1099,52 @@
                   (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))))
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself
@@ -1818,7 +1864,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 +1872,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 +1896,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