;;;; 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
;;; 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))
(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))))
;;; 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)
(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)))))
;;; 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
;;; 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))))
(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 ()
(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)
;;; 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
;;; (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)))
;;; Alpha floating point modes weren't being reset after an exception,
;;; leading to an exception on the second compile, below.
(compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
-(handler-bind ((arithmetic-error #'abort))
+(handler-case (/ 1.0 0.0)
;; provoke an exception
- (/ 1.0 0.0))
+ (arithmetic-error ()))
(compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
+
+;;; bug reported by Paul Dietz: component last block does not have
+;;; start ctran
+(compile nil
+ '(lambda ()
+ (declare (notinline + logand)
+ (optimize (speed 0)))
+ (LOGAND
+ (BLOCK B5
+ (FLET ((%F1 ()
+ (RETURN-FROM B5 -220)))
+ (LET ((V7 (%F1)))
+ (+ 359749 35728422))))
+ -24076)))
+
+;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
+(assert (= (funcall (compile nil `(lambda (b)
+ (declare (optimize (speed 3))
+ (type (integer 2 152044363) b))
+ (rem b (min -16 0))))
+ 108251912)
+ 8))
+
+(assert (= (funcall (compile nil `(lambda (c)
+ (declare (optimize (speed 3))
+ (type (integer 23062188 149459656) c))
+ (mod c (min -2 0))))
+ 95019853)
+ -1))
+
+;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
+(compile nil
+ '(LAMBDA (A B C)
+ (BLOCK B6
+ (LOGEQV (REM C -6758)
+ (REM B (MAX 44 (RETURN-FROM B6 A)))))))
+
+(compile nil '(lambda ()
+ (block nil
+ (flet ((foo (x y) (if (> x y) (print x) (print y))))
+ (foo 1 2)
+ (bar)
+ (foo (return 14) 2)))))
+
+;;; 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))
+
+;;; 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))
+
+\f
+;;;; 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)))
+
+\f
+;;; 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)))
+ "<return value>")
+ (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: #<SB-VM::EA :DWORD base=#<SB-C:TN t1[RDX]> disp=1> is a :DWORD and #<SB-C:TN t2[RAX]> is a :QWORD. on x86-64
+(compile nil '(lambda ()
+ (let ((x (make-array '(1) :element-type '(signed-byte 32))))
+ (setf (aref x 0) 1))))
+
+;;; step instrumentation confusing the compiler, reported by Faré
+(handler-bind ((warning #'error))
+ (compile nil '(lambda ()
+ (declare (optimize (debug 2))) ; not debug 3!
+ (let ((val "foobar"))
+ (map-into (make-array (list (length val))
+ :element-type '(unsigned-byte 8))
+ #'char-code val)))))
+
+;;; overconfident primitive type computation leading to bogus type
+;;; checking.
+(let* ((form1 '(lambda (x)
+ (declare (type (and condition function) x))
+ x))
+ (fun1 (compile nil form1))
+ (form2 '(lambda (x)
+ (declare (type (and standard-object function) x))
+ x))
+ (fun2 (compile nil form2)))
+ (assert (raises-error? (funcall fun1 (make-condition 'error))))
+ (assert (raises-error? (funcall fun1 fun1)))
+ (assert (raises-error? (funcall fun2 fun2)))
+ (assert (eq (funcall fun2 #'print-object) #'print-object)))
+
+;;; LET* + VALUES declaration: while the declaration is a non-standard
+;;; and possibly a non-conforming extension, as long as we do support
+;;; it, we might as well get it right.
+;;;
+;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
+(compile nil '(lambda () (let* () (declare (values list)))))
projects / sbcl.git / blobdiff