X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=28b32428f587b001b3fb4a8baeb9f98a381aeec5;hb=c8cc0137e55e6179f6af344f42e54f514660f68b;hp=1305c5c323d54355e6b0bbd44d98e8e86f91dc7a;hpb=79c8aba8d1af834f7c1db289f33ede663fdbb7eb;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 1305c5c..28b3242 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -790,3 +790,585 @@
                                                             (return-from b3 a))))))))
                  -589))
                '(-589 0)))
+
+;;; MISC.158
+(assert (zerop (funcall
+                (compile nil
+                         '(lambda (a b c)
+                           (declare (type (integer 79828 2625480458) a))
+                           (declare (type (integer -4363283 8171697) b))
+                           (declare (type (integer -301 0) c))
+                           (if (equal 6392154 (logxor a b))
+                               1706
+                               (let ((v5 (abs c)))
+                                 (logand v5
+                                         (logior (logandc2 c v5)
+                                                 (common-lisp:handler-case
+                                                     (ash a (min 36 22477)))))))))
+                100000 0 0)))
+
+;;; MISC.152, 153: deleted code and iteration var type inference
+(assert (eql (funcall
+              (compile nil
+                       '(lambda (a)
+                         (block b5
+                           (let ((v1 (let ((v8 (unwind-protect 9365)))
+                                       8862008)))
+                             (*
+                              (return-from b5
+                                (labels ((%f11 (f11-1) f11-1))
+                                  (%f11 87246015)))
+                              (return-from b5
+                                (setq v1
+                                      (labels ((%f6 (f6-1 f6-2 f6-3) v1))
+                                        (dpb (unwind-protect a)
+                                             (byte 18 13)
+                                             (labels ((%f4 () 27322826))
+                                               (%f6 -2 -108626545 (%f4))))))))))))
+              -6)
+             87246015))
+
+(assert (eql (funcall
+              (compile nil
+                       '(lambda (a)
+                         (if (logbitp 3
+                                      (case -2
+                                        ((-96879 -1035 -57680 -106404 -94516 -125088)
+                                         (unwind-protect 90309179))
+                                        ((-20811 -86901 -9368 -98520 -71594)
+                                         (let ((v9 (unwind-protect 136707)))
+                                           (block b3
+                                             (setq v9
+                                                   (let ((v4 (return-from b3 v9)))
+                                                     (- (ignore-errors (return-from b3 v4))))))))
+                                        (t -50)))
+                             -20343
+                             a)))
+              0)
+             -20343))
+
+;;; MISC.165
+(assert (eql (funcall
+              (compile
+               nil
+               '(lambda (a b c)
+                 (block b3
+                   (flet ((%f15
+                              (f15-1 f15-2 f15-3
+                                     &optional
+                                     (f15-4
+                                      (flet ((%f17
+                                                 (f17-1 f17-2 f17-3
+                                                        &optional (f17-4 185155520) (f17-5 c)
+                                                        (f17-6 37))
+                                               c))
+                                        (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817)))
+                                     (f15-5 a) (f15-6 -40))
+                            (return-from b3 -16)))
+                     (multiple-value-call #'%f15 (values -519354 a 121 c -1905))))))
+              0 0 -5)
+             -16))
+
+;;; MISC.172
+(assert (eql (funcall
+              (compile
+               nil
+               '(lambda (a b c)
+                 (declare (notinline list apply))
+                 (declare (optimize (safety 3)))
+                 (declare (optimize (speed 0)))
+                 (declare (optimize (debug 0)))
+                 (labels ((%f12 (f12-1 f12-2)
+                            (labels ((%f2 (f2-1 f2-2)
+                                       (flet ((%f6 ()
+						(flet ((%f18
+                                                           (f18-1
+                                                            &optional (f18-2 a)
+                                                            (f18-3 -207465075)
+                                                            (f18-4 a))
+                                                         (return-from %f12 b)))
+						  (%f18 -3489553
+							-7
+							(%f18 (%f18 150 -64 f12-1)
+							      (%f18 (%f18 -8531)
+								    11410)
+							      b)
+							56362666))))
+                                         (labels ((%f7
+                                                      (f7-1 f7-2
+                                                            &optional (f7-3 (%f6)))
+                                                    7767415))
+                                           f12-1))))
+                              (%f2 b -36582571))))
+                   (apply #'%f12 (list 774 -4413)))))
+              0 1 2)
+             774))
+
+;;; MISC.173
+(assert (eql (funcall
+              (compile
+               nil
+               '(lambda (a b c)
+                 (declare (notinline values))
+                 (declare (optimize (safety 3)))
+                 (declare (optimize (speed 0)))
+                 (declare (optimize (debug 0)))
+                 (flet ((%f11
+                            (f11-1 f11-2
+                                   &optional (f11-3 c) (f11-4 7947114)
+                                   (f11-5
+                                    (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529))
+                                             8134))
+                                      (multiple-value-call #'%f3
+                                        (values (%f3 -30637724 b) c)))))
+                          (setq c 555910)))
+                   (if (and nil (%f11 a a))
+                       (if (%f11 a 421778 4030 1)
+                           (labels ((%f7
+                                        (f7-1 f7-2
+                                              &optional
+                                              (f7-3
+                                               (%f11 -79192293
+                                                     (%f11 c a c -4 214720)
+                                                     b
+                                                     b
+                                                     (%f11 b 985)))
+                                              (f7-4 a))
+                                      b))
+                             (%f11 c b -25644))
+                           54)
+                       -32326608))))
+              1 2 3)
+             -32326608))
+
+;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
+;;; local lambda argument
+(assert
+ (equal
+  (funcall
+   (compile nil
+            '(lambda (a b c)
+              (declare (type (integer 804561 7640697) a))
+              (declare (type (integer -1 10441401) b))
+              (declare (type (integer -864634669 55189745) c))
+              (declare (ignorable a b c))
+              (declare (optimize (speed 3)))
+              (declare (optimize (safety 1)))
+              (declare (optimize (debug 1)))
+              (flet ((%f11
+                         (f11-1 f11-2)
+                       (labels ((%f4 () (round 200048 (max 99 c))))
+                         (logand
+                          f11-1
+                          (labels ((%f3 (f3-1) -162967612))
+                            (%f3 (let* ((v8 (%f4)))
+                                   (setq f11-1 (%f4)))))))))
+                (%f11 -120429363 (%f11 62362 b)))))
+   6714367 9645616 -637681868)
+  -264223548))
+
+;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
+;;; transform
+(assert (equal (multiple-value-list
+                (funcall
+                 (compile nil '(lambda ()
+                                (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
+                                (ceiling
+                                 (ceiling
+                                  (flet ((%f16 () 0)) (%f16))))))))
+               '(0 0)))
+
+;;; MISC.184
+(assert (zerop
+         (funcall
+          (compile
+           nil
+           '(lambda (a b c)
+             (declare (type (integer 867934833 3293695878) a))
+             (declare (type (integer -82111 1776797) b))
+             (declare (type (integer -1432413516 54121964) c))
+             (declare (optimize (speed 3)))
+             (declare (optimize (safety 1)))
+             (declare (optimize (debug 1)))
+             (if nil
+                 (flet ((%f15 (f15-1 &optional (f15-2 c))
+                          (labels ((%f1 (f1-1 f1-2) 0))
+                            (%f1 a 0))))
+                   (flet ((%f4 ()
+                            (multiple-value-call #'%f15
+                              (values (%f15 c 0) (%f15 0)))))
+                     (if nil (%f4)
+                         (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0))
+                                  f8-3))
+                           0))))
+                 0)))
+          3040851270 1664281 -1340106197)))
+
+;;; MISC.249
+(assert (zerop
+         (funcall
+          (compile
+           nil
+           '(lambda (a b)
+             (declare (notinline <=))
+             (declare (optimize (speed 2) (space 3) (safety 0)
+                       (debug 1) (compilation-speed 3)))
+             (if (if (<= 0) nil nil)
+                 (labels ((%f9 (f9-1 f9-2 f9-3)
+                            (ignore-errors 0)))
+                   (dotimes (iv4 5 a) (%f9 0 0 b)))
+                 0)))
+          1 2)))
+
+;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
+(assert
+ (= (funcall
+     (compile
+      nil
+      '(lambda (a)
+         (declare (type (integer 177547470 226026978) a))
+         (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
+                            (compilation-speed 1)))
+         (logand a (* a 438810))))
+     215067723)
+    13739018))
+
+
+;;;; Bugs in stack analysis
+;;; bug 299 (reported by PFD)
+(assert
+ (equal (funcall
+         (compile
+          nil
+          '(lambda ()
+            (declare (optimize (debug 1)))
+            (multiple-value-call #'list
+              (if (eval t) (eval '(values :a :b :c)) nil)
+              (catch 'foo (throw 'foo (values :x :y)))))))
+        '(:a :b :c :x :y)))
+;;; bug 298 (= MISC.183)
+(assert (zerop (funcall
+                (compile
+                 nil
+                 '(lambda (a b c)
+                   (declare (type (integer -368154 377964) a))
+                   (declare (type (integer 5044 14959) b))
+                   (declare (type (integer -184859815 -8066427) c))
+                   (declare (ignorable a b c))
+                   (declare (optimize (speed 3)))
+                   (declare (optimize (safety 1)))
+                   (declare (optimize (debug 1)))
+                   (block b7
+                     (flet ((%f3 (f3-1 f3-2 f3-3) 0))
+                       (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil)))))
+                0 6000 -9000000)))
+(assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))))
+               '(1 2)))
+(let ((f (compile
+          nil
+          '(lambda (x)
+            (block foo
+              (multiple-value-call #'list
+                :a
+                (block bar
+                  (return-from foo
+                    (multiple-value-call #'list
+                      :b
+                      (block quux
+                        (return-from bar
+                          (catch 'baz
+                            (if x
+                                (return-from quux 1)
+                                (throw 'baz 2))))))))))))))
+  (assert (equal (funcall f t) '(:b 1)))
+  (assert (equal (funcall f nil) '(:a 2))))
+
+;;; MISC.185
+(assert (equal
+         (funcall
+          (compile
+           nil
+           '(lambda (a b c)
+             (declare (type (integer 5 155656586618) a))
+             (declare (type (integer -15492 196529) b))
+             (declare (type (integer 7 10) c))
+             (declare (optimize (speed 3)))
+             (declare (optimize (safety 1)))
+             (declare (optimize (debug 1)))
+             (flet ((%f3
+                        (f3-1 f3-2 f3-3
+                              &optional (f3-4 a) (f3-5 0)
+                              (f3-6
+                               (labels ((%f10 (f10-1 f10-2 f10-3)
+                                          0))
+                                 (apply #'%f10
+                                        0
+                                        a
+                                        (- (if (equal a b) b (%f10 c a 0))
+                                           (catch 'ct2 (throw 'ct2 c)))
+                                        nil))))
+                      0))
+               (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7)
+         0))
+;;; MISC.186
+(assert (eq
+         (eval
+          '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1))
+                          (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil)))
+                  (vars '(b c))
+                  (fn1 `(lambda ,vars
+                          (declare (type (integer -2 19) b)
+                                   (type (integer -1520 218978) c)
+                                   (optimize (speed 3) (safety 1) (debug 1)))
+                          ,form))
+                  (fn2 `(lambda ,vars
+                          (declare (notinline logeqv apply)
+                                   (optimize (safety 3) (speed 0) (debug 0)))
+                          ,form))
+                  (cf1 (compile nil fn1))
+                  (cf2 (compile nil fn2))
+                  (result1 (multiple-value-list (funcall cf1 2 18886)))
+                  (result2 (multiple-value-list (funcall cf2 2 18886))))
+            (if (equal result1 result2)
+                :good
+                (values result1 result2))))
+         :good))
+
+;;; MISC.290
+(assert (zerop
+         (funcall
+          (compile
+           nil
+           '(lambda ()
+             (declare
+              (optimize (speed 3) (space 3) (safety 1)
+               (debug 2) (compilation-speed 0)))
+             (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil))))))
+
+;;; MISC.292
+(assert (zerop (funcall
+                (compile
+                 nil
+                 '(lambda (a b)
+                   (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
+                             (compilation-speed 2)))
+                   (apply (constantly 0)
+                    a
+                    0
+                    (catch 'ct6
+                      (apply (constantly 0)
+                             0
+                             0
+                             (let* ((v1
+                                     (let ((*s7* 0))
+                                       b)))
+                               0)
+                             0
+                             nil))
+                    0
+                    nil)))
+                1 2)))
+
+;;; misc.295
+(assert (eql
+         (funcall
+          (compile
+           nil
+           '(lambda ()
+             (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
+             (multiple-value-prog1
+                 (the integer (catch 'ct8 (catch 'ct7 15867134)))
+               (catch 'ct1 (throw 'ct1 0))))))
+         15867134))
+
+;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
+;;; could transform known-values LVAR to UVL
+(assert (zerop (funcall
+   (compile
+    nil
+    '(lambda (a b c)
+       (declare (notinline boole values denominator list))
+       (declare
+	(optimize (speed 2)
+		  (space 0)
+		  (safety 1)
+		  (debug 0)
+		  (compilation-speed 2)))
+       (catch 'ct6
+	 (progv
+	     '(*s8*)
+	     (list 0)
+	   (let ((v9 (ignore-errors (throw 'ct6 0))))
+	     (denominator
+	      (progv nil nil (values (boole boole-and 0 v9)))))))))
+   1 2 3)))
+
+;;; non-continuous dead UVL blocks
+(defun non-continuous-stack-test (x)
+  (multiple-value-call #'list
+    (eval '(values 11 12))
+    (eval '(values 13 14))
+    (block ext
+      (return-from non-continuous-stack-test
+        (multiple-value-call #'list
+          (eval '(values :b1 :b2))
+          (eval '(values :b3 :b4))
+          (block int
+            (return-from ext
+              (multiple-value-call (eval #'values)
+                (eval '(values 1 2))
+                (eval '(values 3 4))
+                (block ext
+                  (return-from int
+                    (multiple-value-call (eval #'values)
+                      (eval '(values :a1 :a2))
+                      (eval '(values :a3 :a4))
+                      (block int
+                        (return-from ext
+                          (multiple-value-call (eval #'values)
+                            (eval '(values 5 6))
+                            (eval '(values 7 8))
+                            (if x
+                                :ext
+                                (return-from int :int))))))))))))))))
+(assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
+(assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
+
+;;; MISC.362: environment of UNWIND-PROTECTor is different from that
+;;; if ENTRY.
+(assert (equal (multiple-value-list (funcall
+   (compile
+    nil
+    '(lambda (b g h)
+       (declare (optimize (speed 3) (space 3) (safety 2)
+			  (debug 2) (compilation-speed 3)))
+       (catch 'ct5
+	 (unwind-protect
+	     (labels ((%f15 (f15-1 f15-2 f15-3)
+                            (rational (throw 'ct5 0))))
+	       (%f15 0
+		     (apply #'%f15
+			    0
+			    h
+			    (progn
+			      (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
+			      0)
+			    nil)
+		     0))
+	   (common-lisp:handler-case 0)))))
+   1 2 3))
+ '(0)))
+
+
+;;; MISC.275
+(assert
+ (zerop
+  (funcall
+   (compile
+    nil
+    '(lambda (b)
+      (declare (notinline funcall min coerce))
+      (declare
+       (optimize (speed 1)
+        (space 2)
+        (safety 2)
+        (debug 1)
+        (compilation-speed 1)))
+      (flet ((%f12 (f12-1)
+               (coerce
+                (min
+                 (if f12-1 (multiple-value-prog1
+                               b (return-from %f12 0))
+                     0))
+                'integer)))
+        (funcall #'%f12 0))))
+   -33)))
+
+;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
+;;; potential problem: optimizers and type derivers for MAX and MIN
+;;; were not consistent in treating EQUALP, but not EQL, arguments.
+(dolist (f '(min max))
+  (loop for complex-arg-args in '((1d0 2d0) (0d0 1d0))
+        for complex-arg = `(if x ,@complex-arg-args)
+        do
+        (loop for args in `((1 ,complex-arg)
+                            (,complex-arg 1))
+              for form = `(,f ,@args)
+              for f1 = (compile nil `(lambda (x) ,form))
+              and f2 = (compile nil `(lambda (x) (declare (notinline min max))
+                                             ,form))
+              do
+              (dolist (x '(nil t))
+                (assert (eql (funcall f1 x) (funcall f2 x)))))))
+
+;;;
+(handler-case (compile nil '(lambda (x)
+                             (declare (optimize (speed 3) (safety 0)))
+                             (the double-float (sqrt (the double-float x)))))
+  (sb-ext:compiler-note ()
+    (error "Compiler does not trust result type assertion.")))
+
+(let ((f (compile nil '(lambda (x)
+                        (declare (optimize speed (safety 0)))
+                        (block nil
+                          (the double-float
+                            (multiple-value-prog1
+                                (sqrt (the double-float x))
+                              (when (< x 0)
+                                (return :minus)))))))))
+  (assert (eql (funcall f -1d0) :minus))
+  (assert (eql (funcall f 4d0) 2d0)))
+
+;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
+(handler-case
+    (compile nil '(lambda (a i)
+                   (locally
+                     (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
+                                        (inhibit-warnings 0)))
+                     (declare (type (alien (* (unsigned 8))) a)
+                              (type (unsigned-byte 32) i))
+                     (deref a i))))
+  (compiler-note () (error "The code is not optimized.")))
+
+(handler-case
+    (compile nil '(lambda (x)
+		   (declare (type (integer -100 100) x))
+		   (declare (optimize speed))
+		   (declare (notinline identity))
+		   (1+ (identity x))))
+  (compiler-note () (error "IDENTITY derive-type not applied.")))
+
+(assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
+
+;;; MISC.293 = easy variant of bug 303: repeated write to the same
+;;; LVAR; here the first write may be cleared before the second is
+;;; made.
+(assert
+ (zerop
+  (funcall
+   (compile
+    nil
+    '(lambda ()
+      (declare (notinline complex))
+      (declare (optimize (speed 1) (space 0) (safety 1)
+                (debug 3) (compilation-speed 3)))
+      (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
+        (complex (%f) 0)))))))
+
+;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
+(assert (zerop (funcall
+  (compile
+   nil
+   '(lambda (a c)
+     (declare (type (integer -1294746569 1640996137) a))
+     (declare (type (integer -807801310 3) c))
+     (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
+     (catch 'ct7
+       (if
+        (logbitp 0
+                 (if (/= 0 a)
+                     c
+                     (ignore-errors
+                       (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
+        0 0))))
+   391833530 -32785211)))