;;;; various compiler tests without side effects ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. ;;;; ;;;; 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) ;;; Exercise a compiler bug (by crashing the compiler). ;;; ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG ;;; (2000-09-06 on cmucl-imp). ;;; ;;; 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)))) ;;; Exercise a compiler bug (by crashing the compiler). ;;; ;;; 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) ;;; 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))))) (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))))) ;;; 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)))) (declare (ignore warnings-p)) (assert (functionp fun)) (assert failure-p)) ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David ;;; Lichteblau 2002-05-21) (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*)))) (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*)))) (assert (functionp fun)) (assert (not warnings-p)) (assert (not failure-p)))) ;;; a bug in 0.7.4.11 (dolist (i '(a b 1 2 "x" "y")) ;; In sbcl-0.7.4.11, the compiler tried to source-transform the ;; TYPEP here but got confused and died, doing ;; (ASSOC '(AND INTEGERP (SATISFIES PLUSP))) ;; *BACKEND-TYPE-PREDICATES* ;; :TEST #'TYPE=) ;; and blowing up because TYPE= tried to call PLUSP on the ;; characters of the MEMBER-TYPE representing STANDARD-CHAR. (when (typep i '(and integer (satisfies oddp))) (print i))) (dotimes (i 14) (when (typep i '(and integer (satisfies oddp))) (print i))) ;;; bug 156 (reported by APD sbcl-devel 2002-04-12, fixed by CSR patch ;;; sbcl-devel 2002-07-02): FUNCTION-LAMBDA-EXPRESSION of ;;; interactively-compiled functions was broken by sleaziness and ;;; confusion in the assault on 0.7.0, so this expression used to ;;; signal TYPE-ERROR when it found NIL instead of a DEBUG-SOURCE. (eval '(function-lambda-expression #'(lambda (x) x))) ;;; bug caught and fixed by Raymond Toy cmucl-imp 2002-07-10: &REST ;;; variable is not optional. (assert (null (ignore-errors (eval '(funcall (lambda (&rest) 12)))))) ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for ;;; a while; fixed by CSR 2002-07-18 (multiple-value-bind (value error) (ignore-errors (some-undefined-function)) (assert (null value)) (assert (eq (cell-error-name error) 'some-undefined-function))) ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR ;;; is a variable name, as in section 3.4.1 of the ANSI spec.) (assert (null (ignore-errors (eval '(lambda ("foo") 12))))) (assert (ignore-errors (eval '(lambda (foo) 12)))) (assert (null (ignore-errors (eval '(lambda (&optional 12) "foo"))))) (assert (ignore-errors (eval '(lambda (&optional twelve) "foo")))) (assert (null (ignore-errors (eval '(lambda (&optional (12 12)) "foo"))))) (assert (ignore-errors (eval '(lambda (&optional (twelve 12)) "foo")))) (assert (null (ignore-errors (eval '(lambda (&key #\c) "foo"))))) (assert (ignore-errors (eval '(lambda (&key c) "foo")))) (assert (null (ignore-errors (eval '(lambda (&key (#\c #\c)) "foo"))))) (assert (ignore-errors (eval '(lambda (&key (c #\c)) "foo")))) (assert (null (ignore-errors (eval '(lambda (&key ((#\c #\c) #\c)) "foo"))))) (assert (ignore-errors (eval '(lambda (&key ((:c cbyanyothername) #\c)) "foo")))) ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel ;;; 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)) ;;; bug 181: bad type specifier dropped compiler into debugger (assert (list (compile nil '(lambda (x) (declare (type (0) x)) x)))) (let ((f (compile nil '(lambda (x) (make-array 1 :element-type '(0)))))) (assert (null (ignore-errors (funcall f))))) ;;; the following functions must not be flushable (dolist (form '((make-sequence 'fixnum 10) (concatenate 'fixnum nil) (map 'fixnum #'identity nil) (merge 'fixnum nil nil #'<))) (assert (not (eval `(locally (declare (optimize (safety 0))) (ignore-errors (progn ,form t))))))) (dolist (form '((values-list (car (list '(1 . 2)))) (fboundp '(set bet)) (atan #c(1 1) (car (list #c(2 2)))) (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5)) (nthcdr (car (list 5)) '(1 2 . 3)))) (assert (not (eval `(locally (declare (optimize (safety 3))) (ignore-errors (progn ,form t))))))) ;;; 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))))) ;;; bug 129: insufficient syntax checking in MACROLET (multiple-value-bind (result error) (ignore-errors (eval '(macrolet ((foo x `',x)) (foo 1 2 3)))) (assert (null result)) (assert (typep error 'error))) ;;; bug 124: environment of MACROLET-introduced macro expanders (assert (equal (macrolet ((mext (x) `(cons :mext ,x))) (macrolet ((mint (y) `'(:mint ,(mext y)))) (list (mext '(1 2)) (mint (1 2))))) '((:MEXT 1 2) (:MINT (:MEXT 1 2))))) ;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced ;;; symbol is declared to be SPECIAL (multiple-value-bind (result error) (ignore-errors (funcall (lambda () (symbol-macrolet ((s '(1 2))) (declare (special s)) s)))) (assert (null result)) (assert (typep error 'program-error))) ;;; ECASE should treat a bare T as a literal key (multiple-value-bind (result error) (ignore-errors (ecase 1 (t 0))) (assert (null result)) (assert (typep error 'type-error))) (multiple-value-bind (result error) (ignore-errors (ecase 1 (t 0) (1 2))) (assert (eql result 2)) (assert (null error))) ;;; FTYPE should accept any functional type specifier (compile nil '(lambda (x) (declare (ftype function f)) (f x))) ;;; FUNCALL of special operators and macros should signal an ;;; UNDEFINED-FUNCTION error (multiple-value-bind (result error) (ignore-errors (funcall 'quote 1)) (assert (null result)) (assert (typep error 'undefined-function)) (assert (eq (cell-error-name error) 'quote))) (multiple-value-bind (result error) (ignore-errors (funcall 'and 1)) (assert (null result)) (assert (typep error 'undefined-function)) (assert (eq (cell-error-name error) 'and))) ;;; 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))) (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)) (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)))) ;;; 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))))) ;;; bug 62: too cautious type inference in a loop (assert (nth-value 2 (compile nil '(lambda (a) (declare (optimize speed (safety 0))) (typecase a (array (loop (print (car a))))))))) ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler ;;; failure (compile nil '(lambda (key tree collect-path-p) (let ((lessp (key-lessp tree)) (equalp (key-equalp tree))) (declare (type (function (t t) boolean) lessp equalp)) (let ((path '(nil))) (loop for node = (root-node tree) then (if (funcall lessp key (node-key node)) (left-child node) (right-child node)) when (null node) do (return (values nil nil nil)) do (when collect-path-p (push node path)) (when (funcall equalp key (node-key node)) (return (values node path t)))))))) ;;; CONSTANTLY should return a side-effect-free function (bug caught ;;; by Paul Dietz' test suite) (let ((i 0)) (let ((fn (constantly (progn (incf i) 1)))) (assert (= i 1)) (assert (= (funcall fn) 1)) (assert (= i 1)) (assert (= (funcall fn) 1)) (assert (= i 1)))) ;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version) (loop for (fun warns-p) in '(((lambda (&optional *x*) *x*) t) ((lambda (&optional *x* &rest y) (values *x* y)) t) ((lambda (&optional *print-length*) (values *print-length*)) nil) ((lambda (&optional *print-length* &rest y) (values *print-length* y)) nil) ((lambda (&optional *x*) (declare (special *x*)) (values *x*)) nil) ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil)) for real-warns-p = (nth-value 1 (compile nil fun)) do (assert (eq warns-p real-warns-p))) ;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26 (assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y))) '(1 2)) '((2) 1))) ;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd ;;; 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 (equal (multiple-value-list (the (values &rest integer) (eval '(values 3)))) '(3))) ;;; Bug relating to confused representation for the wild function ;;; type: (assert (null (funcall (eval '(lambda () (multiple-value-list (values))))))) ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz' ;;; test suite) (assert (eql (macrolet ((foo () 1)) (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env) x)) (%f))) 1)) ;;; MACROLET should check for duplicated names (dolist (ll '((x (z x)) (x y &optional z x w) (x y &optional z z) (x &rest x) (x &rest (y x)) (x &optional (y nil x)) (x &optional (y nil y)) (x &key x) (x &key (y nil x)) (&key (y nil z) (z nil w)) (&whole x &optional x) (&environment x &whole x))) (assert (nth-value 2 (handler-case (compile nil `(lambda () (macrolet ((foo ,ll nil) (bar (&environment env) `',(macro-function 'foo env))) (bar)))) (error (c) (values nil t t)))))) (assert (typep (eval `(the arithmetic-error ',(make-condition 'arithmetic-error))) 'arithmetic-error)) (assert (not (nth-value 2 (compile nil '(lambda () (make-array nil :initial-element 11)))))) (assert (raises-error? (funcall (eval #'open) "assertoid.lisp" :external-format '#:nonsense))) (assert (raises-error? (funcall (eval #'load) "assertoid.lisp" :external-format '#:nonsense))) (assert (= (the (values integer symbol) (values 1 'foo 13)) 1)) (let ((f (compile nil '(lambda (v) (declare (optimize (safety 3))) (list (the fixnum (the (real 0) (eval v)))))))) (assert (raises-error? (funcall f 0.1) type-error)) (assert (raises-error? (funcall f -1) type-error))) ;;; the implicit block does not enclose lambda list (let ((forms '((defmacro #1=#:foo (&optional (x (return-from #1#)))) #+nil(macrolet ((#2=#:foo (&optional (x (return-from #2#)))))) (define-compiler-macro #3=#:foo (&optional (x (return-from #3#)))) (deftype #4=#:foo (&optional (x (return-from #4#)))) (define-setf-expander #5=#:foo (&optional (x (return-from #5#)))) (defsetf #6=#:foo (&optional (x (return-from #6#))) ())))) (dolist (form forms) (assert (nth-value 2 (compile nil `(lambda () ,form)))))) (assert (nth-value 2 (compile nil '(lambda () (svref (make-array '(8 9) :adjustable t) 1))))) ;;; CHAR= did not check types of its arguments (reported by Adam Warner) (raises-error? (funcall (compile nil '(lambda (x y z) (char= x y z))) #\a #\b nil) type-error) (raises-error? (funcall (compile nil '(lambda (x y z) (declare (optimize (speed 3) (safety 3))) (char/= x y z))) nil #\a #\a) type-error) ;;; Compiler lost return type of MAPCAR and friends (dolist (fun '(mapcar mapc maplist mapl)) (assert (nth-value 2 (compile nil `(lambda (x) (1+ (,fun #'print x))))))) (assert (nth-value 2 (compile nil '(lambda () (declare (notinline mapcar)) (1+ (mapcar #'print '(1 2 3))))))) ;;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant ;;; index was effectless (let ((f (compile nil '(lambda (a v) (declare (type simple-bit-vector a) (type bit v)) (declare (optimize (speed 3) (safety 0))) (setf (aref a 0) v) a)))) (let ((y (make-array 2 :element-type 'bit :initial-element 0))) (assert (equal y #*00)) (funcall f y 1) (assert (equal y #*10)))) (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)))) ;;; 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)))) ;;; bogus optimization of BIT-NOT (multiple-value-bind (result x) (eval '(let ((x (eval #*1001))) (declare (optimize (speed 2) (space 3)) (type (bit-vector) x)) (values (bit-not x nil) x))) (assert (equal x #*1001)) (assert (equal result #*0110))) ;;; 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)))) ;;; this is not a check for a bug, but rather a test of compiler ;;; quality (dolist (type '((integer 0 *) ; upper bound (real (-1) *) float ; class (real * (-10)) ; lower bound )) (assert (nth-value 1 (compile nil `(lambda (n) (declare (optimize (speed 3) (compilation-speed 0))) (loop for i from 1 to (the (integer -17 10) n) by 2 collect (when (> (random 10) 5) (the ,type (- i 11))))))))) ;;; bug 278b ;;; ;;; We suppose that INTEGER arithmetic cannot be efficient, and the ;;; compiler has an optimized VOP for +; so this code should cause an ;;; efficiency note. (assert (eq (block nil (handler-case (compile nil '(lambda (i) (declare (optimize speed)) (declare (type integer i)) (+ i 2))) (sb-ext:compiler-note (c) (return :good)))) :good)) ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for ;;; symbol macros (assert (not (nth-value 1 (compile nil '(lambda (u v) (symbol-macrolet ((x u) (y v)) (declare (ignore x) (ignorable y)) (list u v))))))) ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0) (loop for (x type) in '((14 integer) (14 rational) (-14/3 (rational -8 11)) (3s0 short-float) (4f0 single-float) (5d0 double-float) (6l0 long-float) (14 real) (13/2 real) (2s0 real) (2d0 real) (#c(-3 4) (complex fixnum)) (#c(-3 4) (complex rational)) (#c(-3/7 4) (complex rational)) (#c(2s0 3s0) (complex short-float)) (#c(2f0 3f0) (complex single-float)) (#c(2d0 3d0) (complex double-float)) (#c(2l0 3l0) (complex long-float)) (#c(2d0 3s0) (complex float)) (#c(2 3f0) (complex real)) (#c(2 3d0) (complex real)) (#c(-3/7 4) (complex real)) (#c(-3/7 4) complex) (#c(2 3l0) complex)) do (dolist (zero '(0 0s0 0f0 0d0 0l0)) (dolist (real-zero (list zero (- zero))) (let* ((src `(lambda (x) (expt (the ,type x) ,real-zero))) (fun (compile nil src)) (result (1+ (funcall (eval #'*) x real-zero)))) (assert (eql result (funcall fun x))))))) ;;; (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)))) (assert (= (funcall fun 0 0) 0)) (assert (= (funcall fun 0 -1) -1)) (assert (= (funcall fun -1 -1) 0))) ;;; from PFD's torture test, triggering a bug in our effective address ;;; treatment. (compile nil `(lambda (a b) (declare (type (integer 8 22337) b)) (logandc2 (logandc2 (* (logandc1 (max -29303 b) 4) b) (abs (logorc1 (+ (logandc1 -11 b) 2607688420) -31153924))) (logeqv (max a 0) b)))) ;;; 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-case (/ 1.0 0.0) ;; provoke an exception (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)) ;;;; 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 () (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)))