X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=7952ae1ecd1eaca24a31ff40a942a6c000a731fe;hb=3c9981c71f4d0d2c5b5830486c4b9a35ab50a240;hp=b2ed28272044e42c3da23f174e0ec1d97c5cfc7d;hpb=a406d16494b6f127c9ddc96ed279ba7c371f199d;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index b2ed282..7952ae1 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -13,6 +13,10 @@ (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 @@ -407,11 +411,12 @@ ;;; 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)))) @@ -1370,8 +1375,12 @@ (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))) + "") + (error "Compiler does not trust result type assertion.")))) (let ((f (compile nil '(lambda (x) (declare (optimize speed (safety 0))) @@ -1896,14 +1905,15 @@ (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)))) - (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. @@ -2032,3 +2042,139 @@ (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: # disp=1> is a :DWORD and # 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)))))