X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=bccf8efd74ac2d1e49265295f022c2129aca6ac2;hb=0b3f5cc5fa9e6b121d232960ccd964d2eb15f695;hp=81fc0f711f5d295d99dd35fc592581411fe0b696;hpb=d7e55b414d180341d79e0eddc957e1aa52551c38;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 81fc0f7..bccf8ef 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -1441,7 +1441,9 @@
                      (declare (type (alien (* (unsigned 8))) a)
                               (type (unsigned-byte 32) i))
                      (deref a i))))
-  (compiler-note () (error "The code is not optimized.")))
+  (compiler-note (c)
+    (unless (search "%ASH/RIGHT" (first (simple-condition-format-arguments c)))
+      (error "The code is not optimized."))))
 
 (handler-case
     (compile nil '(lambda (x)
@@ -3717,7 +3719,11 @@
   (flet ((time-it (lambda want)
            (gc :full t) ; let's keep GCs coming from other code out...
            (let* ((start (get-internal-run-time))
-                  (fun (compile nil lambda))
+                  (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)
@@ -3827,7 +3833,8 @@
 (with-test (:name :multiple-args-to-function)
   (let ((form `(flet ((foo (&optional (x 13)) x))
                  (funcall (function foo 42))))
-        (*evaluator-mode* :interpret))
+        #+sb-eval (*evaluator-mode* :interpret))
+    #+sb-eval
     (assert (eq :error
                 (handler-case (eval form)
                   (error () :error))))
@@ -4167,3 +4174,413 @@
                   (declare (type (integer -1 -1) d))
                   (let ((i (unwind-protect 32 (shiftf d -1))))
                     (or (if (= d c)  2 (= 3 b)) 4)))))
+
+(with-test (:name :bug-913232)
+  (compile nil `(lambda (x)
+                  (declare (optimize speed)
+                           (type (or (and (or (integer -100 -50)
+                                              (integer 100 200)) (satisfies foo))
+                                     (and (or (integer 0 10) (integer 20 30)) a)) x))
+                  x))
+  (compile nil `(lambda (x)
+                  (declare (optimize speed)
+                           (type (and fixnum a) x))
+                  x)))
+
+(with-test (:name :bug-959687)
+  (multiple-value-bind (fun warn fail)
+      (compile nil `(lambda (x)
+                      (case x
+                        (t
+                         :its-a-t)
+                        (otherwise
+                         :somethign-else))))
+    (assert (and warn fail))
+    (assert (not (ignore-errors (funcall fun t)))))
+  (multiple-value-bind (fun warn fail)
+      (compile nil `(lambda (x)
+                      (case x
+                        (otherwise
+                         :its-an-otherwise)
+                        (t
+                         :somethign-else))))
+    (assert (and warn fail))
+    (assert (not (ignore-errors (funcall fun t))))))
+
+(with-test (:name :bug-924276)
+  (assert (eq :style-warning
+              (handler-case
+                  (compile nil `(lambda (a)
+                                  (cons a (symbol-macrolet ((b 1))
+                                            (declare (ignorable a))
+                                            :c))))
+                (style-warning ()
+                  :style-warning)))))
+
+(with-test (:name :bug-974406)
+  (let ((fun32 (compile nil `(lambda (x)
+                               (declare (optimize speed (safety 0)))
+                               (declare (type (integer 53 86) x))
+                               (logand (+ x 1032791128) 11007078467))))
+        (fun64 (compile nil `(lambda (x)
+                               (declare (optimize speed (safety 0)))
+                               (declare (type (integer 53 86) x))
+                               (logand (+ x 1152921504606846975)
+                                       38046409652025950207)))))
+    (assert (= (funcall fun32 61) 268574721))
+    (assert (= (funcall fun64 61) 60)))
+  (let (result)
+    (do ((width 5 (1+ width)))
+        ((= width 130))
+      (dotimes (extra 4)
+        (let ((fun (compile nil `(lambda (x)
+                                   (declare (optimize speed (safety 0)))
+                                   (declare (type (integer 1 16) x))
+                                   (logand
+                                    (+ x ,(1- (ash 1 width)))
+                                    ,(logior (ash 1 (+ width 1 extra))
+                                             (1- (ash 1 width))))))))
+          (unless (= (funcall fun 16) (logand 15 (1- (ash 1 width))))
+            (push (cons width extra) result)))))
+    (assert (null result))))
+
+;; On x86-64 MOVE-IMMEDIATE of fixnum values into memory either directly
+;; uses a MOV into memory or goes through a temporary register if the
+;; value is larger than a certain number of bits. Check that it respects
+;; the limits of immediate arguments to the MOV instruction (if not, the
+;; assembler will fail an assertion) and doesn't have sign-extension
+;; problems. (The test passes fixnum constants through the MOVE VOP
+;; which calls MOVE-IMMEDIATE.)
+(with-test (:name :constant-fixnum-move)
+  (let ((f (compile nil `(lambda (g)
+                           (funcall g
+                                    ;; The first three args are
+                                    ;; uninteresting as they are
+                                    ;; passed in registers.
+                                    1 2 3
+                                    ,@(loop for i from 27 to 32
+                                            collect (expt 2 i)))))))
+    (assert (every #'plusp (funcall f #'list)))))
+
+(with-test (:name (:malformed-ignore :lp-1000239))
+  (raises-error?
+   (eval '(lambda () (declare (ignore (function . a)))))
+   sb-int:compiled-program-error)
+  (raises-error?
+   (eval '(lambda () (declare (ignore (function a b)))))
+   sb-int:compiled-program-error)
+  (raises-error?
+   (eval '(lambda () (declare (ignore (function)))))
+   sb-int:compiled-program-error)
+  (raises-error?
+   (eval '(lambda () (declare (ignore (a)))))
+   sb-int:compiled-program-error)
+  (raises-error?
+   (eval '(lambda () (declare (ignorable (a b)))))
+   sb-int:compiled-program-error))
+
+(with-test (:name :malformed-type-declaraions)
+  (compile nil '(lambda (a) (declare (type (integer 1 2 . 3) a)))))
+
+(with-test (:name :compiled-program-error-escaped-source)
+  (assert
+   (handler-case
+       (funcall (compile nil `(lambda () (lambda ("foo")))))
+     (sb-int:compiled-program-error (e)
+       (let ((source (read-from-string (sb-kernel::program-error-source e))))
+         (equal source '#'(lambda ("foo"))))))))
+
+(with-test (:name :escape-analysis-for-nlxs)
+  (flet ((test (check lambda &rest args)
+           (let* ((cell-note nil)
+                  (fun (handler-bind ((compiler-note
+                                        (lambda (note)
+                                          (when (search
+                                                 "Allocating a value-cell at runtime for"
+                                                 (princ-to-string note))
+                                            (setf cell-note t)))))
+                          (compile nil lambda))))
+             (assert (eql check cell-note))
+             (if check
+                 (assert
+                  (eq :ok
+                      (handler-case
+                          (dolist (arg args nil)
+                            (setf fun (funcall fun arg)))
+                        (sb-int:simple-control-error (e)
+                          (when (equal
+                                 (simple-condition-format-control e)
+                                 "attempt to RETURN-FROM a block or GO to a tag that no longer exists")
+                            :ok)))))
+                 (ctu:assert-no-consing (apply fun args))))))
+    (test nil `(lambda (x)
+                 (declare (optimize speed))
+                 (block out
+                   (flet ((ex () (return-from out 'out!)))
+                     (typecase x
+                       (cons (or (car x) (ex)))
+                       (t (ex)))))) :foo)
+    (test t   `(lambda (x)
+                 (declare (optimize speed))
+                 (funcall
+                  (block nasty
+                    (flet ((oops () (return-from nasty t)))
+                      #'oops)))) t)
+    (test t   `(lambda (r)
+                 (declare (optimize speed))
+                 (block out
+                   (flet ((ex () (return-from out r)))
+                     (lambda (x)
+                       (typecase x
+                         (cons (or (car x) (ex)))
+                         (t (ex))))))) t t)
+    (test t   `(lambda (x)
+                 (declare (optimize speed))
+                 (flet ((eh (x)
+                          (flet ((meh () (return-from eh 'meh)))
+                            (lambda ()
+                              (typecase x
+                                (cons (or (car x) (meh)))
+                                (t (meh)))))))
+                   (funcall (eh x)))) t t)))
+
+(with-test (:name (:bug-1050768 :symptom))
+  ;; Used to signal an error.
+  (compile nil
+           `(lambda (string position)
+              (char string position)
+              (array-in-bounds-p string (1+ position)))))
+
+(with-test (:name (:bug-1050768 :cause))
+  (let ((types `((string string)
+                 ((or (simple-array character 24) (vector t 24))
+                  (or (simple-array character 24) (vector t))))))
+    (dolist (pair types)
+      (destructuring-bind (orig conservative) pair
+        (assert sb-c::(type= (specifier-type cl-user::conservative)
+                             (conservative-type (specifier-type cl-user::orig))))))))
+
+(with-test (:name (:smodular64 :wrong-width))
+  (let ((fun (compile nil
+                      '(lambda (x)
+                         (declare (type (signed-byte 64) x))
+                         (sb-c::mask-signed-field 64 (- x 7033717698976965573))))))
+    (assert (= (funcall fun 10038) -7033717698976955535))))
+
+(with-test (:name (:smodular32 :wrong-width))
+  (let ((fun (compile nil '(lambda (x)
+                             (declare (type (signed-byte 31) x))
+                             (sb-c::mask-signed-field 31 (- x 1055131947))))))
+    (assert (= (funcall fun 10038) -1055121909))))
+
+(with-test (:name :first-open-coded)
+  (let ((fun (compile nil `(lambda (x) (first x)))))
+    (assert (not (ctu:find-named-callees fun)))))
+
+(with-test (:name :second-open-coded)
+  (let ((fun (compile nil `(lambda (x) (second x)))))
+    (assert (not (ctu:find-named-callees fun)))))
+
+(with-test (:name :svref-of-symbol-macro)
+  (compile nil `(lambda (x)
+                  (symbol-macrolet ((sv x))
+                    (values (svref sv 0) (setf (svref sv 0) 99))))))
+
+;; The compiler used to update the receiving LVAR's type too
+;; aggressively when converting a large constant to a smaller
+;; (potentially signed) one, causing other branches to be
+;; inferred as dead.
+(with-test (:name :modular-cut-constant-to-width)
+  (let ((test (compile nil
+                       `(lambda (x)
+                          (logand 254
+                                  (case x
+                                    ((3) x)
+                                    ((2 2 0 -2 -1 2) 9223372036854775803)
+                                    (t 358458651)))))))
+    (assert (= (funcall test -10470605025) 26))))
+
+(with-test (:name :append-type-derivation)
+  (let ((test-cases
+          '((lambda () (append 10)) (integer 10 10)
+            (lambda () (append nil 10)) (integer 10 10)
+            (lambda (x) (append x 10)) t
+            (lambda (x) (append x (cons 1 2))) cons
+            (lambda (x y) (append x (cons 1 2) y)) cons
+            (lambda (x y) (nconc x (the list y) x)) t
+            (lambda (x y) (print (length y)) (append x y)) sequence)))
+    (loop for (function result-type) on test-cases by #'cddr
+          do (assert (equal (car (cdaddr (sb-kernel:%simple-fun-type
+                                          (compile nil function))))
+                            result-type)))))
+
+(with-test (:name :bug-504121)
+  (compile nil `(lambda (s)
+                  (let ((p1 #'upper-case-p))
+                    (funcall
+                     (lambda (g)
+                       (funcall p1 g))))
+                  (let ((p2 #'(lambda (char) (upper-case-p char))))
+                    (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :optional-missing))
+  (compile nil `(lambda (s)
+                  (let ((p1 #'upper-case-p))
+                    (funcall
+                     (lambda (g &optional x)
+                       (funcall p1 g))))
+                  (let ((p2 #'(lambda (char) (upper-case-p char))))
+                    (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :optional-superfluous))
+  (compile nil `(lambda (s)
+                  (let ((p1 #'upper-case-p))
+                    (funcall
+                     (lambda (g &optional x)
+                       (funcall p1 g))
+                     #\1 2 3))
+                  (let ((p2 #'(lambda (char) (upper-case-p char))))
+                    (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :key-odd))
+  (compile nil `(lambda (s)
+                  (let ((p1 #'upper-case-p))
+                    (funcall
+                     (lambda (g &key x)
+                       (funcall p1 g))
+                     #\1 :x))
+                  (let ((p2 #'(lambda (char) (upper-case-p char))))
+                    (funcall p2 s)))))
+
+(with-test (:name (:bug-504121 :key-unknown))
+  (compile nil `(lambda (s)
+                  (let ((p1 #'upper-case-p))
+                    (funcall
+                     (lambda (g &key x)
+                       (funcall p1 g))
+                     #\1 :y 2))
+                  (let ((p2 #'(lambda (char) (upper-case-p char))))
+                    (funcall p2 s)))))
+
+(with-test (:name :bug-1181684)
+  (compile nil `(lambda ()
+                  (let ((hash #xD13CCD13))
+                    (setf hash (logand most-positive-word
+                                       (ash hash 5)))))))
+
+(with-test (:name (local-&optional-recursive-inline :bug-1180992))
+  (compile nil
+           `(lambda ()
+              (labels ((called (&optional a))
+                       (recursed (&optional b)
+                         (called)
+                         (recursed)))
+                (declare (inline recursed called))
+                (recursed)))))
+
+(with-test (:name :constant-fold-logtest)
+  (assert (equal (sb-kernel:%simple-fun-type
+                  (compile nil `(lambda (x)
+                                  (declare (type (mod 1024) x)
+                                           (optimize speed))
+                                  (logtest x 2048))))
+                 '(function ((unsigned-byte 10)) (values null &optional)))))
+
+;; type mismatches on LVARs with multiple potential sources used to
+;; 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))
+  (block nil
+    (handler-bind ((sb-int:type-warning
+                     (lambda (c)
+                       (assert
+                        (not (search "Constant "
+                                     (simple-condition-format-control
+                                      c))))
+                       (return))))
+      (compile nil `(lambda (x y z)
+                      (declare (type fixnum y z))
+                      (aref (if x y z) 0))))
+    (error "Where's my warning?")))
+
+(with-test (:name (:multiple-use-lvar-interpreted-as-NIL catch))
+  (block nil
+    (handler-bind ((style-warning
+                     (lambda (c)
+                       (assert
+                        (not (position
+                              nil
+                              (simple-condition-format-arguments c))))
+                       (return))))
+      (compile nil `(lambda (x y z f)
+                      (declare (type fixnum y z))
+                      (catch (if x y z) (funcall f)))))
+    (error "Where's my style-warning?")))
+
+;; Smoke test for rightward shifts
+(with-test (:name (:ash/right-signed))
+  (let* ((f (compile nil `(lambda (x y)
+                            (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+                                     (type sb-vm:signed-word x)
+                                     (optimize speed))
+                            (ash x (- y)))))
+         (max (ash most-positive-word -1))
+         (min (- -1 max)))
+    (flet ((test (x y)
+             (assert (= (ash x (- y))
+                        (funcall f x y)))))
+      (dotimes (x 32)
+        (dotimes (y (* 2 sb-vm:n-word-bits))
+          (test x y)
+          (test (- x) y)
+          (test (- max x) y)
+          (test (+ min x) y))))))
+
+(with-test (:name (:ash/right-unsigned))
+  (let ((f (compile nil `(lambda (x y)
+                           (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+                                    (type word x)
+                                    (optimize speed))
+                           (ash x (- y)))))
+        (max most-positive-word))
+    (flet ((test (x y)
+             (assert (= (ash x (- y))
+                        (funcall f x y)))))
+      (dotimes (x 32)
+        (dotimes (y (* 2 sb-vm:n-word-bits))
+          (test x y)
+          (test (- max x) y))))))
+
+(with-test (:name (:ash/right-fixnum))
+  (let ((f (compile nil `(lambda (x y)
+                           (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
+                                    (type fixnum x)
+                                    (optimize speed))
+                           (ash x (- y))))))
+    (flet ((test (x y)
+             (assert (= (ash x (- y))
+                        (funcall f x y)))))
+      (dotimes (x 32)
+        (dotimes (y (* 2 sb-vm:n-word-bits))
+          (test x y)
+          (test (- x) y)
+          (test (- most-positive-fixnum x) y)
+          (test (+ most-negative-fixnum x) y))))))
+
+;; expected failure
+(test-util:with-test (:name :fold-index-addressing-positive-offset
+                      :fails-on '(and))
+  (let ((f (compile nil `(lambda (i)
+                           (if (typep i '(integer -31 31))
+                               (aref #. (make-array 63) (+ i 31))
+                               (error "foo"))))))
+    (funcall f -31)))
+
+;; 5d3a728 broke something like this in CL-PPCRE
+(test-util:with-test (:name :fold-index-addressing-potentially-negative-index)
+  (compile nil `(lambda (index vector)
+                  (declare (optimize speed (safety 0))
+                           ((simple-array character (*)) vector)
+                           ((unsigned-byte 24) index))
+                  (aref vector (1+ (mod index (1- (length vector))))))))