1.0.9.53: trivial typo fixes
[sbcl.git] / tests / compiler.pure.lisp
index a8ce73d..5448102 100644 (file)
 
 (cl:in-package :cl-user)
 
 
 (cl:in-package :cl-user)
 
+;; The tests in this file assume that EVAL will use the compiler
+(when (eq sb-ext:*evaluator-mode* :interpret)
+  (invoke-restart 'run-tests::skip-file))
+
 ;;; Exercise a compiler bug (by crashing the compiler).
 ;;;
 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
 ;;; Exercise a compiler bug (by crashing the compiler).
 ;;;
 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
 (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))
 
 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
 (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))
 
-(raises-error? (multiple-value-bind (a b c)
-                   (eval '(truncate 3 4))
-                 (declare (integer c))
-                 (list a b c))
-               type-error)
+(assert
+ (raises-error? (multiple-value-bind (a b c)
+                    (eval '(truncate 3 4))
+                  (declare (integer c))
+                  (list a b c))
+                type-error))
 
 (assert (equal (multiple-value-list (the (values &rest integer)
                                       (eval '(values 3))))
 
 (assert (equal (multiple-value-list (the (values &rest integer)
                                       (eval '(values 3))))
 (handler-case (compile nil '(lambda (x)
                              (declare (optimize (speed 3) (safety 0)))
                              (the double-float (sqrt (the double-float 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.")))
+  (sb-ext:compiler-note (c)
+    ;; Ignore the note for the float -> pointer conversion of the
+    ;; return value.
+    (unless (string= (car (last (sb-c::simple-condition-format-arguments c)))
+                     "<return value>")
+      (error "Compiler does not trust result type assertion."))))
 
 (let ((f (compile nil '(lambda (x)
                         (declare (optimize speed (safety 0)))
 
 (let ((f (compile nil '(lambda (x)
                         (declare (optimize speed (safety 0)))
     (compile nil '(lambda (x)
                    (declare (optimize (speed 3)))
                    (1+ x))))
     (compile nil '(lambda (x)
                    (declare (optimize (speed 3)))
                    (1+ x))))
-  ;; forced-to-do GENERIC-+, etc
-  (assert (> count0 0))
+  ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note
+  (assert (> count0 1))
   (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1))))
     (compile nil '(lambda (x)
                    (declare (optimize (speed 3)))
                    (check-type x fixnum)
                    (1+ x))))
   (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1))))
     (compile nil '(lambda (x)
                    (declare (optimize (speed 3)))
                    (check-type x fixnum)
                    (1+ x))))
-  (assert (= count1 0)))
+  ;; Only the posssible word -> bignum conversion note
+  (assert (= count1 1)))
+
+;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
+;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
+(with-test (:name :sap-ref-float)
+  (compile nil '(lambda (sap)
+                 (let ((x (setf (sb-vm::sap-ref-double sap 0) 1d0)))
+                   (1+ x))))
+  (compile nil '(lambda (sap)
+                 (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0)))
+                   (1+ x)))))
 
 
+;;; bug #399
+(with-test (:name :string-union-types)
+  (compile nil '(lambda (x)
+                 (declare (type (or (simple-array character (6))
+                                    (simple-array character (5))) x))
+                 (aref x 0))))
 
 
+;;; MISC.623: missing functions for constant-folding
+(assert (eql 0
+             (funcall
+              (compile
+               nil
+               '(lambda ()
+                 (declare (optimize (space 2) (speed 0) (debug 2)
+                           (compilation-speed 3) (safety 0)))
+                 (loop for lv3 below 1
+                    count (minusp
+                           (loop for lv2 below 2
+                              count (logbitp 0
+                                             (bit #*1001101001001
+                                                  (min 12 (max 0 lv3))))))))))))
+
+;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs
+(assert (eql 0
+             (funcall
+              (compile
+               nil
+               '(lambda (a)
+                 (declare (type (integer 21 28) a))
+                 (declare       (optimize (compilation-speed 1) (safety 2)
+                                 (speed 0) (debug 0) (space 1)))
+                 (let* ((v7 (flet ((%f3 (f3-1 f3-2)
+                                     (loop for lv2 below 1
+                                        count
+                                        (logbitp 29
+                                                 (sbit #*10101111
+                                                       (min 7 (max 0 (eval '0))))))))
+                              (%f3 0 a))))
+                   0)))
+              22)))
+
+;;; MISC.626: bandaged AVER was still wrong
+(assert (eql -829253
+             (funcall
+              (compile
+               nil
+               '(lambda (a)
+                  (declare (type (integer -902970 2) a))
+                  (declare (optimize (space 2) (debug 0) (compilation-speed 1)
+                                     (speed 0) (safety 3)))
+                  (prog2 (if (logbitp 30 a) 0 (block b3 0)) a)))
+              -829253)))
+
+;; MISC.628: constant-folding %LOGBITP was buggy
+(assert (eql t
+             (funcall
+              (compile
+               nil
+               '(lambda ()
+                  (declare (optimize (safety 3) (space 3) (compilation-speed 3)
+                                     (speed 0) (debug 1)))
+                  (not (not (logbitp 0 (floor 2147483651 (min -23 0))))))))))
+
+;; mistyping found by random-tester
+(assert (zerop
+  (funcall
+   (compile
+    nil
+    '(lambda ()
+      (declare (optimize (speed 1) (debug 0)
+                (space 2) (safety 0) (compilation-speed 0)))
+      (unwind-protect 0
+        (* (/ (multiple-value-prog1 -29457482 -5602513511) 1))))))))
+
+;; aggressive constant folding (bug #400)
+(assert
+ (eq t (funcall (compile nil '(lambda () (or t (the integer (/ 1 0))))))))
+
+(with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-1))
+  (assert
+   (handler-case
+       (compile nil '(lambda (x y)
+                       (when (eql x (length y))
+                         (locally
+                             (declare (optimize (speed 3)))
+                           (1+ x)))))
+     (compiler-note () (error "The code is not optimized.")))))
+
+(with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-2))
+  (assert
+   (handler-case
+       (compile nil '(lambda (x y)
+                       (when (eql (length y) x)
+                         (locally
+                             (declare (optimize (speed 3)))
+                           (1+ x)))))
+     (compiler-note () (error "The code is not optimized.")))))
+
+(with-test (:name (:compiler :constraint-propagation :float-bounds-1))
+  (handler-case
+      (compile nil '(lambda (x)
+                      (declare (type (single-float * (3.0)) x))
+                      (when (<= x 2.0)
+                        (when (<= 2.0 x)
+                          x))))
+    (compiler-note () (error "Deleted reachable code."))))
+
+(with-test (:name (:compiler :constraint-propagation :float-bounds-2))
+  (catch :note
+    (handler-case
+        (compile nil '(lambda (x)
+                        (declare (type single-float x))
+                        (when (< 1.0 x)
+                          (when (<= x 1.0)
+                            (error "This is unreachable.")))))
+      (compiler-note () (throw :note nil)))
+    (error "Unreachable code undetected.")))
+
+(with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
+  (catch :note
+    (handler-case
+        (compile nil '(lambda (x y)
+                        (when (typep y 'fixnum)
+                          (when (eql x y)
+                            (unless (typep x 'fixnum)
+                              (error "This is unreachable"))
+                            (setq y nil)))))
+      (compiler-note () (throw :note nil)))
+    (error "Unreachable code undetected.")))
+
+(with-test (:name (:compiler :constraint-propagation :var-eql-to-var-2))
+  (catch :note
+    (handler-case
+        (compile nil '(lambda (x y)
+                        (when (typep y 'fixnum)
+                          (when (eql y x)
+                            (unless (typep x 'fixnum)
+                              (error "This is unreachable"))
+                            (setq y nil)))))
+      (compiler-note () (throw :note nil)))
+    (error "Unreachable code undetected.")))
+
+;; Reported by John Wiseman, sbcl-devel
+;; Subject: [Sbcl-devel] float type derivation bug?
+;; Date: Tue, 4 Apr 2006 15:28:15 -0700
+(with-test (:name (:type-derivation :float-bounds))
+  (compile nil '(lambda (bits)
+                 (let* ((s (if (= (ash bits -31) 0) 1 -1))
+                        (e (logand (ash bits -23) #xff))
+                        (m (if (= e 0)
+                               (ash (logand bits #x7fffff) 1)
+                               (logior (logand bits #x7fffff) #x800000))))
+                   (float (* s m (expt 2 (- e 150))))))))
+
+;; Reported by James Knight
+;; Subject: [Sbcl-devel] AVER: "(EQ (SB-NAME (SC-SB (TN-SC TN))) 'REGISTERS)"
+;; Date: Fri, 24 Mar 2006 19:30:00 -0500
+(with-test (:name :logbitp-vop)
+  (compile nil
+           '(lambda (days shift)
+             (declare (type fixnum shift days))
+             (let* ((result 0)
+                    (canonicalized-shift (+ shift 1))
+                    (first-wrapping-day (- 1 canonicalized-shift)))
+               (declare (type fixnum result))
+               (dotimes (source-day 7)
+                 (declare (type (integer 0 6) source-day))
+                 (when (logbitp source-day days)
+                   (setf result
+                         (logior result
+                                 (the fixnum
+                                   (if (< source-day first-wrapping-day)
+                                       (+ source-day canonicalized-shift)
+                                       (- (+ source-day
+                                             canonicalized-shift) 7)))))))
+               result))))
+
+;;; MISC.637: incorrect delaying of conversion of optional entries
+;;; with hairy constant defaults
+(let ((f '(lambda ()
+  (labels ((%f11 (f11-2 &key key1)
+             (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0)))
+                        :bad1))
+               (%f8 (%f8 0)))
+             :bad2))
+    :good))))
+  (assert (eq (funcall (compile nil f)) :good)))
+
+;;; MISC.555: new reference to an already-optimized local function
+(let* ((l '(lambda (p1)
+    (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1))
+    (keywordp p1)))
+       (f (compile nil l)))
+  (assert (funcall f :good))
+  (assert (nth-value 1 (ignore-errors (funcall f 42)))))
+
+;;; Check that the compiler doesn't munge *RANDOM-STATE*.
+(let* ((state (make-random-state))
+       (*random-state* (make-random-state state))
+       (a (random most-positive-fixnum)))
+  (setf *random-state* state)
+  (compile nil `(lambda (x a)
+                  (declare (single-float x)
+                           (type (simple-array double-float) a))
+                  (+ (loop for i across a
+                           summing i)
+                     x)))
+  (assert (= a (random most-positive-fixnum))))
+
+;;; MISC.641: LET-conversion after physical environment analysis lost NLX-INFOs
+(let ((form '(lambda ()
+              (declare (optimize (speed 1) (space 0) (debug 2)
+                           (compilation-speed 0) (safety 1)))
+              (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #())))
+                          0))
+                   (apply #'%f3 0 nil)))))
+  (assert (zerop (funcall (compile nil form)))))
+
+;;;  size mismatch: #<SB-VM::EA :DWORD base=#<SB-C:TN t1[RDX]> disp=1> is a :DWORD and #<SB-C:TN t2[RAX]> is a :QWORD. on x86-64
+(compile nil '(lambda ()
+               (let ((x (make-array '(1) :element-type '(signed-byte 32))))
+                 (setf (aref x 0) 1))))
+
+;;; step instrumentation confusing the compiler, reported by Faré
+(handler-bind ((warning #'error))
+  (compile nil '(lambda ()
+                 (declare (optimize (debug 2))) ; not debug 3!
+                 (let ((val "foobar"))
+                   (map-into (make-array (list (length val))
+                                         :element-type '(unsigned-byte 8))
+                             #'char-code val)))))
+
+;;; overconfident primitive type computation leading to bogus type
+;;; checking.
+(let* ((form1 '(lambda (x)
+                (declare (type (and condition function) x))
+                x))
+       (fun1 (compile nil form1))
+       (form2 '(lambda (x)
+                (declare (type (and standard-object function) x))
+                x))
+       (fun2 (compile nil form2)))
+  (assert (raises-error? (funcall fun1 (make-condition 'error))))
+  (assert (raises-error? (funcall fun1 fun1)))
+  (assert (raises-error? (funcall fun2 fun2)))
+  (assert (eq (funcall fun2 #'print-object) #'print-object)))
+
+;;; LET* + VALUES declaration: while the declaration is a non-standard
+;;; and possibly a non-conforming extension, as long as we do support
+;;; it, we might as well get it right.
+;;;
+;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
+(compile nil '(lambda () (let* () (declare (values list)))))
+
+
+;;; test for some problems with too large immediates in x86-64 modular
+;;; arithmetic vops
+(compile nil '(lambda (x) (declare (fixnum x))
+               (logand most-positive-fixnum (logxor x most-positive-fixnum))))
+
+(compile nil '(lambda (x) (declare (fixnum x))
+               (logand most-positive-fixnum (+ x most-positive-fixnum))))
+
+(compile nil '(lambda (x) (declare (fixnum x))
+               (logand most-positive-fixnum (* x most-positive-fixnum))))
+
+;;; bug 256.b
+(assert (let (warned-p)
+            (handler-bind ((warning (lambda (w) (setf warned-p t))))
+              (compile nil
+                         '(lambda (x)
+                           (list (let ((y (the real x)))
+                                   (unless (floatp y) (error ""))
+                                   y)
+                                 (integer-length x)))))
+            warned-p))
+
+;; Dead / in safe code
+(with-test (:name :safe-dead-/)
+  (assert (eq :error
+              (handler-case
+                  (funcall (compile nil
+                                    '(lambda (x y)
+                                      (declare (optimize (safety 3)))
+                                      (/ x y)
+                                      (+ x y)))
+                           1
+                           0)
+                (division-by-zero ()
+                  :error)))))
+
+;;; Dead unbound variable (bug 412)
+(with-test (:name :dead-unbound)
+  (assert (eq :error
+              (handler-case
+                  (funcall (compile nil
+                                    '(lambda ()
+                                      #:unbound
+                                      42)))
+                (unbound-variable ()
+                  :error)))))
+
+;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR.
+(handler-bind ((sb-ext:compiler-note 'error))
+  (assert
+   (equalp #(2 3)
+           (funcall (compile nil `(lambda (s p e)
+                                    (declare (optimize speed)
+                                             (simple-vector s))
+                                    (subseq s p e)))
+                    (vector 1 2 3 4)
+                    1
+                    3))))
+
+;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR.
+(handler-bind ((sb-ext:compiler-note 'error))
+  (assert
+   (equalp #(1 2 3 4)
+           (funcall (compile nil `(lambda (s)
+                                    (declare (optimize speed)
+                                             (simple-vector s))
+                                    (copy-seq s)))
+                    (vector 1 2 3 4)))))
+
+;;; bug in adding DATA-VECTOR-REF-WITH-OFFSET to x86-64
+(assert (not (mismatch #(1.0f0 2.0f0) (make-array 2 :element-type 'single-float :initial-contents (list 1.0f0 2.0f0)))))
+
+;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too
+;;; large bignums to floats
+(dolist (op '(* / + -))
+  (let ((fun (compile
+              nil
+              `(lambda (x)
+                 (declare (type (integer 0 #.(* 2 (truncate most-positive-double-float))) x))
+                 (,op 0.0d0 x)))))
+    (loop repeat 10
+          do (let ((arg (random (truncate most-positive-double-float))))
+               (assert (eql (funcall fun arg)
+                            (funcall op 0.0d0 arg)))))))
+
+(with-test (:name :high-debug-known-function-inlining)
+  (let ((fun (compile nil
+                      '(lambda ()
+                        (declare (optimize (debug 3)) (inline append))
+                        (let ((fun (lambda (body)
+                                     (append
+                                      (first body)
+                                      nil))))
+                          (funcall fun
+                                   '((foo (bar)))))))))
+    (funcall fun)))
+
+(with-test (:name :high-debug-known-function-transform-with-optional-arguments)
+  (compile nil '(lambda (x y)
+               (declare (optimize sb-c::preserve-single-use-debug-variables))
+               (if (block nil
+                     (some-unknown-function
+                      (lambda ()
+                        (return (member x y))))
+                     t)
+                   t
+                   (error "~a" y)))))