X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=0e7c53c5128cb81a56772ff101294ba44aef6f0c;hb=a5fbc248b7513f19a31e58a591a27868f30354ef;hp=cd14e507fd5b1f02ecc2f0ac51c8bf3b7a8a21e5;hpb=bb9b382751d808c76592ce2484c33f8447db6568;p=sbcl.git

diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index cd14e50..0e7c53c 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3717,7 +3717,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 +3831,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))))
@@ -4282,3 +4287,113 @@
      (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))))