X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=577c4346e29a2f17cb8a8bc1633b984114529f7f;hb=19319c931fc1636835dbef71808cc10e252bcf45;hp=16b6e4fa61193ccce5a0e6f092f7fa2729537dc7;hpb=36717964ebcff8353035062789c08f223feccf1a;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 16b6e4f..577c434 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1,4 +1,5 @@
 
+
 ;;;; various compiler tests without side effects
 
 ;;;; This software is part of the SBCL system. See the README file for
@@ -1775,7 +1776,7 @@
       (error "bad RANDOM event"))))
 
 ;;; 0.8.17.28-sma.1 lost derived type information.
-(with-test (:name "0.8.17.28-sma.1" :fails-on :sparc)
+(with-test (:name :0.8.17.28-sma.1 :fails-on :sparc)
   (handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c))))
     (compile nil
       '(lambda (x y v)
@@ -2986,8 +2987,8 @@
         (compile nil `(lambda (x)
                         (declare (character x) (optimize speed))
                         (,name x))))
-      (dolist (name '(char= char/= char< char> char<= char>= char-equal
-                      char-not-equal char-lessp char-greaterp char-not-greaterp
+      (dolist (name '(char= char/= char< char> char<= char>=
+                      char-lessp char-greaterp char-not-greaterp
                       char-not-lessp))
         (setf current name)
         (compile nil `(lambda (x y)
@@ -3091,7 +3092,7 @@
          (array-in-bounds-p a 5 2))))))
 
 ;;; optimizing (EXPT -1 INTEGER)
-(with-test (:name (expt minus-one integer))
+(with-test (:name (expt -1 integer))
   (dolist (x '(-1 -1.0 -1.0d0))
     (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x))))))
       (assert (not (ctu:find-named-callees fun)))
@@ -3718,63 +3719,64 @@
   ;; Like all tests trying to verify that something doesn't blow up
   ;; compile-times this is bound to be a bit brittle, but at least
   ;; here we try to establish a decent baseline.
-  (flet ((time-it (lambda want)
-           (gc :full t) ; let's keep GCs coming from other code out...
-           (let* ((start (get-internal-run-time))
-                  (fun (dotimes (internal-time-resolution-too-low-workaround
-                                  #+win32 10
-                                  #-win32 0
-                                  (compile nil lambda))
-                         (compile nil lambda)))
-                  (end (get-internal-run-time))
-                  (got (funcall fun)))
-             (unless (eql want got)
-               (error "wanted ~S, got ~S" want got))
-             (- end start))))
-    (let ((time-1/simple
-           ;; This is mostly identical as the next one, but doesn't create
-           ;; hairy unions of numeric types.
-           (time-it `(lambda ()
-                       (labels ((bar (baz bim)
-                                  (let ((n (+ baz bim)))
-                                 (* n (+ n 1) bim))))
-                      (let ((a (bar 1 1))
-                            (b (bar 1 1))
-                            (c (bar 1 1)))
-                        (- (+ a b) c))))
-                    6))
-          (time-1/hairy
-           (time-it `(lambda ()
-                       (labels ((bar (baz bim)
-                                  (let ((n (+ baz bim)))
-                                 (* n (+ n 1) bim))))
-                      (let ((a (bar 1 1))
-                            (b (bar 1 5))
-                            (c (bar 1 15)))
-                        (- (+ a b) c))))
-                    -3864)))
-      (assert (>= (* 10 (1+ time-1/simple)) time-1/hairy)))
-    (let ((time-2/simple
-           ;; This is mostly identical as the next one, but doesn't create
-           ;; hairy unions of numeric types.
-           (time-it `(lambda ()
-                       (labels ((sum-d (n)
-                                  (let ((m (truncate 999 n)))
-                                    (/ (* n m (1+ m)) 2))))
-                         (- (+ (sum-d 3)
-                               (sum-d 3))
-                            (sum-d 3))))
-                    166833))
-          (time-2/hairy
-           (time-it `(lambda ()
-                       (labels ((sum-d (n)
-                                  (let ((m (truncate 999 n)))
-                                    (/ (* n m (1+ m)) 2))))
-                         (- (+ (sum-d 3)
-                               (sum-d 5))
-                            (sum-d 15))))
-                    233168)))
-      (assert (>= (* 10 (1+ time-2/simple)) time-2/hairy)))))
+  (labels ((time-it (lambda want &optional times)
+             (gc :full t) ; let's keep GCs coming from other code out...
+             (let* ((start (get-internal-run-time))
+                    (iterations 0)
+                    (fun (if times
+                             (loop repeat times
+                                   for result = (compile nil lambda)
+                                   finally (return result))
+                             (loop for result = (compile nil lambda)
+                                   do (incf iterations)
+                                   until (> (get-internal-run-time) (+ start 10))
+                                   finally (return result))))
+                    (end (get-internal-run-time))
+                    (got (funcall fun)))
+               (unless (eql want got)
+                 (error "wanted ~S, got ~S" want got))
+               (values (- end start) iterations)))
+           (test-it (simple result1 complex result2)
+             (multiple-value-bind (time-simple iterations)
+                 (time-it simple result1)
+               (assert (>= (* 10 (1+ time-simple))
+                           (time-it complex result2 iterations))))))
+    ;; This is mostly identical as the next one, but doesn't create
+    ;; hairy unions of numeric types.
+    (test-it `(lambda ()
+                (labels ((bar (baz bim)
+                           (let ((n (+ baz bim)))
+                             (* n (+ n 1) bim))))
+                  (let ((a (bar 1 1))
+                        (b (bar 1 1))
+                        (c (bar 1 1)))
+                    (- (+ a b) c))))
+             6
+             `(lambda ()
+                (labels ((bar (baz bim)
+                           (let ((n (+ baz bim)))
+                             (* n (+ n 1) bim))))
+                  (let ((a (bar 1 1))
+                        (b (bar 1 5))
+                        (c (bar 1 15)))
+                    (- (+ a b) c))))
+             -3864)
+    (test-it `(lambda ()
+                (labels ((sum-d (n)
+                           (let ((m (truncate 999 n)))
+                             (/ (* n m (1+ m)) 2))))
+                  (- (+ (sum-d 3)
+                        (sum-d 3))
+                     (sum-d 3))))
+             166833
+             `(lambda ()
+                (labels ((sum-d (n)
+                           (let ((m (truncate 999 n)))
+                             (/ (* n m (1+ m)) 2))))
+                  (- (+ (sum-d 3)
+                        (sum-d 5))
+                     (sum-d 15))))
+             233168)))
 
 (with-test (:name :regression-1.0.44.34)
   (compile nil '(lambda (z &rest args)
@@ -4479,7 +4481,7 @@
                     (setf hash (logand most-positive-word
                                        (ash hash 5)))))))
 
-(with-test (:name (local-&optional-recursive-inline :bug-1180992))
+(with-test (:name (:local-&optional-recursive-inline :bug-1180992))
   (compile nil
            `(lambda ()
               (labels ((called (&optional a))
@@ -4501,7 +4503,7 @@
 ;; be reported as mismatches with the value NIL.  Make sure we get
 ;; a warning, but that it doesn't complain about a constant NIL ...
 ;; of type FIXNUM.
-(with-test (:name (:multiple-use-lvar-interpreted-as-NIL cast))
+(with-test (:name (:multiple-use-lvar-interpreted-as-NIL :cast))
   (block nil
     (handler-bind ((sb-int:type-warning
                      (lambda (c)
@@ -4723,7 +4725,7 @@
 
 ;; win32 is very specific about the order in which catch blocks
 ;; must be allocated on the stack
-(with-test (:name :bug-121581169)
+(with-test (:name :bug-1072739)
   (let ((f (compile nil
                     `(lambda ()
                        (STRING=
@@ -4771,11 +4773,7 @@
                         "23a%b%")))))
     (assert (funcall f))))
 
-(defvar *global-equal-function* #'equal
-  "Global reference to the EQUAL function. This reference is funcalled
-in order to prevent the compiler from inlining the call.")
-
-(defmacro equal-reduction-macro ()
+(with-test (:name :equal-equalp-transforms)
   (let* ((s "foo")
          (bit-vector #*11001100)
          (values `(nil 1 2 "test"
@@ -4784,19 +4782,178 @@ in order to prevent the compiler from inlining the call.")
                        (read-from-string "1.1") (read-from-string "1.2d0")
                        1.1 1.2d0 '("foo" "bar" "test")
                        #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file"
-                       ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector))))
+                       ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)
+                       ,(make-hash-table) #\a #\b #\A #\C
+                       ,(make-random-state) 1/2 2/3)))
     ;; Test all permutations of different types
-    `(progn
-       ,@(loop
-            for x in values
-            append (loop
-                      for y in values
-                      collect (let ((result1-sym (gensym "RESULT1-"))
-                                    (result2-sym (gensym "RESULT2-")))
-                                `(let ((,result1-sym (equal ,x ,y))
-                                       (,result2-sym (funcall *global-equal-function* ,x ,y)))
-                                   (assert (or (and ,result1-sym ,result2-sym)
-                                               (and (not ,result1-sym) (not ,result2-sym)))))))))))
-
-(with-test (:name :equal-reduction)
-  (equal-reduction-macro))
+    (assert
+     (loop
+       for x in values
+       always (loop
+                for y in values
+                always
+                (and (eq (funcall (compile nil `(lambda (x y)
+                                                  (equal (the ,(type-of x) x)
+                                                         (the ,(type-of y) y))))
+                                  x y)
+                         (equal x y))
+                     (eq (funcall (compile nil `(lambda (x y)
+                                                  (equalp (the ,(type-of x) x)
+                                                          (the ,(type-of y) y))))
+                                  x y)
+                         (equalp x y))))))
+    (assert
+     (funcall (compile
+               nil
+               `(lambda (x y)
+                  (equal (the (cons (or simple-bit-vector simple-base-string))
+                              x)
+                         (the (cons (or (and bit-vector (not simple-array))
+                                        (simple-array character (*))))
+                              y))))
+              (list (string 'list))
+              (list "LIST")))
+    (assert
+     (funcall (compile
+               nil
+               `(lambda (x y)
+                  (equalp (the (cons (or simple-bit-vector simple-base-string))
+                               x)
+                          (the (cons (or (and bit-vector (not simple-array))
+                                         (simple-array character (*))))
+                               y))))
+              (list (string 'list))
+              (list "lisT")))))
+
+(with-test (:name (restart-case optimize speed compiler-note))
+  (handler-bind ((compiler-note #'error))
+    (compile nil '(lambda ()
+                   (declare (optimize speed))
+                   (restart-case () (c ()))))
+    (compile nil '(lambda ()
+                   (declare (optimize speed))
+                   (let (x)
+                     (restart-case (setf x (car (compute-restarts)))
+                       (c ()))
+                     x)))))
+
+(with-test (:name :copy-more-arg
+            :fails-on '(not (or :x86 :x86-64)))
+  ;; copy-more-arg might not copy in the right direction
+  ;; when there are more fixed args than stack frame slots,
+  ;; and thus end up splatting a single argument everywhere.
+  ;; Fixed on x86oids only, but other platforms still start
+  ;; their stack frames at 8 slots, so this is less likely
+  ;; to happen.
+  (let ((limit 33))
+    (labels ((iota (n)
+               (loop for i below n collect i))
+             (test-function (function skip)
+               ;; function should just be (subseq x skip)
+               (loop for i from skip below (+ skip limit) do
+                 (let* ((values (iota i))
+                        (f (apply function values))
+                        (subseq (subseq values skip)))
+                   (assert (equal f subseq)))))
+             (make-function (n)
+               (let ((gensyms (loop for i below n collect (gensym))))
+                 (compile nil `(lambda (,@gensyms &rest rest)
+                                 (declare (ignore ,@gensyms))
+                                 rest)))))
+      (dotimes (i limit)
+        (test-function (make-function i) i)))))
+
+(with-test (:name :apply-aref)
+  (flet ((test (form)
+           (let (warning)
+             (handler-bind ((warning (lambda (c) (setf warning c))))
+               (compile nil `(lambda (x y) (setf (apply #'sbit x y) 10))))
+             (assert (not warning)))))
+    (test `(lambda (x y) (setf (apply #'aref x y) 21)))
+    (test `(lambda (x y) (setf (apply #'bit x y) 1)))
+    (test `(lambda (x y) (setf (apply #'sbit x y) 0)))))
+
+(with-test (:name :warn-on-the-values-constant)
+  (multiple-value-bind (fun warnings-p failure-p)
+      (compile nil
+               ;; The compiler used to elide this test without
+               ;; noting that the type demands multiple values.
+               '(lambda () (the (values fixnum fixnum) 1)))
+    (declare (ignore warnings-p))
+    (assert (functionp fun))
+    (assert failure-p)))
+
+;; quantifiers shouldn't cons themselves.
+(with-test (:name :quantifiers-no-consing)
+  (let ((constantly-t (lambda (x) x t))
+        (constantly-nil (lambda (x) x nil))
+        (list (make-list 1000 :initial-element nil))
+        (vector (make-array 1000 :initial-element nil)))
+    (macrolet ((test (quantifier)
+                 (let ((function (make-symbol (format nil "TEST-~A" quantifier))))
+                   `(flet ((,function (function sequence)
+                             (,quantifier function sequence)))
+                      (ctu:assert-no-consing (,function constantly-t list))
+                      (ctu:assert-no-consing (,function constantly-nil vector))))))
+      (test some)
+      (test every)
+      (test notany)
+      (test notevery))))
+
+(with-test (:name :propagate-complex-type-tests)
+  (flet ((test (type value)
+           (let ((ftype (sb-kernel:%simple-fun-type
+                         (compile nil `(lambda (x)
+                                         (if (typep x ',type)
+                                             x
+                                             ',value))))))
+             (assert (typep ftype `(cons (eql function))))
+             (assert (= 3 (length ftype)))
+             (let* ((return (third ftype))
+                    (rtype (second return)))
+               (assert (typep return `(cons (eql values)
+                                            (cons t
+                                                  (cons (eql &optional)
+                                                        null)))))
+               (assert (and (subtypep rtype type)
+                            (subtypep type rtype)))))))
+    (mapc (lambda (params)
+            (apply #'test params))
+          `(((unsigned-byte 17) 0)
+            ((member 1 3 5 7) 5)
+            ((or symbol (eql 42)) t)))))
+
+(with-test (:name :constant-fold-complex-type-tests)
+  (assert (equal (sb-kernel:%simple-fun-type
+                  (compile nil `(lambda (x)
+                                  (if (typep x '(member 1 3))
+                                      (typep x '(member 1 3 15))
+                                      t))))
+                 `(function (t) (values (member t) &optional))))
+  (assert (equal (sb-kernel:%simple-fun-type
+                  (compile nil `(lambda (x)
+                                  (declare (type (member 1 3) x))
+                                  (typep x '(member 1 3 15)))))
+                 `(function ((or (integer 1 1) (integer 3 3)))
+                            (values (member t) &optional)))))
+
+(with-test (:name :quietly-row-major-index-no-dimensions)
+  (assert (handler-case
+              (compile nil `(lambda (x) (array-row-major-index x)))
+            (warning () nil))))
+
+(with-test (:name :array-rank-transform)
+  (compile nil `(lambda (a) (array-rank (the an-imaginary-type a)))))
+
+(with-test (:name (:array-rank-fold :bug-1252108))
+  (let (noted)
+    (handler-bind ((sb-ext::code-deletion-note
+                     (lambda (x)
+                       (setf noted x))))
+      (compile nil
+               `(lambda (a)
+                  (typecase a
+                    ((array t 2)
+                     (when (= (array-rank a) 3)
+                       (array-dimension a 2)))))))
+    (assert noted)))