X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=db2bfc494ab3ccecd7d58f9ee42b2d1fa2fa5ca8;hb=7f9f1fd113d7047731bda9dab2c7719cdf092a21;hp=d36c958df49828ac906fa476d0c68b6c7b359927;hpb=2b1d1a8924502ad53f2de1bb0ee88f0e5b27b41c;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index d36c958..db2bfc4 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -6,13 +6,27 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. +(cl:in-package :sb-c) + +(defknown compiler-derived-type (t) (values t t) (movable flushable unsafe)) + +(deftransform compiler-derived-type ((x)) + `(values ',(type-specifier (lvar-type x)) t)) + +(defun compiler-derived-type (x) + (values t nil)) + (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 @@ -21,67 +35,67 @@ ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by ;;; Martin Atzmueller (2000-09-13 on sbcl-devel). (funcall (compile nil - '(lambda () - (labels ((fun1 () - (fun2)) - (fun2 () - (when nil - (tagbody - tag - (fun2) - (go tag))) - (when nil - (tagbody - tag - (fun1) - (go tag))))) - - (fun1) - nil)))) + '(lambda () + (labels ((fun1 () + (fun2)) + (fun2 () + (when nil + (tagbody + tag + (fun2) + (go tag))) + (when nil + (tagbody + tag + (fun1) + (go tag))))) + + (fun1) + nil)))) ;;; Exercise a compiler bug (by crashing the compiler). ;;; -;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on +;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL. (funcall (compile nil - '(lambda (x) - (or (integerp x) - (block used-by-some-y? - (flet ((frob (stk) - (dolist (y stk) - (unless (rejected? y) - (return-from used-by-some-y? t))))) - (declare (inline frob)) - (frob (rstk x)) - (frob (mrstk x))) - nil)))) - 13) + '(lambda (x) + (or (integerp x) + (block used-by-some-y? + (flet ((frob (stk) + (dolist (y stk) + (unless (rejected? y) + (return-from used-by-some-y? t))))) + (declare (inline frob)) + (frob (rstk x)) + (frob (mrstk x))) + nil)))) + 13) ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally ;;; from Bruno Haible in CMU CL bugs collection), fixed by ;;; Alexey Dejneka 2002-01-27 (assert (= 1 ; (used to give 0 under bug 112) - (let ((x 0)) - (declare (special x)) - (let ((x 1)) - (let ((y x)) - (declare (special x)) y))))) + (let ((x 0)) + (declare (special x)) + (let ((x 1)) + (let ((y x)) + (declare (special x)) y))))) (assert (= 1 ; (used to give 1 even under bug 112, still works after fix) - (let ((x 0)) - (declare (special x)) - (let ((x 1)) - (let ((y x) (x 5)) - (declare (special x)) y))))) + (let ((x 0)) + (declare (special x)) + (let ((x 1)) + (let ((y x) (x 5)) + (declare (special x)) y))))) ;;; another LET-related bug fixed by Alexey Dejneka at the same ;;; time as bug 112 (multiple-value-bind (fun warnings-p failure-p) ;; should complain about duplicate variable names in LET binding (compile nil - '(lambda () - (let (x - (x 1)) - (list x)))) + '(lambda () + (let (x + (x 1)) + (list x)))) (declare (ignore warnings-p)) (assert (functionp fun)) (assert failure-p)) @@ -91,26 +105,26 @@ (progn (multiple-value-bind (fun warnings-p failure-p) (compile nil - ;; Compiling this code should cause a STYLE-WARNING - ;; about *X* looking like a special variable but not - ;; being one. - '(lambda (n) - (let ((*x* n)) - (funcall (symbol-function 'x-getter)) - (print *x*)))) + ;; Compiling this code should cause a STYLE-WARNING + ;; about *X* looking like a special variable but not + ;; being one. + '(lambda (n) + (let ((*x* n)) + (funcall (symbol-function 'x-getter)) + (print *x*)))) (assert (functionp fun)) (assert warnings-p) (assert (not failure-p))) (multiple-value-bind (fun warnings-p failure-p) (compile nil - ;; Compiling this code should not cause a warning - ;; (because the DECLARE turns *X* into a special - ;; variable as its name suggests it should be). - '(lambda (n) - (let ((*x* n)) - (declare (special *x*)) - (funcall (symbol-function 'x-getter)) - (print *x*)))) + ;; Compiling this code should not cause a warning + ;; (because the DECLARE turns *X* into a special + ;; variable as its name suggests it should be). + '(lambda (n) + (let ((*x* n)) + (declare (special *x*)) + (funcall (symbol-function 'x-getter)) + (print *x*)))) (assert (functionp fun)) (assert (not warnings-p)) (assert (not failure-p)))) @@ -167,7 +181,7 @@ ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)") (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14) - 17)) + 17)) ;;; bug 181: bad type specifier dropped compiler into debugger (assert (list (compile nil '(lambda (x) @@ -194,6 +208,71 @@ (assert (not (eval `(locally (declare (optimize (safety 3))) (ignore-errors (progn ,form t))))))) +;;; feature: we shall complain if functions which are only useful for +;;; their result are called and their result ignored. +(loop for (form expected-des) in + '(((progn (nreverse (list 1 2)) t) + "The return value of NREVERSE should not be discarded.") + ((progn (nreconc (list 1 2) (list 3 4)) t) + "The return value of NRECONC should not be discarded.") + ((locally + (declare (inline sort)) + (sort (list 1 2) #'<) t) + ;; FIXME: it would be nice if this warned on non-inlined sort + ;; but the current simple boolean function attribute + ;; can't express the condition that would be required. + "The return value of STABLE-SORT-LIST should not be discarded.") + ((progn (sort (vector 1 2) #'<) t) + ;; Apparently, SBCL (but not CL) guarantees in-place vector + ;; sort, so no warning. + nil) + ((progn (delete 2 (list 1 2)) t) + "The return value of DELETE should not be discarded.") + ((progn (delete-if #'evenp (list 1 2)) t) + ("The return value of DELETE-IF should not be discarded.")) + ((progn (delete-if #'evenp (vector 1 2)) t) + ("The return value of DELETE-IF should not be discarded.")) + ((progn (delete-if-not #'evenp (list 1 2)) t) + "The return value of DELETE-IF-NOT should not be discarded.") + ((progn (delete-duplicates (list 1 2)) t) + "The return value of DELETE-DUPLICATES should not be discarded.") + ((progn (merge 'list (list 1 3) (list 2 4) #'<) t) + "The return value of MERGE should not be discarded.") + ((progn (nreconc (list 1 3) (list 2 4)) t) + "The return value of NRECONC should not be discarded.") + ((progn (nunion (list 1 3) (list 2 4)) t) + "The return value of NUNION should not be discarded.") + ((progn (nintersection (list 1 3) (list 2 4)) t) + "The return value of NINTERSECTION should not be discarded.") + ((progn (nset-difference (list 1 3) (list 2 4)) t) + "The return value of NSET-DIFFERENCE should not be discarded.") + ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t) + "The return value of NSET-EXCLUSIVE-OR should not be discarded.")) + for expected = (if (listp expected-des) + expected-des + (list expected-des)) + do + (multiple-value-bind (fun warnings-p failure-p) + (handler-bind ((style-warning (lambda (c) + (if expected + (let ((expect-one (pop expected))) + (assert (search expect-one + (with-standard-io-syntax + (let ((*print-right-margin* nil)) + (princ-to-string c)))) + () + "~S should have warned ~S, but instead warned: ~A" + form expect-one c)) + (error "~S shouldn't give a(nother) warning, but did: ~A" form c))))) + (compile nil `(lambda () ,form))) + (declare (ignore warnings-p)) + (assert (functionp fun)) + (assert (null expected) + () + "~S should have warned ~S, but didn't." + form expected) + (assert (not failure-p)))) + ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers ;;; to cause errors in the compiler. Fixed by CSR in 0.7.8.10 (assert (list (compile nil '(lambda (x) (map 'simple-array 'identity x))))) @@ -252,37 +331,37 @@ ;;; PSETQ should behave when given complex symbol-macro arguments (multiple-value-bind (sequence index) (symbol-macrolet ((x (aref a (incf i))) - (y (aref a (incf i)))) - (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) - (i 0)) - (psetq x (aref a (incf i)) - y (aref a (incf i))) - (values a i))) + (y (aref a (incf i)))) + (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9))) + (i 0)) + (psetq x (aref a (incf i)) + y (aref a (incf i))) + (values a i))) (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9))) (assert (= index 4))) (multiple-value-bind (result error) (ignore-errors (let ((x (list 1 2))) - (psetq (car x) 3) - x)) + (psetq (car x) 3) + x)) (assert (null result)) (assert (typep error 'program-error))) ;;; COPY-SEQ should work on known-complex vectors: (assert (equalp #(1) - (let ((v (make-array 0 :fill-pointer 0))) - (vector-push-extend 1 v) - (copy-seq v)))) + (let ((v (make-array 0 :fill-pointer 0))) + (vector-push-extend 1 v) + (copy-seq v)))) ;;; to support INLINE functions inside MACROLET, it is necessary for ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in ;;; certain circumstances, one of which is when compile is called from ;;; top-level. (assert (equal - (function-lambda-expression - (compile nil '(lambda (x) (block nil (print x))))) - '(lambda (x) (block nil (print x))))) + (function-lambda-expression + (compile nil '(lambda (x) (block nil (print x))))) + '(lambda (x) (block nil (print x))))) ;;; bug 62: too cautious type inference in a loop (assert (nth-value @@ -342,11 +421,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)))) @@ -389,8 +469,8 @@ (values nil t t)))))) (assert (typep (eval `(the arithmetic-error - ',(make-condition 'arithmetic-error))) - 'arithmetic-error)) + ',(make-condition 'arithmetic-error))) + 'arithmetic-error)) (assert (not (nth-value 2 (compile nil '(lambda () @@ -458,19 +538,27 @@ (funcall f y 1) (assert (equal y #*10)))) +;;; use of declared array types +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x) + (declare (type (simple-array (simple-string 3) (5)) x) + (optimize speed)) + (aref (aref x 0) 0)))) + (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda (x) - (declare (type (simple-array (simple-string 3) (5)) x)) - (aref (aref x 0) 0)))) + (declare (type (simple-array (simple-array bit (10)) (10)) x) + (optimize speed)) + (1+ (aref (aref x 0) 0))))) ;;; compiler failure (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0))))))) (assert (funcall f 1d0))) (compile nil '(lambda (x) - (declare (double-float x)) - (let ((y (* x pi))) - (atan y y)))) + (declare (double-float x)) + (let ((y (* x pi))) + (atan y y)))) ;;; bogus optimization of BIT-NOT (multiple-value-bind (result x) @@ -484,13 +572,13 @@ ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T). (handler-bind ((sb-ext:compiler-note #'error)) (assert (equalp (funcall - (compile - nil - '(lambda () - (let ((x (make-sequence 'vector 10 :initial-element 'a))) - (setf (aref x 4) 'b) - x)))) - #(a a a a b a a a a a)))) + (compile + nil + '(lambda () + (let ((x (make-sequence 'vector 10 :initial-element 'a))) + (setf (aref x 4) 'b) + x)))) + #(a a a a b a a a a a)))) ;;; this is not a check for a bug, but rather a test of compiler ;;; quality @@ -566,8 +654,8 @@ ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ] ;;; wasn't recognized as a good type specifier. (let ((fun (lambda (x y) - (declare (type (integer -1 0) x y) (optimize speed)) - (logxor x y)))) + (declare (type (integer -1 0) x y) (optimize speed)) + (logxor x y)))) (assert (= (funcall fun 0 0) 0)) (assert (= (funcall fun 0 -1) -1)) (assert (= (funcall fun -1 -1) 0))) @@ -637,12 +725,12 @@ ;;; bug in Alpha backend: not enough sanity checking of arguments to ;;; instructions -(assert (= (funcall (compile nil - '(lambda (x) - (declare (fixnum x)) - (ash x -257))) - 1024) - 0)) +(assert (= (funcall (compile nil + '(lambda (x) + (declare (fixnum x)) + (ash x -257))) + 1024) + 0)) ;;; bug found by WHN and pfdietz: compiler failure while referencing ;;; an entry point inside a deleted lambda @@ -682,19 +770,19 @@ ;;; reasonable multiplication never returned, causing chaos. Fixed by ;;; explicitly doing modular arithmetic, and relying on the backends ;;; being smart. -(assert (= (funcall - (compile nil - '(lambda (x) - (declare (type (integer 178956970 178956970) x) - (optimize speed)) - (* x 24))) - 178956970) - 4294967280)) +(assert (= (funcall + (compile nil + '(lambda (x) + (declare (type (integer 178956970 178956970) x) + (optimize speed)) + (* x 24))) + 178956970) + 4294967280)) ;;; bug in modular arithmetic and type specifiers (assert (= (funcall (compile nil (lambda (x) (logand x x 0))) - -1) - 0)) + -1) + 0)) ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP ;;; produced wrong result for shift >=32 on X86 @@ -704,6 +792,35 @@ (declare (type (integer 4303063 101130078) a)) (mask-field (byte 18 2) (ash a 77)))) 57132532))) +;;; rewrite the test case to get the unsigned-byte 32/64 +;;; implementation even after implementing some modular arithmetic +;;; with signed-byte 30: +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (mask-field (byte 30 2) (ash a 77)))) + 57132532))) +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (mask-field (byte 64 2) (ash a 77)))) + 57132532))) +;;; and a similar test case for the signed masking extension (not the +;;; final interface, so change the call when necessary): +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (sb-c::mask-signed-field 30 (ash a 77)))) + 57132532))) +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (sb-c::mask-signed-field 61 (ash a 77)))) + 57132532))) ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for ;;; type check regeneration @@ -881,19 +998,19 @@ (labels ((%f12 (f12-1 f12-2) (labels ((%f2 (f2-1 f2-2) (flet ((%f6 () - (flet ((%f18 + (flet ((%f18 (f18-1 &optional (f18-2 a) (f18-3 -207465075) (f18-4 a)) (return-from %f12 b))) - (%f18 -3489553 - -7 - (%f18 (%f18 150 -64 f12-1) - (%f18 (%f18 -8531) - 11410) - b) - 56362666)))) + (%f18 -3489553 + -7 + (%f18 (%f18 150 -64 f12-1) + (%f18 (%f18 -8531) + 11410) + b) + 56362666)))) (labels ((%f7 (f7-1 f7-2 &optional (f7-3 (%f6))) @@ -1189,18 +1306,18 @@ '(lambda (a b c) (declare (notinline boole values denominator list)) (declare - (optimize (speed 2) - (space 0) - (safety 1) - (debug 0) - (compilation-speed 2))) + (optimize (speed 2) + (space 0) + (safety 1) + (debug 0) + (compilation-speed 2))) (catch 'ct6 - (progv - '(*s8*) - (list 0) - (let ((v9 (ignore-errors (throw 'ct6 0)))) - (denominator - (progv nil nil (values (boole boole-and 0 v9))))))))) + (progv + '(*s8*) + (list 0) + (let ((v9 (ignore-errors (throw 'ct6 0)))) + (denominator + (progv nil nil (values (boole boole-and 0 v9))))))))) 1 2 3))) ;;; non-continuous dead UVL blocks @@ -1241,21 +1358,21 @@ nil '(lambda (b g h) (declare (optimize (speed 3) (space 3) (safety 2) - (debug 2) (compilation-speed 3))) + (debug 2) (compilation-speed 3))) (catch 'ct5 - (unwind-protect - (labels ((%f15 (f15-1 f15-2 f15-3) + (unwind-protect + (labels ((%f15 (f15-1 f15-2 f15-3) (rational (throw 'ct5 0)))) - (%f15 0 - (apply #'%f15 - 0 - h - (progn - (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b) - 0) - nil) - 0)) - (common-lisp:handler-case 0))))) + (%f15 0 + (apply #'%f15 + 0 + h + (progn + (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b) + 0) + nil) + 0)) + (common-lisp:handler-case 0))))) 1 2 3)) '(0))) @@ -1305,8 +1422,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))) @@ -1332,10 +1453,10 @@ (handler-case (compile nil '(lambda (x) - (declare (type (integer -100 100) x)) - (declare (optimize speed)) - (declare (notinline identity)) - (1+ (identity x)))) + (declare (type (integer -100 100) x)) + (declare (optimize speed)) + (declare (notinline identity)) + (1+ (identity x)))) (compiler-note () (error "IDENTITY derive-type not applied."))) (assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil))) @@ -1375,17 +1496,17 @@ ;;; efficiency notes for ordinary code (macrolet ((frob (arglist &body body) - `(progn - (handler-case - (compile nil '(lambda ,arglist ,@body)) - (sb-ext:compiler-note (e) - (error "bad compiler note for ~S:~% ~A" ',body e))) - (catch :got-note - (handler-case - (compile nil '(lambda ,arglist (declare (optimize speed)) - ,@body)) - (sb-ext:compiler-note (e) (throw :got-note nil))) - (error "missing compiler note for ~S" ',body))))) + `(progn + (handler-case + (compile nil '(lambda ,arglist ,@body)) + (sb-ext:compiler-note (e) + (error "bad compiler note for ~S:~% ~A" ',body e))) + (catch :got-note + (handler-case + (compile nil '(lambda ,arglist (declare (optimize speed)) + ,@body)) + (sb-ext:compiler-note (e) (throw :got-note nil))) + (error "missing compiler note for ~S" ',body))))) (frob (x) (funcall x)) (frob (x y) (find x y)) (frob (x y) (find-if x y)) @@ -1396,16 +1517,16 @@ (frob (x) (aref x 0))) (macrolet ((frob (style-warn-p form) - (if style-warn-p - `(catch :got-style-warning - (handler-case - (eval ',form) - (style-warning (e) (throw :got-style-warning nil))) - (error "missing style-warning for ~S" ',form)) - `(handler-case - (eval ',form) - (style-warning (e) - (error "bad style-warning for ~S: ~A" ',form e)))))) + (if style-warn-p + `(catch :got-style-warning + (handler-case + (eval ',form) + (style-warning (e) (throw :got-style-warning nil))) + (error "missing style-warning for ~S" ',form)) + `(handler-case + (eval ',form) + (style-warning (e) + (error "bad style-warning for ~S: ~A" ',form e)))))) (frob t (lambda (x &optional y &key z) (list x y z))) (frob nil (lambda (x &optional y z) (list x y z))) (frob nil (lambda (x &key y z) (list x y z))) @@ -1419,27 +1540,27 @@ ;;; from LOGXOR was small and negative, though the bottom one worked. (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda () - (declare (optimize speed (safety 0))) - (lambda (x y) - (declare (type (integer 3 6) x) - (type (integer -6 -3) y)) - (+ (logxor x y) most-positive-fixnum))))) + (declare (optimize speed (safety 0))) + (lambda (x y) + (declare (type (integer 3 6) x) + (type (integer -6 -3) y)) + (+ (logxor x y) most-positive-fixnum))))) (handler-bind ((sb-ext:compiler-note #'error)) (compile nil '(lambda () - (declare (optimize speed (safety 0))) - (lambda (x y) - (declare (type (integer 3 6) y) - (type (integer -6 -3) x)) - (+ (logxor x y) most-positive-fixnum))))) + (declare (optimize speed (safety 0))) + (lambda (x y) + (declare (type (integer 3 6) y) + (type (integer -6 -3) x)) + (+ (logxor x y) most-positive-fixnum))))) ;;; check that modular ash gives the right answer, to protect against ;;; possible misunderstandings about the hardware shift instruction. (assert (zerop (funcall - (compile nil '(lambda (x y) - (declare (optimize speed) - (type (unsigned-byte 32) x y)) - (logand #xffffffff (ash x y)))) - 1 257))) + (compile nil '(lambda (x y) + (declare (optimize speed) + (type (unsigned-byte 32) x y)) + (logand #xffffffff (ash x y)))) + 1 257))) ;;; code instrumenting problems (compile nil @@ -1505,22 +1626,22 @@ (declare (type (integer -4085 0) b)) (declare (ignorable a b)) (declare - (optimize (space 2) - (compilation-speed 0) - #+sbcl (sb-c:insert-step-conditions 0) - (debug 2) - (safety 0) - (speed 3))) + (optimize (space 2) + (compilation-speed 0) + #+sbcl (sb-c:insert-step-conditions 0) + (debug 2) + (safety 0) + (speed 3))) (let ((*s5* 0)) - (dotimes (iv1 2 0) - (let ((*s5* - (elt '(1954479092053) - (min 0 - (max 0 - (if (< iv1 iv1) - (lognand iv1 (ash iv1 (min 53 iv1))) - iv1)))))) - 0))))) + (dotimes (iv1 2 0) + (let ((*s5* + (elt '(1954479092053) + (min 0 + (max 0 + (if (< iv1 iv1) + (lognand iv1 (ash iv1 (min 53 iv1))) + iv1)))))) + 0))))) -7639589303599 -1368))) (compile @@ -1544,15 +1665,15 @@ '(lambda (a b c d) (declare (notinline aref logandc2 gcd make-array)) (declare - (optimize (space 0) (safety 0) (compilation-speed 3) - (speed 3) (debug 1))) + (optimize (space 0) (safety 0) (compilation-speed 3) + (speed 3) (debug 1))) (progn - (tagbody - (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2))))) - (declare (dynamic-extent v2)) - (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2)))) - tag2) - 0))) + (tagbody + (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2))))) + (declare (dynamic-extent v2)) + (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2)))) + tag2) + 0))) 3021871717588 -866608 -2 -17194))) ;;; MISC.436, 438: lost reoptimization @@ -1564,39 +1685,39 @@ (declare (type (integer 0 160159) b)) (declare (ignorable a b)) (declare - (optimize (compilation-speed 1) - (speed 3) - (safety 3) - (space 0) - ; #+sbcl (sb-c:insert-step-conditions 0) - (debug 0))) + (optimize (compilation-speed 1) + (speed 3) + (safety 3) + (space 0) + ; #+sbcl (sb-c:insert-step-conditions 0) + (debug 0))) (if - (oddp - (loop for - lv1 - below - 2 - count - (logbitp 0 - (1- - (ash b - (min 8 - (count 0 - '(-10197561 486 430631291 - 9674068)))))))) - b - 0))) + (oddp + (loop for + lv1 + below + 2 + count + (logbitp 0 + (1- + (ash b + (min 8 + (count 0 + '(-10197561 486 430631291 + 9674068)))))))) + b + 0))) 1265797 110757))) (assert (zerop (funcall (compile nil ' (lambda (a) - (declare (type (integer 0 1696) a)) - ; (declare (ignorable a)) - (declare (optimize (space 2) (debug 0) (safety 1) - (compilation-speed 0) (speed 1))) - (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) + (declare (type (integer 0 1696) a)) + ; (declare (ignorable a)) + (declare (optimize (space 2) (debug 0) (safety 1) + (compilation-speed 0) (speed 1))) + (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0))) 805))) ;;; bug #302 @@ -1648,3 +1769,1151 @@ (multiple-value-bind (res err) (ignore-errors (funcall fun)) (assert (not res)) (assert (typep err 'program-error)))) + +(let ((fun (compile nil '(lambda (x) (random (if x 10 20)))))) + (dotimes (i 100 (error "bad RANDOM distribution")) + (when (> (funcall fun nil) 9) + (return t))) + (dotimes (i 100) + (when (> (funcall fun t) 9) + (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) + (handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c)))) + (compile nil + '(lambda (x y v) + (declare (optimize (speed 3) (safety 0))) + (declare (type (integer 0 80) x) + (type (integer 0 11) y) + (type (simple-array (unsigned-byte 32) (*)) v)) + (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y)) + nil)))) + +;;; Bug reported by Robert J. Macomber: instrumenting of more-entry +;;; prevented open coding of %LISTIFY-REST-ARGS. +(let ((f (compile nil '(lambda () + (declare (optimize (debug 3))) + (with-simple-restart (blah "blah") (error "blah")))))) + (handler-bind ((error (lambda (c) (invoke-restart 'blah)))) + (assert (equal (multiple-value-list (funcall f)) '(nil t))))) + +;;; Bug reported by Timmy Douglas: overflow in bit vector setter with +;;; constant index and value. +(loop for n-bits = 1 then (* n-bits 2) + for type = `(unsigned-byte ,n-bits) + and v-max = (1- (ash 1 n-bits)) + while (<= n-bits sb-vm:n-word-bits) + do + (let* ((n (* 2 (1+ (- sb-vm::n-word-bits n-bits)))) + (array1 (make-array n :element-type type)) + (array2 (make-array n :element-type type))) + (dotimes (i n) + (dolist (v (list 0 v-max)) + (let ((f (compile nil `(lambda (a) + (declare (type (simple-array ,type (,n)) a)) + (setf (aref a ,i) ,v))))) + (fill array1 (- v-max v)) + (fill array2 (- v-max v)) + (funcall f array1) + (setf (aref array2 i) v) + (assert (every #'= array1 array2))))))) + +(let ((fn (compile nil '(lambda (x) + (declare (type bit x)) + (declare (optimize speed)) + (let ((b (make-array 64 :element-type 'bit + :initial-element 0))) + (count x b)))))) + (assert (= (funcall fn 0) 64)) + (assert (= (funcall fn 1) 0))) + +(let ((fn (compile nil '(lambda (x y) + (declare (type simple-bit-vector x y)) + (declare (optimize speed)) + (equal x y))))) + (assert (funcall + fn + (make-array 64 :element-type 'bit :initial-element 0) + (make-array 64 :element-type 'bit :initial-element 0))) + (assert (not + (funcall + fn + (make-array 64 :element-type 'bit :initial-element 0) + (let ((b (make-array 64 :element-type 'bit :initial-element 0))) + (setf (sbit b 63) 1) + b))))) + +;;; MISC.535: compiler failure +(let ((c0 #c(4196.088977268509d0 -15943.3603515625d0))) + (assert (not (funcall + (compile + nil + `(lambda (p1 p2) + (declare (optimize speed (safety 1)) + (type (eql ,c0) p1) + (type number p2)) + (eql (the (complex double-float) p1) p2))) + c0 #c(12 612/979))))) + +;;; reported by Lutz Euler: we shouldn't signal a compiler note for +;;; simple-bit-vector functions. +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x) + (declare (type simple-bit-vector x)) + (count 1 x)))) +(handler-bind ((sb-ext:compiler-note #'error)) + (compile nil '(lambda (x y) + (declare (type simple-bit-vector x y)) + (equal x y)))) + +;;; MISC.550: CAST merging in IR1 finalization caused unexpected +;;; code transformations. +(assert (eql (funcall + (compile + nil + '(lambda (p1 p2) + (declare (optimize (speed 3) (safety 2) (debug 3) (space 3)) + (type atom p1) + (type symbol p2)) + (or p1 (the (eql t) p2)))) + nil t) + t)) + +;;; MISC.548: type check weakening converts required type into +;;; optional +(assert (eql t + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 2) (safety 1) (debug 3) (space 2))) + (atom (the (member f assoc-if write-line t w) p1)))) + t))) + +;;; Free special bindings only apply to the body of the binding form, not +;;; the initialization forms. +(assert (eq :good + (funcall (compile 'nil + (lambda () + (let ((x :bad)) + (declare (special x)) + (let ((x :good)) + ((lambda (&optional (y x)) + (declare (special x)) y))))))))) + +;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of +;;; a rational was zero, but didn't do the substitution, leading to a +;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the +;;; machine's ASH instruction's immediate field) that the compiler +;;; thought was legitimate. +;;; +;;; FIXME: this has been recorded as bug 383. The attempted fix (sbcl +;;; 0.9.2.6) led to lots of spurious optimization notes. So the bug stil +;;; exist and this test case serves as a reminder of the problem. +;;; --njf, 2005-07-05 +#+nil +(compile 'nil + (LAMBDA (B) + (DECLARE (TYPE (INTEGER -2 14) B)) + (DECLARE (IGNORABLE B)) + (ASH (IMAGPART B) 57))) + +;;; bug reported by Eduardo Mu\~noz +(multiple-value-bind (fun warnings failure) + (compile nil '(lambda (struct first) + (declare (optimize speed)) + (let* ((nodes (nodes struct)) + (bars (bars struct)) + (length (length nodes)) + (new (make-array length :fill-pointer 0))) + (vector-push first new) + (loop with i fixnum = 0 + for newl fixnum = (length new) + while (< newl length) do + (let ((oldl (length new))) + (loop for j fixnum from i below newl do + (dolist (n (node-neighbours (aref new j) bars)) + (unless (find n new) + (vector-push n new)))) + (setq i oldl))) + new))) + (declare (ignore fun warnings failure)) + (assert (not failure))) + +;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe +;;; sbcl-devel) +(compile nil '(lambda (x y a b c) + (- y (* (signum x) (sqrt (abs (- (* b x) c))))))) + +;;; Type inference from CHECK-TYPE +(let ((count0 0) (count1 0)) + (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count0)))) + (compile nil '(lambda (x) + (declare (optimize (speed 3))) + (1+ x)))) + ;; 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)))) + ;; 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: # 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))))) + + +;;; 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))))) + +;;; Compiling W-P-O when the pinned objects are known to be fixnums +;;; or characters. +(compile nil '(lambda (x y) + (declare (fixnum y) (character x)) + (sb-sys:with-pinned-objects (x y) + (some-random-function)))) + +;;; *CHECK-CONSISTENCY* and TRULY-THE + +(with-test (:name :bug-423) + (let ((sb-c::*check-consistency* t)) + (handler-bind ((warning #'error)) + (flet ((make-lambda (type) + `(lambda (x) + ((lambda (z) + (if (listp z) + (let ((q (truly-the list z))) + (length q)) + (if (arrayp z) + (let ((q (truly-the vector z))) + (length q)) + (error "oops")))) + (the ,type x))))) + (compile nil (make-lambda 'list)) + (compile nil (make-lambda 'vector)))))) + +;;; this caused a momentary regression when an ill-adviced fix to +;;; bug 427 made ANY-REG suitable for primitive-type T: +;;; +;;; no :MOVE-ARG VOP defined to move # (SC SB-VM::SINGLE-REG) to # (SC SB-VM::ANY-REG) +;;; [Condition of type SIMPLE-ERROR] +(compile nil + '(lambda (frob) + (labels + ((%zig (frob) + (typecase frob + (double-float + (setf (sb-alien:deref (sb-alien:cast (sb-alien:sap-alien (unknown1) (* unsigned-char)) + (* double-float))) frob)) + (hash-table + (%zig (the (values (single-float (0.0) 1.0) &optional) (unknown2))) + nil)))) + (%zig)))) + +;;; non-required arguments in HANDLER-BIND +(assert (eq :oops (car (funcall (compile nil + '(lambda (x) + (block nil + (handler-bind ((error (lambda (&rest args) (return (cons :oops args))))) + (/ 2 x))))) + 0)))) + +;;; NIL is a legal function name +(assert (eq 'a (flet ((nil () 'a)) (nil)))) + +;;; misc.528 +(assert (null (let* ((x 296.3066f0) + (y 22717067) + (form `(lambda (r p2) + (declare (optimize speed (safety 1)) + (type (simple-array single-float nil) r) + (type (integer -9369756340 22717335) p2)) + (setf (aref r) (* ,x (the (eql 22717067) p2))) + (values))) + (r (make-array nil :element-type 'single-float)) + (expected (* x y))) + (funcall (compile nil form) r y) + (let ((actual (aref r))) + (unless (eql expected actual) + (list expected actual)))))) +;;; misc.529 +(assert (null (let* ((x -2367.3296f0) + (y 46790178) + (form `(lambda (r p2) + (declare (optimize speed (safety 1)) + (type (simple-array single-float nil) r) + (type (eql 46790178) p2)) + (setf (aref r) (+ ,x (the (integer 45893897) p2))) + (values))) + (r (make-array nil :element-type 'single-float)) + (expected (+ x y))) + (funcall (compile nil form) r y) + (let ((actual (aref r))) + (unless (eql expected actual) + (list expected actual)))))) + +;;; misc.556 +(assert (eql -1 + (funcall + (compile nil '(lambda (p1 p2) + (declare + (optimize (speed 1) (safety 0) + (debug 0) (space 0)) + (type (member 8174.8604) p1) + (type (member -95195347) p2)) + (floor p1 p2))) + 8174.8604 -95195347))) + +;;; misc.557 +(assert (eql -1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 3) (safety 0) (debug 3) (space 1)) + (type (member -94430.086f0) p1)) + (floor (the single-float p1) 19311235))) + -94430.086f0))) + +;;; misc.558 +(assert (eql -1.0f0 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 2) + (debug 2) (space 3)) + (type (eql -39466.56f0) p1)) + (ffloor p1 305598613))) + -39466.56f0))) + +;;; misc.559 +(assert (eql 1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 1) (debug 1) (space 2)) + (type (eql -83232.09f0) p1)) + (ceiling p1 -83381228))) + -83232.09f0))) + +;;; misc.560 +(assert (eql 1 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 1) (safety 1) + (debug 1) (space 0)) + (type (member -66414.414f0) p1)) + (ceiling p1 -63019173f0))) + -66414.414f0))) + +;;; misc.561 +(assert (eql 1.0f0 + (funcall + (compile + nil + '(lambda (p1) + (declare (optimize (speed 0) (safety 1) + (debug 0) (space 1)) + (type (eql 20851.398f0) p1)) + (fceiling p1 80839863))) + 20851.398f0))) + +;;; misc.581 +(assert (floatp + (funcall + (compile nil '(lambda (x) + (declare (type (eql -5067.2056) x)) + (+ 213734822 x))) + -5067.2056))) + +;;; misc.581a +(assert (typep + (funcall + (compile nil '(lambda (x) (declare (type (eql -1.0) x)) + (+ #x1000001 x))) + -1.0f0) + 'single-float)) + +;;; misc.582 +(assert (plusp (funcall + (compile + nil + ' (lambda (p1) + (declare (optimize (speed 0) (safety 1) (debug 1) (space 1)) + (type (eql -39887.645) p1)) + (mod p1 382352925))) + -39887.645))) + +;;; misc.587 +(assert (let ((result (funcall + (compile + nil + '(lambda (p2) + (declare (optimize (speed 0) (safety 3) (debug 1) (space 0)) + (type (eql 33558541) p2)) + (- 92215.266 p2))) + 33558541))) + (typep result 'single-float))) + +;;; misc.635 +(assert (eql 1 + (let* ((form '(lambda (p2) + (declare (optimize (speed 0) (safety 1) + (debug 2) (space 2)) + (type (member -19261719) p2)) + (ceiling -46022.094 p2)))) + (values (funcall (compile nil form) -19261719))))) + +;;; misc.636 +(assert (let* ((x 26899.875) + (form `(lambda (p2) + (declare (optimize (speed 3) (safety 1) (debug 3) (space 1)) + (type (member ,x #:g5437 char-code #:g5438) p2)) + (* 104102267 p2)))) + (floatp (funcall (compile nil form) x)))) + +;;; misc.622 +(assert (eql + (funcall + (compile + nil + '(lambda (p2) + (declare (optimize (speed 3) (safety 2) (debug 3) (space 0)) + (type real p2)) + (+ 81535869 (the (member 17549.955 #:g35917) p2)))) + 17549.955) + (+ 81535869 17549.955))) + +;;; misc.654 +(assert (eql 2 + (let ((form '(lambda (p2) + (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) + (type (member integer eql) p2)) + (coerce 2 p2)))) + (funcall (compile nil form) 'integer)))) + +;;; misc.656 +(assert (eql 2 + (let ((form '(lambda (p2) + (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) + (type (member integer mod) p2)) + (coerce 2 p2)))) + (funcall (compile nil form) 'integer)))) + +;;; misc.657 +(assert (eql 2 + (let ((form '(lambda (p2) + (declare (optimize (speed 0) (safety 2) (debug 0) (space 2)) + (type (member integer values) p2)) + (coerce 2 p2)))) + (funcall (compile nil form) 'integer)))) + +(with-test (:name :string-aref-type) + (assert (eq 'character + (funcall (compile nil + '(lambda (s) + (sb-c::compiler-derived-type (aref (the string s) 0)))) + "foo")))) + +(with-test (:name :base-string-aref-type) + (assert (eq #+sb-unicode 'base-char + #-sb-unicode 'character + (funcall (compile nil + '(lambda (s) + (sb-c::compiler-derived-type (aref (the base-string s) 0)))) + (coerce "foo" 'base-string))))) + +(with-test (:name :dolist-constant-type-derivation) + (assert (equal '(integer 1 3) + (funcall (compile nil + '(lambda (x) + (dolist (y '(1 2 3)) + (when x + (return (sb-c::compiler-derived-type y)))))) + t)))) + +(with-test (:name :dolist-simple-list-type-derivation) + (assert (equal '(integer 1 3) + (funcall (compile nil + '(lambda (x) + (dolist (y (list 1 2 3)) + (when x + (return (sb-c::compiler-derived-type y)))))) + t)))) + +(with-test (:name :dolist-dotted-constant-list-type-derivation) + (let* ((warned nil) + (fun (handler-bind ((style-warning (lambda (c) (push c warned)))) + (compile nil + '(lambda (x) + (dolist (y '(1 2 3 . 4) :foo) + (when x + (return (sb-c::compiler-derived-type y))))))))) + (assert (equal '(integer 1 3) (funcall fun t))) + (assert (= 1 (length warned))) + (multiple-value-bind (res err) (ignore-errors (funcall fun nil)) + (assert (not res)) + (assert (typep err 'type-error))))) + +(with-test (:name :constant-list-destructuring) + (handler-bind ((sb-ext:compiler-note #'error)) + (progn + (assert (= 10 + (funcall + (compile nil + '(lambda () + (destructuring-bind (a (b c) d) '(1 (2 3) 4) + (+ a b c d))))))) + (assert (eq :feh + (funcall + (compile nil + '(lambda (x) + (or x + (destructuring-bind (a (b c) d) '(1 "foo" 4) + (+ a b c d))))) + :feh)))))) + +;;; Functions with non-required arguments used to end up with +;;; (&OPTIONAL-DISPATCH ...) as their names. +(with-test (:name :hairy-function-name) + (assert (eq 'read-line (nth-value 2 (function-lambda-expression #'read-line)))) + (assert (equal "#" (princ-to-string #'read-line)))) + +;;; PROGV + RESTRICT-COMPILER-POLICY +(with-test (:name :progv-and-restrict-compiler-policy) + (let ((sb-c::*policy-restrictions* sb-c::*policy-restrictions*)) + (restrict-compiler-policy 'debug 3) + (let ((fun (compile nil '(lambda (x) + (let ((i x)) + (declare (special i)) + (list i + (progv '(i) (list (+ i 1)) + i) + i)))))) + (assert (equal '(1 2 1) (funcall fun 1)))))) + +;;; It used to be possible to confuse the compiler into +;;; IR2-converting such a call to CONS +(with-test (:name :late-bound-primitive) + (compile nil `(lambda () + (funcall 'cons 1)))) + +(with-test (:name :hairy-array-element-type-derivation) + (compile nil '(lambda (x) + (declare (type (and simple-string (satisfies array-has-fill-pointer-p)) x)) + (array-element-type x)))) + +(with-test (:name :rest-list-type-derivation) + (multiple-value-bind (type derivedp) + (funcall (compile nil `(lambda (&rest args) + (sb-c::compiler-derived-type args))) + nil) + (assert (eq 'list type)) + (assert derivedp))) + +(with-test (:name :base-char-typep-elimination) + (assert (eq (funcall (lambda (ch) + (declare (type base-char ch) (optimize (speed 3) (safety 0))) + (typep ch 'base-char)) + t) + t))) + +(with-test (:name :regression-1.0.24.37) + (compile nil '(lambda (&key (test (constantly t))) + (when (funcall test) + :quux)))) + +;;; Attempt to test a decent cross section of conditions +;;; and values types to move conditionally. +(macrolet + ((test-comparison (comparator type x y) + `(progn + ,@(loop for (result-type a b) + in '((nil t nil) + (nil 0 1) + (nil 0.0 1.0) + (nil 0d0 0d0) + (nil 0.0 0d0) + (nil #c(1.0 1.0) #c(2.0 2.0)) + + (t t nil) + (fixnum 0 1) + ((unsigned-byte #.sb-vm:n-word-bits) + (1+ most-positive-fixnum) + (+ 2 most-positive-fixnum)) + ((signed-byte #.sb-vm:n-word-bits) + -1 (* 2 most-negative-fixnum)) + (single-float 0.0 1.0) + (double-float 0d0 1d0)) + for lambda = (if result-type + `(lambda (x y a b) + (declare (,type x y) + (,result-type a b)) + (if (,comparator x y) + a b)) + `(lambda (x y) + (declare (,type x y)) + (if (,comparator x y) + ,a ,b))) + for args = `(,x ,y ,@(and result-type + `(,a ,b))) + collect + `(progn + (eql (funcall (compile nil ',lambda) + ,@args) + (eval '(,lambda ,@args)))))))) + (sb-vm::with-float-traps-masked + (:divide-by-zero :overflow :inexact :invalid) + (let ((sb-ext:*evaluator-mode* :interpret)) + (declare (sb-ext:muffle-conditions style-warning)) + (test-comparison eql t t nil) + (test-comparison eql t t t) + + (test-comparison = t 1 0) + (test-comparison = t 1 1) + (test-comparison = t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum)) + (test-comparison = fixnum 1 0) + (test-comparison = fixnum 0 0) + (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 0 0) + (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 1) + + (test-comparison = single-float 0.0 1.0) + (test-comparison = single-float 1.0 1.0) + (test-comparison = single-float (/ 1.0 0.0) (/ 1.0 0.0)) + (test-comparison = single-float (/ 1.0 0.0) 1.0) + (test-comparison = single-float (/ 0.0 0.0) (/ 0.0 0.0)) + (test-comparison = single-float (/ 0.0 0.0) 0.0) + + (test-comparison = double-float 0d0 1d0) + (test-comparison = double-float 1d0 1d0) + (test-comparison = double-float (/ 1d0 0d0) (/ 1d0 0d0)) + (test-comparison = double-float (/ 1d0 0d0) 1d0) + (test-comparison = double-float (/ 0d0 0d0) (/ 0d0 0d0)) + (test-comparison = double-float (/ 0d0 0d0) 0d0) + + (test-comparison < t 1 0) + (test-comparison < t 0 1) + (test-comparison < t 1 1) + (test-comparison < t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum)) + (test-comparison < t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum)) + (test-comparison < fixnum 1 0) + (test-comparison < fixnum 0 1) + (test-comparison < fixnum 0 0) + (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 0) + (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison < (signed-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 1) + + (test-comparison < single-float 0.0 1.0) + (test-comparison < single-float 1.0 0.0) + (test-comparison < single-float 1.0 1.0) + (test-comparison < single-float (/ 1.0 0.0) (/ 1.0 0.0)) + (test-comparison < single-float (/ 1.0 0.0) 1.0) + (test-comparison < single-float 1.0 (/ 1.0 0.0)) + (test-comparison < single-float (/ 0.0 0.0) (/ 0.0 0.0)) + (test-comparison < single-float (/ 0.0 0.0) 0.0) + + (test-comparison < double-float 0d0 1d0) + (test-comparison < double-float 1d0 0d0) + (test-comparison < double-float 1d0 1d0) + (test-comparison < double-float (/ 1d0 0d0) (/ 1d0 0d0)) + (test-comparison < double-float (/ 1d0 0d0) 1d0) + (test-comparison < double-float 1d0 (/ 1d0 0d0)) + (test-comparison < double-float (/ 0d0 0d0) (/ 0d0 0d0)) + (test-comparison < double-float (/ 0d0 0d0) 0d0) + (test-comparison < double-float 0d0 (/ 0d0 0d0)) + + (test-comparison > t 1 0) + (test-comparison > t 0 1) + (test-comparison > t 1 1) + (test-comparison > t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum)) + (test-comparison > t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum)) + (test-comparison > fixnum 1 0) + (test-comparison > fixnum 0 1) + (test-comparison > fixnum 0 0) + (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 0) + (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 0) + (test-comparison > (signed-byte #.sb-vm:n-word-bits) 0 1) + (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 1) + + (test-comparison > single-float 0.0 1.0) + (test-comparison > single-float 1.0 0.0) + (test-comparison > single-float 1.0 1.0) + (test-comparison > single-float (/ 1.0 0.0) (/ 1.0 0.0)) + (test-comparison > single-float (/ 1.0 0.0) 1.0) + (test-comparison > single-float 1.0 (/ 1.0 0.0)) + (test-comparison > single-float (/ 0.0 0.0) (/ 0.0 0.0)) + (test-comparison > single-float (/ 0.0 0.0) 0.0) + + (test-comparison > double-float 0d0 1d0) + (test-comparison > double-float 1d0 0d0) + (test-comparison > double-float 1d0 1d0) + (test-comparison > double-float (/ 1d0 0d0) (/ 1d0 0d0)) + (test-comparison > double-float (/ 1d0 0d0) 1d0) + (test-comparison > double-float 1d0 (/ 1d0 0d0)) + (test-comparison > double-float (/ 0d0 0d0) (/ 0d0 0d0)) + (test-comparison > double-float (/ 0d0 0d0) 0d0) + (test-comparison > double-float 0d0 (/ 0d0 0d0))))) + +(with-test (:name :car-and-cdr-type-derivation-conservative) + (let ((f1 (compile nil + `(lambda (y) + (declare (optimize speed)) + (let ((x (the (cons fixnum fixnum) (cons 1 2)))) + (declare (type (cons t fixnum) x)) + (rplaca x y) + (+ (car x) (cdr x)))))) + (f2 (compile nil + `(lambda (y) + (declare (optimize speed)) + (let ((x (the (cons fixnum fixnum) (cons 1 2)))) + (setf (cdr x) y) + (+ (car x) (cdr x))))))) + (flet ((test-error (e value) + (assert (typep e 'type-error)) + (assert (eq 'number (type-error-expected-type e))) + (assert (eq value (type-error-datum e))))) + (let ((v1 "foo") + (v2 "bar")) + (multiple-value-bind (res err) (ignore-errors (funcall f1 v1)) + (assert (not res)) + (test-error err v1)) + (multiple-value-bind (res err) (ignore-errors (funcall f2 v2)) + (assert (not res)) + (test-error err v2)))))) + +(with-test (:name :array-dimension-derivation-conservative) + (let ((f (compile nil + `(lambda (x) + (declare (optimize speed)) + (declare (type (array * (4 4)) x)) + (let ((y x)) + (setq x (make-array '(4 4))) + (adjust-array y '(3 5)) + (array-dimension y 0)))))) + (assert (= 3 (funcall f (make-array '(4 4) :adjustable t)))))) + +(with-test (:name :with-timeout-code-deletion-note) + (handler-bind ((sb-ext:code-deletion-note #'error)) + (compile nil `(lambda () + (sb-ext:with-timeout 0 + (sleep 1)))))) + +(with-test (:name :full-warning-for-undefined-type-in-cl) + (assert (eq :full + (handler-case + (compile nil `(lambda (x) (the replace x))) + (style-warning () + :style) + (warning () + :full))))) + +(with-test (:name :single-warning-for-single-undefined-type) + (let ((n 0)) + (handler-bind ((warning (lambda (c) + (declare (ignore c)) + (incf n)))) + (compile nil `(lambda (x) (the #:no-type x))) + (assert (= 1 n)) + (compile nil `(lambda (x) (the 'fixnum x))) + (assert (= 2 n))))) + +(with-test (:name :complex-subtype-dumping-in-xc) + (assert + (= sb-vm:complex-single-float-widetag + (sb-kernel:widetag-of + (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex single-float)))))) + (assert + (= sb-vm:complex-double-float-widetag + (sb-kernel:widetag-of + (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex double-float))))))) + +(with-test (:name :complex-single-float-fill) + (assert (every (lambda (x) (= #c(1.0 2.0) x)) + (funcall + (compile nil + `(lambda (n x) + (make-array (list n) + :element-type '(complex single-float) + :initial-element x))) + 10 + #c(1.0 2.0)))))