X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fcompiler.pure.lisp;h=9167b6b66da50341b591bad6f8b7f21a3bc32492;hb=c43e3ee7e99bf8116402c2e6a90320b2e92b391b;hp=9776ae2c6584ea2e70b2d0336de731eecc97d3b9;hpb=61c18727668ff0c3263a3d363e609d4522d545cc;p=sbcl.git diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp index 9776ae2..9167b6b 100644 --- a/tests/compiler.pure.lisp +++ b/tests/compiler.pure.lisp @@ -6,13 +6,17 @@ ;;;; 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 :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 +25,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 +95,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 +171,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 +198,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 +321,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 +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)))) @@ -389,8 +459,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 () @@ -460,17 +530,17 @@ (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-string 3) (5)) x)) + (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 +554,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 +636,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,9 +707,1486 @@ ;;; 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 +(compile nil '(lambda () + (let (r3533) + (flet ((bbfn () + (setf r3533 + (progn + (flet ((truly (fn bbd) + (let (r3534) + (let ((p3537 nil)) + (unwind-protect + (multiple-value-prog1 + (progn + (setf r3534 + (progn + (bubf bbd t) + (flet ((c-3536 () + (funcall fn))) + (cdec #'c-3536 + (vector bbd)))))) + (setf p3537 t)) + (unless p3537 + (error "j")))) + r3534)) + (c (pd) (pdc pd))) + (let ((a (smock a)) + (b (smock b)) + (b (smock c))))))))) + (wum #'bbfn "hc3" (list))) + r3533))) +(compile nil '(lambda () (flet ((%f () (unwind-protect nil))) nil))) + +;;; the strength reduction of constant multiplication used (before +;;; sbcl-0.8.4.x) to lie to the compiler. This meant that, under +;;; certain circumstances, the compiler would derive that a perfectly +;;; 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)) + +;;; bug in modular arithmetic and type specifiers +(assert (= (funcall (compile nil (lambda (x) (logand x x 0))) + -1) + 0)) + +;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP +;;; produced wrong result for shift >=32 on X86 +(assert (= 0 (funcall + (compile nil + '(lambda (a) + (declare (type (integer 4303063 101130078) a)) + (mask-field (byte 18 2) (ash a 77)))) + 57132532))) + +;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for +;;; type check regeneration +(assert (eql (funcall + (compile nil '(lambda (a c) + (declare (type (integer 185501219873 303014665162) a)) + (declare (type (integer -160758 255724) c)) + (declare (optimize (speed 3))) + (let ((v8 + (- -554046873252388011622614991634432 + (ignore-errors c) + (unwind-protect 2791485)))) + (max (ignore-errors a) + (let ((v6 (- v8 (restart-case 980)))) + (min v8 v6)))))) + 259448422916 173715) + 259448422916)) +(assert (eql (funcall + (compile nil '(lambda (a b) + (min -80 + (abs + (ignore-errors + (+ + (logeqv b + (block b6 + (return-from b6 + (load-time-value -6876935)))) + (if (logbitp 1 a) b (setq a -1522022182249)))))))) + -1802767029877 -12374959963) + -80)) + +;;; various MISC.*, related to NODEs/LVARs with derived type NIL +(assert (eql (funcall (compile nil '(lambda (c) + (declare (type (integer -3924 1001809828) c)) + (declare (optimize (speed 3))) + (min 47 (if (ldb-test (byte 2 14) c) + -570344431 + (ignore-errors -732893970))))) + 705347625) + -570344431)) +(assert (eql (funcall + (compile nil '(lambda (b) + (declare (type (integer -1598566306 2941) b)) + (declare (optimize (speed 3))) + (max -148949 (ignore-errors b)))) + 0) + 0)) +(assert (eql (funcall + (compile nil '(lambda (b c) + (declare (type (integer -4 -3) c)) + (block b7 + (flet ((%f1 (f1-1 f1-2 f1-3) + (if (logbitp 0 (return-from b7 + (- -815145138 f1-2))) + (return-from b7 -2611670) + 99345))) + (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2))) + b))))) + 2950453607 -4) + -815145134)) +(assert (eql (funcall + (compile nil + '(lambda (b c) + (declare (type (integer -29742055786 23602182204) b)) + (declare (type (integer -7409 -2075) c)) + (declare (optimize (speed 3))) + (floor + (labels ((%f2 () + (block b6 + (ignore-errors (return-from b6 + (if (= c 8) b 82674)))))) + (%f2))))) + 22992834060 -5833) + 82674)) +(assert (equal (multiple-value-list + (funcall + (compile nil '(lambda (a) + (declare (type (integer -944 -472) a)) + (declare (optimize (speed 3))) + (round + (block b3 + (return-from b3 + (if (= 55957 a) -117 (ignore-errors + (return-from b3 a)))))))) + -589)) + '(-589 0))) + +;;; MISC.158 +(assert (zerop (funcall + (compile nil + '(lambda (a b c) + (declare (type (integer 79828 2625480458) a)) + (declare (type (integer -4363283 8171697) b)) + (declare (type (integer -301 0) c)) + (if (equal 6392154 (logxor a b)) + 1706 + (let ((v5 (abs c))) + (logand v5 + (logior (logandc2 c v5) + (common-lisp:handler-case + (ash a (min 36 22477))))))))) + 100000 0 0))) + +;;; MISC.152, 153: deleted code and iteration var type inference +(assert (eql (funcall + (compile nil + '(lambda (a) + (block b5 + (let ((v1 (let ((v8 (unwind-protect 9365))) + 8862008))) + (* + (return-from b5 + (labels ((%f11 (f11-1) f11-1)) + (%f11 87246015))) + (return-from b5 + (setq v1 + (labels ((%f6 (f6-1 f6-2 f6-3) v1)) + (dpb (unwind-protect a) + (byte 18 13) + (labels ((%f4 () 27322826)) + (%f6 -2 -108626545 (%f4)))))))))))) + -6) + 87246015)) + +(assert (eql (funcall + (compile nil + '(lambda (a) + (if (logbitp 3 + (case -2 + ((-96879 -1035 -57680 -106404 -94516 -125088) + (unwind-protect 90309179)) + ((-20811 -86901 -9368 -98520 -71594) + (let ((v9 (unwind-protect 136707))) + (block b3 + (setq v9 + (let ((v4 (return-from b3 v9))) + (- (ignore-errors (return-from b3 v4)))))))) + (t -50))) + -20343 + a))) + 0) + -20343)) + +;;; MISC.165 +(assert (eql (funcall + (compile + nil + '(lambda (a b c) + (block b3 + (flet ((%f15 + (f15-1 f15-2 f15-3 + &optional + (f15-4 + (flet ((%f17 + (f17-1 f17-2 f17-3 + &optional (f17-4 185155520) (f17-5 c) + (f17-6 37)) + c)) + (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817))) + (f15-5 a) (f15-6 -40)) + (return-from b3 -16))) + (multiple-value-call #'%f15 (values -519354 a 121 c -1905)))))) + 0 0 -5) + -16)) + +;;; MISC.172 +(assert (eql (funcall + (compile + nil + '(lambda (a b c) + (declare (notinline list apply)) + (declare (optimize (safety 3))) + (declare (optimize (speed 0))) + (declare (optimize (debug 0))) + (labels ((%f12 (f12-1 f12-2) + (labels ((%f2 (f2-1 f2-2) + (flet ((%f6 () + (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)))) + (labels ((%f7 + (f7-1 f7-2 + &optional (f7-3 (%f6))) + 7767415)) + f12-1)))) + (%f2 b -36582571)))) + (apply #'%f12 (list 774 -4413))))) + 0 1 2) + 774)) + +;;; MISC.173 +(assert (eql (funcall + (compile + nil + '(lambda (a b c) + (declare (notinline values)) + (declare (optimize (safety 3))) + (declare (optimize (speed 0))) + (declare (optimize (debug 0))) + (flet ((%f11 + (f11-1 f11-2 + &optional (f11-3 c) (f11-4 7947114) + (f11-5 + (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529)) + 8134)) + (multiple-value-call #'%f3 + (values (%f3 -30637724 b) c))))) + (setq c 555910))) + (if (and nil (%f11 a a)) + (if (%f11 a 421778 4030 1) + (labels ((%f7 + (f7-1 f7-2 + &optional + (f7-3 + (%f11 -79192293 + (%f11 c a c -4 214720) + b + b + (%f11 b 985))) + (f7-4 a)) + b)) + (%f11 c b -25644)) + 54) + -32326608)))) + 1 2 3) + -32326608)) + +;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a +;;; local lambda argument +(assert + (equal + (funcall + (compile nil + '(lambda (a b c) + (declare (type (integer 804561 7640697) a)) + (declare (type (integer -1 10441401) b)) + (declare (type (integer -864634669 55189745) c)) + (declare (ignorable a b c)) + (declare (optimize (speed 3))) + (declare (optimize (safety 1))) + (declare (optimize (debug 1))) + (flet ((%f11 + (f11-1 f11-2) + (labels ((%f4 () (round 200048 (max 99 c)))) + (logand + f11-1 + (labels ((%f3 (f3-1) -162967612)) + (%f3 (let* ((v8 (%f4))) + (setq f11-1 (%f4))))))))) + (%f11 -120429363 (%f11 62362 b))))) + 6714367 9645616 -637681868) + -264223548)) + +;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE +;;; transform +(assert (equal (multiple-value-list + (funcall + (compile nil '(lambda () + (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1))) + (ceiling + (ceiling + (flet ((%f16 () 0)) (%f16)))))))) + '(0 0))) + +;;; MISC.184 +(assert (zerop + (funcall + (compile + nil + '(lambda (a b c) + (declare (type (integer 867934833 3293695878) a)) + (declare (type (integer -82111 1776797) b)) + (declare (type (integer -1432413516 54121964) c)) + (declare (optimize (speed 3))) + (declare (optimize (safety 1))) + (declare (optimize (debug 1))) + (if nil + (flet ((%f15 (f15-1 &optional (f15-2 c)) + (labels ((%f1 (f1-1 f1-2) 0)) + (%f1 a 0)))) + (flet ((%f4 () + (multiple-value-call #'%f15 + (values (%f15 c 0) (%f15 0))))) + (if nil (%f4) + (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0)) + f8-3)) + 0)))) + 0))) + 3040851270 1664281 -1340106197))) + +;;; MISC.249 +(assert (zerop + (funcall + (compile + nil + '(lambda (a b) + (declare (notinline <=)) + (declare (optimize (speed 2) (space 3) (safety 0) + (debug 1) (compilation-speed 3))) + (if (if (<= 0) nil nil) + (labels ((%f9 (f9-1 f9-2 f9-3) + (ignore-errors 0))) + (dotimes (iv4 5 a) (%f9 0 0 b))) + 0))) + 1 2))) + +;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32") +(assert + (= (funcall + (compile + nil + '(lambda (a) + (declare (type (integer 177547470 226026978) a)) + (declare (optimize (speed 3) (space 0) (safety 0) (debug 0) + (compilation-speed 1))) + (logand a (* a 438810)))) + 215067723) + 13739018)) + + +;;;; Bugs in stack analysis +;;; bug 299 (reported by PFD) +(assert + (equal (funcall + (compile + nil + '(lambda () + (declare (optimize (debug 1))) + (multiple-value-call #'list + (if (eval t) (eval '(values :a :b :c)) nil) + (catch 'foo (throw 'foo (values :x :y))))))) + '(:a :b :c :x :y))) +;;; bug 298 (= MISC.183) +(assert (zerop (funcall + (compile + nil + '(lambda (a b c) + (declare (type (integer -368154 377964) a)) + (declare (type (integer 5044 14959) b)) + (declare (type (integer -184859815 -8066427) c)) + (declare (ignorable a b c)) + (declare (optimize (speed 3))) + (declare (optimize (safety 1))) + (declare (optimize (debug 1))) + (block b7 + (flet ((%f3 (f3-1 f3-2 f3-3) 0)) + (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil))))) + 0 6000 -9000000))) +(assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2))))))) + '(1 2))) +(let ((f (compile + nil + '(lambda (x) + (block foo + (multiple-value-call #'list + :a + (block bar + (return-from foo + (multiple-value-call #'list + :b + (block quux + (return-from bar + (catch 'baz + (if x + (return-from quux 1) + (throw 'baz 2)))))))))))))) + (assert (equal (funcall f t) '(:b 1))) + (assert (equal (funcall f nil) '(:a 2)))) + +;;; MISC.185 +(assert (equal + (funcall + (compile + nil + '(lambda (a b c) + (declare (type (integer 5 155656586618) a)) + (declare (type (integer -15492 196529) b)) + (declare (type (integer 7 10) c)) + (declare (optimize (speed 3))) + (declare (optimize (safety 1))) + (declare (optimize (debug 1))) + (flet ((%f3 + (f3-1 f3-2 f3-3 + &optional (f3-4 a) (f3-5 0) + (f3-6 + (labels ((%f10 (f10-1 f10-2 f10-3) + 0)) + (apply #'%f10 + 0 + a + (- (if (equal a b) b (%f10 c a 0)) + (catch 'ct2 (throw 'ct2 c))) + nil)))) + 0)) + (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7) + 0)) +;;; MISC.186 +(assert (eq + (eval + '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1)) + (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil))) + (vars '(b c)) + (fn1 `(lambda ,vars + (declare (type (integer -2 19) b) + (type (integer -1520 218978) c) + (optimize (speed 3) (safety 1) (debug 1))) + ,form)) + (fn2 `(lambda ,vars + (declare (notinline logeqv apply) + (optimize (safety 3) (speed 0) (debug 0))) + ,form)) + (cf1 (compile nil fn1)) + (cf2 (compile nil fn2)) + (result1 (multiple-value-list (funcall cf1 2 18886))) + (result2 (multiple-value-list (funcall cf2 2 18886)))) + (if (equal result1 result2) + :good + (values result1 result2)))) + :good)) + +;;; MISC.290 +(assert (zerop + (funcall + (compile + nil + '(lambda () + (declare + (optimize (speed 3) (space 3) (safety 1) + (debug 2) (compilation-speed 0))) + (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil)))))) + +;;; MISC.292 +(assert (zerop (funcall + (compile + nil + '(lambda (a b) + (declare (optimize (speed 2) (space 0) (safety 3) (debug 1) + (compilation-speed 2))) + (apply (constantly 0) + a + 0 + (catch 'ct6 + (apply (constantly 0) + 0 + 0 + (let* ((v1 + (let ((*s7* 0)) + b))) + 0) + 0 + nil)) + 0 + nil))) + 1 2))) + +;;; misc.295 +(assert (eql + (funcall + (compile + nil + '(lambda () + (declare (optimize (speed 1) (space 0) (safety 0) (debug 0))) + (multiple-value-prog1 + (the integer (catch 'ct8 (catch 'ct7 15867134))) + (catch 'ct1 (throw 'ct1 0)))))) + 15867134)) + +;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error) +;;; could transform known-values LVAR to UVL +(assert (zerop (funcall + (compile + nil + '(lambda (a b c) + (declare (notinline boole values denominator list)) + (declare + (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))))))))) + 1 2 3))) + +;;; non-continuous dead UVL blocks +(defun non-continuous-stack-test (x) + (multiple-value-call #'list + (eval '(values 11 12)) + (eval '(values 13 14)) + (block ext + (return-from non-continuous-stack-test + (multiple-value-call #'list + (eval '(values :b1 :b2)) + (eval '(values :b3 :b4)) + (block int + (return-from ext + (multiple-value-call (eval #'values) + (eval '(values 1 2)) + (eval '(values 3 4)) + (block ext + (return-from int + (multiple-value-call (eval #'values) + (eval '(values :a1 :a2)) + (eval '(values :a3 :a4)) + (block int + (return-from ext + (multiple-value-call (eval #'values) + (eval '(values 5 6)) + (eval '(values 7 8)) + (if x + :ext + (return-from int :int)))))))))))))))) +(assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext))) +(assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int))) + +;;; MISC.362: environment of UNWIND-PROTECTor is different from that +;;; if ENTRY. +(assert (equal (multiple-value-list (funcall + (compile + nil + '(lambda (b g h) + (declare (optimize (speed 3) (space 3) (safety 2) + (debug 2) (compilation-speed 3))) + (catch 'ct5 + (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))))) + 1 2 3)) + '(0))) + + +;;; MISC.275 +(assert + (zerop + (funcall + (compile + nil + '(lambda (b) + (declare (notinline funcall min coerce)) + (declare + (optimize (speed 1) + (space 2) + (safety 2) + (debug 1) + (compilation-speed 1))) + (flet ((%f12 (f12-1) + (coerce + (min + (if f12-1 (multiple-value-prog1 + b (return-from %f12 0)) + 0)) + 'integer))) + (funcall #'%f12 0)))) + -33))) + +;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a +;;; potential problem: optimizers and type derivers for MAX and MIN +;;; were not consistent in treating EQUALP, but not EQL, arguments. +(dolist (f '(min max)) + (loop for complex-arg-args in '((1d0 2d0) (0d0 1d0)) + for complex-arg = `(if x ,@complex-arg-args) + do + (loop for args in `((1 ,complex-arg) + (,complex-arg 1)) + for form = `(,f ,@args) + for f1 = (compile nil `(lambda (x) ,form)) + and f2 = (compile nil `(lambda (x) (declare (notinline min max)) + ,form)) + do + (dolist (x '(nil t)) + (assert (eql (funcall f1 x) (funcall f2 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 (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))) + (block nil + (the double-float + (multiple-value-prog1 + (sqrt (the double-float x)) + (when (< x 0) + (return :minus))))))))) + (assert (eql (funcall f -1d0) :minus)) + (assert (eql (funcall f 4d0) 2d0))) + +;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8) +(handler-case + (compile nil '(lambda (a i) + (locally + (declare (optimize (speed 3) (safety 0) (space 0) (debug 0) + (inhibit-warnings 0))) + (declare (type (alien (* (unsigned 8))) a) + (type (unsigned-byte 32) i)) + (deref a i)))) + (compiler-note () (error "The code is not optimized."))) + +(handler-case + (compile nil '(lambda (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))) + +;;; MISC.293 = easy variant of bug 303: repeated write to the same +;;; LVAR; here the first write may be cleared before the second is +;;; made. +(assert + (zerop + (funcall + (compile + nil + '(lambda () + (declare (notinline complex)) + (declare (optimize (speed 1) (space 0) (safety 1) + (debug 3) (compilation-speed 3))) + (flet ((%f () (multiple-value-prog1 0 (return-from %f 0)))) + (complex (%f) 0))))))) + +;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type +(assert (zerop (funcall + (compile + nil + '(lambda (a c) + (declare (type (integer -1294746569 1640996137) a)) + (declare (type (integer -807801310 3) c)) + (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3))) + (catch 'ct7 + (if + (logbitp 0 + (if (/= 0 a) + c + (ignore-errors + (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0)))) + 0 0)))) + 391833530 -32785211))) + +;;; 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))))) + (frob (x) (funcall x)) + (frob (x y) (find x y)) + (frob (x y) (find-if x y)) + (frob (x y) (find-if-not x y)) + (frob (x y) (position x y)) + (frob (x y) (position-if x y)) + (frob (x y) (position-if-not x y)) + (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)))))) + (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))) + (frob t (defgeneric #:foo (x &optional y &key z))) + (frob nil (defgeneric #:foo (x &optional y z))) + (frob nil (defgeneric #:foo (x &key y z))) + (frob t (defun #:foo (x) (flet ((foo (x &optional y &key z) (list x y z))) (foo x x :z x))))) + +;;; this was a bug in the LOGXOR type deriver. The top form gave a +;;; note, because the system failed to derive the fact that the return +;;; 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))))) +(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))))) + +;;; 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))) + +;;; code instrumenting problems +(compile nil + '(lambda () + (declare (optimize (debug 3))) + (list (the integer (if nil 14 t))))) + +(compile nil + '(LAMBDA (A B C D) + (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD)) + (DECLARE + (OPTIMIZE (SPEED 1) + (SPACE 1) + (SAFETY 1) + (DEBUG 3) + (COMPILATION-SPEED 0))) + (MASK-FIELD (BYTE 7 26) + (PROGN + (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1) + B)))) + +(compile nil + '(lambda (buffer i end) + (declare (optimize (debug 3))) + (loop (when (not (eql 0 end)) (return))) + (let ((s (make-string end))) + (setf (schar s i) (schar buffer i)) + s))) + +;;; check that constant string prefix and suffix don't cause the +;;; compiler to emit code deletion notes. +(handler-bind ((sb-ext:code-deletion-note #'error)) + (compile nil '(lambda (s x) + (pprint-logical-block (s x :prefix "(") + (print x s)))) + (compile nil '(lambda (s x) + (pprint-logical-block (s x :per-line-prefix ";") + (print x s)))) + (compile nil '(lambda (s x) + (pprint-logical-block (s x :suffix ">") + (print x s))))) + +;;; MISC.427: loop analysis requires complete DFO structure +(assert (eql 17 (funcall + (compile + nil + '(lambda (a) + (declare (notinline list reduce logior)) + (declare (optimize (safety 2) (compilation-speed 1) + (speed 3) (space 2) (debug 2))) + (logior + (let* ((v5 (reduce #'+ (list 0 a)))) + (declare (dynamic-extent v5)) + v5)))) + 17))) + +;;; MISC.434 +(assert (zerop (funcall + (compile + nil + '(lambda (a b) + (declare (type (integer -8431780939320 1571817471932) a)) + (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))) + (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))))) + -7639589303599 -1368))) + +(compile + nil + '(lambda (a b) + (declare (type (integer) a)) + (declare (type (integer) b)) + (declare (ignorable a b)) + (declare (optimize (space 2) (compilation-speed 0) + (debug 0) (safety 0) (speed 3))) + (dotimes (iv1 2 0) + (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass + (print (if (< iv1 iv1) + (logand (ash iv1 iv1) 1) + iv1))))) + +;;; MISC.435: lambda var substitution in a deleted code. +(assert (zerop (funcall + (compile + nil + '(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))) + (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))) + 3021871717588 -866608 -2 -17194))) + +;;; MISC.436, 438: lost reoptimization +(assert (zerop (funcall + (compile + nil + '(lambda (a b) + (declare (type (integer -2917822 2783884) a)) + (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))) + (if + (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))) + 805))) + +;;; bug #302 +(assert (compile + nil + '(lambda (s ei x y) + (declare (type (simple-array function (2)) s) (type ei ei)) + (funcall (aref s ei) x y)))) + +;;; MISC.320: ir1-transform can create an intercomponent reference to +;;; a DEFINED-FUN. +(assert (eql 102 (funcall + (compile + nil + '(lambda () + (declare (optimize (speed 3) (space 0) (safety 2) + (debug 2) (compilation-speed 0))) + (catch 'ct2 + (elt '(102) + (flet ((%f12 () (rem 0 -43))) + (multiple-value-call #'%f12 (values)))))))))) + +;;; MISC.437: lost reoptimization after FLUSH-DEST +(assert (zerop (funcall + (compile + nil + '(lambda (a b c d e) + (declare (notinline values complex eql)) + (declare + (optimize (compilation-speed 3) + (speed 3) + (debug 1) + (safety 1) + (space 0))) + (flet ((%f10 + (f10-1 f10-2 f10-3 + &optional (f10-4 (ignore-errors 0)) (f10-5 0) + &key &allow-other-keys) + (if (or (eql 0 0) t) 0 (if f10-1 0 0)))) + (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0)))) + 80043 74953652306 33658947 -63099937105 -27842393))) + +;;; bug #351 -- program-error for malformed LET and LET*, including those +;;; resulting from SETF of LET. +(dolist (fun (list (compile nil '(lambda () (let :bogus-let :oops))) + (compile nil '(lambda () (let* :bogus-let* :oops))) + (compile nil '(lambda (x) (push x (let ((y 0)) y)))))) + (assert (functionp fun)) + (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: erronous 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))))