3 ;;;; various compiler tests without side effects
5 ;;;; This software is part of the SBCL system. See the README file for
8 ;;;; While most of SBCL is derived from the CMU CL system, the test
9 ;;;; files (like this one) were written from scratch after the fork
12 ;;;; This software is in the public domain and is provided with
13 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
14 ;;;; more information.
16 (cl:in-package :cl-user)
18 (load "compiler-test-util.lisp")
20 ;; The tests in this file assume that EVAL will use the compiler
21 (when (eq sb-ext:*evaluator-mode* :interpret)
22 (invoke-restart 'run-tests::skip-file))
24 ;;; Exercise a compiler bug (by crashing the compiler).
26 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
27 ;;; (2000-09-06 on cmucl-imp).
29 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
30 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
50 ;;; Exercise a compiler bug (by crashing the compiler).
52 ;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on
53 ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL.
57 (block used-by-some-y?
61 (return-from used-by-some-y? t)))))
62 (declare (inline frob))
68 ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally
69 ;;; from Bruno Haible in CMU CL bugs collection), fixed by
70 ;;; Alexey Dejneka 2002-01-27
71 (assert (= 1 ; (used to give 0 under bug 112)
76 (declare (special x)) y)))))
77 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
82 (declare (special x)) y)))))
84 ;;; another LET-related bug fixed by Alexey Dejneka at the same
86 (multiple-value-bind (fun warnings-p failure-p)
87 ;; should complain about duplicate variable names in LET binding
93 (declare (ignore warnings-p))
94 (assert (functionp fun))
97 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
98 ;;; Lichteblau 2002-05-21)
100 (multiple-value-bind (fun warnings-p failure-p)
102 ;; Compiling this code should cause a STYLE-WARNING
103 ;; about *X* looking like a special variable but not
107 (funcall (symbol-function 'x-getter))
109 (assert (functionp fun))
111 (assert (not failure-p)))
112 (multiple-value-bind (fun warnings-p failure-p)
114 ;; Compiling this code should not cause a warning
115 ;; (because the DECLARE turns *X* into a special
116 ;; variable as its name suggests it should be).
119 (declare (special *x*))
120 (funcall (symbol-function 'x-getter))
122 (assert (functionp fun))
123 (assert (not warnings-p))
124 (assert (not failure-p))))
126 ;;; a bug in 0.7.4.11
127 (dolist (i '(a b 1 2 "x" "y"))
128 ;; In sbcl-0.7.4.11, the compiler tried to source-transform the
129 ;; TYPEP here but got confused and died, doing
130 ;; (ASSOC '(AND INTEGERP (SATISFIES PLUSP)))
131 ;; *BACKEND-TYPE-PREDICATES*
133 ;; and blowing up because TYPE= tried to call PLUSP on the
134 ;; characters of the MEMBER-TYPE representing STANDARD-CHAR.
135 (when (typep i '(and integer (satisfies oddp)))
138 (when (typep i '(and integer (satisfies oddp)))
141 ;;; bug 156 (reported by APD sbcl-devel 2002-04-12, fixed by CSR patch
142 ;;; sbcl-devel 2002-07-02): FUNCTION-LAMBDA-EXPRESSION of
143 ;;; interactively-compiled functions was broken by sleaziness and
144 ;;; confusion in the assault on 0.7.0, so this expression used to
145 ;;; signal TYPE-ERROR when it found NIL instead of a DEBUG-SOURCE.
146 (eval '(function-lambda-expression #'(lambda (x) x)))
148 ;;; bug caught and fixed by Raymond Toy cmucl-imp 2002-07-10: &REST
149 ;;; variable is not optional.
150 (assert (null (ignore-errors (eval '(funcall (lambda (&rest) 12))))))
152 ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
153 ;;; a while; fixed by CSR 2002-07-18
154 (with-test (:name :undefined-function-error)
155 (multiple-value-bind (value error)
156 (ignore-errors (some-undefined-function))
157 (assert (null value))
158 (assert (eq (cell-error-name error) 'some-undefined-function))))
160 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
161 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
162 (assert (null (ignore-errors (eval '(lambda ("foo") 12)))))
163 (assert (ignore-errors (eval '(lambda (foo) 12))))
164 (assert (null (ignore-errors (eval '(lambda (&optional 12) "foo")))))
165 (assert (ignore-errors (eval '(lambda (&optional twelve) "foo"))))
166 (assert (null (ignore-errors (eval '(lambda (&optional (12 12)) "foo")))))
167 (assert (ignore-errors (eval '(lambda (&optional (twelve 12)) "foo"))))
168 (assert (null (ignore-errors (eval '(lambda (&key #\c) "foo")))))
169 (assert (ignore-errors (eval '(lambda (&key c) "foo"))))
170 (assert (null (ignore-errors (eval '(lambda (&key (#\c #\c)) "foo")))))
171 (assert (ignore-errors (eval '(lambda (&key (c #\c)) "foo"))))
172 (assert (null (ignore-errors (eval '(lambda (&key ((#\c #\c) #\c)) "foo")))))
173 (assert (ignore-errors (eval '(lambda (&key ((:c cbyanyothername) #\c)) "foo"))))
175 ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel
176 ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER
177 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
178 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14)
181 ;;; bug 181: bad type specifier dropped compiler into debugger
182 (assert (list (compile nil '(lambda (x)
183 (declare (type (0) x))
186 (let ((f (compile nil '(lambda (x)
187 (make-array 1 :element-type '(0))))))
188 (assert (null (ignore-errors (funcall f)))))
190 ;;; the following functions must not be flushable
191 (dolist (form '((make-sequence 'fixnum 10)
192 (concatenate 'fixnum nil)
193 (map 'fixnum #'identity nil)
194 (merge 'fixnum nil nil #'<)))
195 (assert (not (eval `(locally (declare (optimize (safety 0)))
196 (ignore-errors (progn ,form t)))))))
198 (dolist (form '((values-list (car (list '(1 . 2))))
200 (atan #c(1 1) (car (list #c(2 2))))
201 (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5))
202 (nthcdr (car (list 5)) '(1 2 . 3))))
203 (assert (not (eval `(locally (declare (optimize (safety 3)))
204 (ignore-errors (progn ,form t)))))))
206 ;;; feature: we shall complain if functions which are only useful for
207 ;;; their result are called and their result ignored.
208 (loop for (form expected-des) in
209 '(((progn (nreverse (list 1 2)) t)
210 "The return value of NREVERSE should not be discarded.")
211 ((progn (nreconc (list 1 2) (list 3 4)) t)
212 "The return value of NRECONC should not be discarded.")
214 (declare (inline sort))
215 (sort (list 1 2) #'<) t)
216 ;; FIXME: it would be nice if this warned on non-inlined sort
217 ;; but the current simple boolean function attribute
218 ;; can't express the condition that would be required.
219 "The return value of STABLE-SORT-LIST should not be discarded.")
220 ((progn (sort (vector 1 2) #'<) t)
221 ;; Apparently, SBCL (but not CL) guarantees in-place vector
222 ;; sort, so no warning.
224 ((progn (delete 2 (list 1 2)) t)
225 "The return value of DELETE should not be discarded.")
226 ((progn (delete-if #'evenp (list 1 2)) t)
227 ("The return value of DELETE-IF should not be discarded."))
228 ((progn (delete-if #'evenp (vector 1 2)) t)
229 ("The return value of DELETE-IF should not be discarded."))
230 ((progn (delete-if-not #'evenp (list 1 2)) t)
231 "The return value of DELETE-IF-NOT should not be discarded.")
232 ((progn (delete-duplicates (list 1 2)) t)
233 "The return value of DELETE-DUPLICATES should not be discarded.")
234 ((progn (merge 'list (list 1 3) (list 2 4) #'<) t)
235 "The return value of MERGE should not be discarded.")
236 ((progn (nreconc (list 1 3) (list 2 4)) t)
237 "The return value of NRECONC should not be discarded.")
238 ((progn (nunion (list 1 3) (list 2 4)) t)
239 "The return value of NUNION should not be discarded.")
240 ((progn (nintersection (list 1 3) (list 2 4)) t)
241 "The return value of NINTERSECTION should not be discarded.")
242 ((progn (nset-difference (list 1 3) (list 2 4)) t)
243 "The return value of NSET-DIFFERENCE should not be discarded.")
244 ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t)
245 "The return value of NSET-EXCLUSIVE-OR should not be discarded."))
246 for expected = (if (listp expected-des)
250 (multiple-value-bind (fun warnings-p failure-p)
251 (handler-bind ((style-warning (lambda (c)
253 (let ((expect-one (pop expected)))
254 (assert (search expect-one
255 (with-standard-io-syntax
256 (let ((*print-right-margin* nil))
257 (princ-to-string c))))
259 "~S should have warned ~S, but instead warned: ~A"
261 (error "~S shouldn't give a(nother) warning, but did: ~A" form c)))))
262 (compile nil `(lambda () ,form)))
263 (declare (ignore warnings-p))
264 (assert (functionp fun))
265 (assert (null expected)
267 "~S should have warned ~S, but didn't."
269 (assert (not failure-p))))
271 ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers
272 ;;; to cause errors in the compiler. Fixed by CSR in 0.7.8.10
273 (assert (list (compile nil '(lambda (x) (map 'simple-array 'identity x)))))
275 ;;; bug 129: insufficient syntax checking in MACROLET
276 (multiple-value-bind (result error)
277 (ignore-errors (eval '(macrolet ((foo x `',x)) (foo 1 2 3))))
278 (assert (null result))
279 (assert (typep error 'error)))
281 ;;; bug 124: environment of MACROLET-introduced macro expanders
283 (macrolet ((mext (x) `(cons :mext ,x)))
284 (macrolet ((mint (y) `'(:mint ,(mext y))))
287 '((:MEXT 1 2) (:MINT (:MEXT 1 2)))))
289 ;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced
290 ;;; symbol is declared to be SPECIAL
291 (multiple-value-bind (result error)
292 (ignore-errors (funcall (lambda ()
293 (symbol-macrolet ((s '(1 2)))
294 (declare (special s))
296 (assert (null result))
297 (assert (typep error 'program-error)))
299 ;;; ECASE should treat a bare T as a literal key
300 (multiple-value-bind (result error)
301 (ignore-errors (ecase 1 (t 0)))
302 (assert (null result))
303 (assert (typep error 'type-error)))
305 (multiple-value-bind (result error)
306 (ignore-errors (ecase 1 (t 0) (1 2)))
307 (assert (eql result 2))
308 (assert (null error)))
310 ;;; FTYPE should accept any functional type specifier
311 (compile nil '(lambda (x) (declare (ftype function f)) (f x)))
313 ;;; FUNCALL of special operators and macros should signal an
314 ;;; UNDEFINED-FUNCTION error
315 (multiple-value-bind (result error)
316 (ignore-errors (funcall 'quote 1))
317 (assert (null result))
318 (assert (typep error 'undefined-function))
319 (assert (eq (cell-error-name error) 'quote)))
320 (multiple-value-bind (result error)
321 (ignore-errors (funcall 'and 1))
322 (assert (null result))
323 (assert (typep error 'undefined-function))
324 (assert (eq (cell-error-name error) 'and)))
326 ;;; PSETQ should behave when given complex symbol-macro arguments
327 (multiple-value-bind (sequence index)
328 (symbol-macrolet ((x (aref a (incf i)))
329 (y (aref a (incf i))))
330 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
332 (psetq x (aref a (incf i))
335 (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9)))
336 (assert (= index 4)))
338 (multiple-value-bind (result error)
340 (let ((x (list 1 2)))
343 (assert (null result))
344 (assert (typep error 'program-error)))
346 ;;; COPY-SEQ should work on known-complex vectors:
348 (let ((v (make-array 0 :fill-pointer 0)))
349 (vector-push-extend 1 v)
352 ;;; to support INLINE functions inside MACROLET, it is necessary for
353 ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in
354 ;;; certain circumstances, one of which is when compile is called from
357 (function-lambda-expression
358 (compile nil '(lambda (x) (block nil (print x)))))
359 '(lambda (x) (block nil (print x)))))
361 ;;; bug 62: too cautious type inference in a loop
366 (declare (optimize speed (safety 0)))
368 (array (loop (print (car a)))))))))
370 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
373 '(lambda (key tree collect-path-p)
374 (let ((lessp (key-lessp tree))
375 (equalp (key-equalp tree)))
376 (declare (type (function (t t) boolean) lessp equalp))
378 (loop for node = (root-node tree)
379 then (if (funcall lessp key (node-key node))
383 do (return (values nil nil nil))
384 do (when collect-path-p
386 (when (funcall equalp key (node-key node))
387 (return (values node path t))))))))
389 ;;; CONSTANTLY should return a side-effect-free function (bug caught
390 ;;; by Paul Dietz' test suite)
392 (let ((fn (constantly (progn (incf i) 1))))
394 (assert (= (funcall fn) 1))
396 (assert (= (funcall fn) 1))
399 ;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version)
400 (loop for (fun warns-p) in
401 '(((lambda (&optional *x*) *x*) t)
402 ((lambda (&optional *x* &rest y) (values *x* y)) t)
403 ((lambda (&optional *print-length*) (values *print-length*)) nil)
404 ((lambda (&optional *print-length* &rest y) (values *print-length* y)) nil)
405 ((lambda (&optional *x*) (declare (special *x*)) (values *x*)) nil)
406 ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil))
407 for real-warns-p = (nth-value 1 (compile nil fun))
408 do (assert (eq warns-p real-warns-p)))
410 ;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26
411 (assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y)))
415 ;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd
416 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
417 (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))
420 (raises-error? (multiple-value-bind (a b c)
421 (eval '(truncate 3 4))
422 (declare (integer c))
426 (assert (equal (multiple-value-list (the (values &rest integer)
430 ;;; Bug relating to confused representation for the wild function
432 (assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
434 ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz'
436 (assert (eql (macrolet ((foo () 1))
437 (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env)
442 ;;; MACROLET should check for duplicated names
443 (dolist (ll '((x (z x))
444 (x y &optional z x w)
448 (x &optional (y nil x))
449 (x &optional (y nil y))
452 (&key (y nil z) (z nil w))
453 (&whole x &optional x)
454 (&environment x &whole x)))
459 (macrolet ((foo ,ll nil)
460 (bar (&environment env)
461 `',(macro-function 'foo env)))
464 (values nil t t))))))
466 (assert (typep (eval `(the arithmetic-error
467 ',(make-condition 'arithmetic-error)))
470 (assert (not (nth-value
471 2 (compile nil '(lambda ()
472 (make-array nil :initial-element 11))))))
474 (assert (raises-error? (funcall (eval #'open) "assertoid.lisp"
475 :external-format '#:nonsense)))
476 (assert (raises-error? (funcall (eval #'load) "assertoid.lisp"
477 :external-format '#:nonsense)))
479 (assert (= (the (values integer symbol) (values 1 'foo 13)) 1))
481 (let ((f (compile nil
483 (declare (optimize (safety 3)))
484 (list (the fixnum (the (real 0) (eval v))))))))
485 (assert (raises-error? (funcall f 0.1) type-error))
486 (assert (raises-error? (funcall f -1) type-error)))
488 ;;; the implicit block does not enclose lambda list
489 (let ((forms '((defmacro #1=#:foo (&optional (x (return-from #1#))))
490 #+nil(macrolet ((#2=#:foo (&optional (x (return-from #2#))))))
491 (define-compiler-macro #3=#:foo (&optional (x (return-from #3#))))
492 (deftype #4=#:foo (&optional (x (return-from #4#))))
493 (define-setf-expander #5=#:foo (&optional (x (return-from #5#))))
494 (defsetf #6=#:foo (&optional (x (return-from #6#))) ()))))
496 (assert (nth-value 2 (compile nil `(lambda () ,form))))))
498 (assert (nth-value 2 (compile nil
500 (svref (make-array '(8 9) :adjustable t) 1)))))
502 ;;; CHAR= did not check types of its arguments (reported by Adam Warner)
503 (raises-error? (funcall (compile nil '(lambda (x y z) (char= x y z)))
506 (raises-error? (funcall (compile nil
508 (declare (optimize (speed 3) (safety 3)))
513 ;;; Compiler lost return type of MAPCAR and friends
514 (dolist (fun '(mapcar mapc maplist mapl))
515 (assert (nth-value 2 (compile nil
517 (1+ (,fun #'print x)))))))
519 (assert (nth-value 2 (compile nil
521 (declare (notinline mapcar))
522 (1+ (mapcar #'print '(1 2 3)))))))
524 ;;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant
525 ;;; index was effectless
526 (let ((f (compile nil '(lambda (a v)
527 (declare (type simple-bit-vector a) (type bit v))
528 (declare (optimize (speed 3) (safety 0)))
531 (let ((y (make-array 2 :element-type 'bit :initial-element 0)))
532 (assert (equal y #*00))
534 (assert (equal y #*10))))
536 ;;; use of declared array types
537 (handler-bind ((sb-ext:compiler-note #'error))
538 (compile nil '(lambda (x)
539 (declare (type (simple-array (simple-string 3) (5)) x)
541 (aref (aref x 0) 0))))
543 (handler-bind ((sb-ext:compiler-note #'error))
544 (compile nil '(lambda (x)
545 (declare (type (simple-array (simple-array bit (10)) (10)) x)
547 (1+ (aref (aref x 0) 0)))))
550 (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0)))))))
551 (assert (funcall f 1d0)))
553 (compile nil '(lambda (x)
554 (declare (double-float x))
558 ;;; bogus optimization of BIT-NOT
559 (multiple-value-bind (result x)
560 (eval '(let ((x (eval #*1001)))
561 (declare (optimize (speed 2) (space 3))
562 (type (bit-vector) x))
563 (values (bit-not x nil) x)))
564 (assert (equal x #*1001))
565 (assert (equal result #*0110)))
567 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
568 (handler-bind ((sb-ext:compiler-note #'error))
569 (assert (equalp (funcall
573 (let ((x (make-sequence 'vector 10 :initial-element 'a)))
576 #(a a a a b a a a a a))))
578 ;;; this is not a check for a bug, but rather a test of compiler
580 (dolist (type '((integer 0 *) ; upper bound
583 (real * (-10)) ; lower bound
588 (declare (optimize (speed 3) (compilation-speed 0)))
589 (loop for i from 1 to (the (integer -17 10) n) by 2
590 collect (when (> (random 10) 5)
591 (the ,type (- i 11)))))))))
595 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
596 ;;; compiler has an optimized VOP for +; so this code should cause an
598 (assert (eq (block nil
600 (compile nil '(lambda (i)
601 (declare (optimize speed))
602 (declare (type integer i))
604 (sb-ext:compiler-note (c) (return :good))))
607 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
609 (assert (not (nth-value 1 (compile nil '(lambda (u v)
610 (symbol-macrolet ((x u)
616 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
617 (loop for (x type) in
620 (-14/3 (rational -8 11))
629 (#c(-3 4) (complex fixnum))
630 (#c(-3 4) (complex rational))
631 (#c(-3/7 4) (complex rational))
632 (#c(2s0 3s0) (complex short-float))
633 (#c(2f0 3f0) (complex single-float))
634 (#c(2d0 3d0) (complex double-float))
635 (#c(2l0 3l0) (complex long-float))
636 (#c(2d0 3s0) (complex float))
637 (#c(2 3f0) (complex real))
638 (#c(2 3d0) (complex real))
639 (#c(-3/7 4) (complex real))
642 do (dolist (zero '(0 0s0 0f0 0d0 0l0))
643 (dolist (real-zero (list zero (- zero)))
644 (let* ((src `(lambda (x) (expt (the ,type x) ,real-zero)))
645 (fun (compile nil src))
646 (result (1+ (funcall (eval #'*) x real-zero))))
647 (assert (eql result (funcall fun x)))))))
649 ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
650 ;;; wasn't recognized as a good type specifier.
651 (let ((fun (lambda (x y)
652 (declare (type (integer -1 0) x y) (optimize speed))
654 (assert (= (funcall fun 0 0) 0))
655 (assert (= (funcall fun 0 -1) -1))
656 (assert (= (funcall fun -1 -1) 0)))
658 ;;; from PFD's torture test, triggering a bug in our effective address
663 (declare (type (integer 8 22337) b))
666 (* (logandc1 (max -29303 b) 4) b)
667 (abs (logorc1 (+ (logandc1 -11 b) 2607688420) -31153924)))
668 (logeqv (max a 0) b))))
670 ;;; Alpha floating point modes weren't being reset after an exception,
671 ;;; leading to an exception on the second compile, below.
672 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
673 (handler-case (/ 1.0 0.0)
674 ;; provoke an exception
675 (arithmetic-error ()))
676 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
678 ;;; bug reported by Paul Dietz: component last block does not have
682 (declare (notinline + logand)
683 (optimize (speed 0)))
687 (RETURN-FROM B5 -220)))
689 (+ 359749 35728422))))
692 ;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
693 (assert (= (funcall (compile nil `(lambda (b)
694 (declare (optimize (speed 3))
695 (type (integer 2 152044363) b))
696 (rem b (min -16 0))))
700 (assert (= (funcall (compile nil `(lambda (c)
701 (declare (optimize (speed 3))
702 (type (integer 23062188 149459656) c))
707 ;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
711 (LOGEQV (REM C -6758)
712 (REM B (MAX 44 (RETURN-FROM B6 A)))))))
714 (compile nil '(lambda ()
716 (flet ((foo (x y) (if (> x y) (print x) (print y))))
719 (foo (return 14) 2)))))
721 ;;; bug in Alpha backend: not enough sanity checking of arguments to
723 (assert (= (funcall (compile nil
730 ;;; bug found by WHN and pfdietz: compiler failure while referencing
731 ;;; an entry point inside a deleted lambda
732 (compile nil '(lambda ()
737 (flet ((truly (fn bbd)
741 (multiple-value-prog1
758 (wum #'bbfn "hc3" (list)))
760 (compile nil '(lambda () (flet ((%f () (unwind-protect nil))) nil)))
762 ;;; the strength reduction of constant multiplication used (before
763 ;;; sbcl-0.8.4.x) to lie to the compiler. This meant that, under
764 ;;; certain circumstances, the compiler would derive that a perfectly
765 ;;; reasonable multiplication never returned, causing chaos. Fixed by
766 ;;; explicitly doing modular arithmetic, and relying on the backends
771 (declare (type (integer 178956970 178956970) x)
777 ;;; bug in modular arithmetic and type specifiers
778 (assert (= (funcall (compile nil (lambda (x) (logand x x 0)))
782 ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP
783 ;;; produced wrong result for shift >=32 on X86
784 (assert (= 0 (funcall
787 (declare (type (integer 4303063 101130078) a))
788 (mask-field (byte 18 2) (ash a 77))))
790 ;;; rewrite the test case to get the unsigned-byte 32/64
791 ;;; implementation even after implementing some modular arithmetic
792 ;;; with signed-byte 30:
793 (assert (= 0 (funcall
796 (declare (type (integer 4303063 101130078) a))
797 (mask-field (byte 30 2) (ash a 77))))
799 (assert (= 0 (funcall
802 (declare (type (integer 4303063 101130078) a))
803 (mask-field (byte 64 2) (ash a 77))))
805 ;;; and a similar test case for the signed masking extension (not the
806 ;;; final interface, so change the call when necessary):
807 (assert (= 0 (funcall
810 (declare (type (integer 4303063 101130078) a))
811 (sb-c::mask-signed-field 30 (ash a 77))))
813 (assert (= 0 (funcall
816 (declare (type (integer 4303063 101130078) a))
817 (sb-c::mask-signed-field 61 (ash a 77))))
820 ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
821 ;;; type check regeneration
822 (assert (eql (funcall
823 (compile nil '(lambda (a c)
824 (declare (type (integer 185501219873 303014665162) a))
825 (declare (type (integer -160758 255724) c))
826 (declare (optimize (speed 3)))
828 (- -554046873252388011622614991634432
830 (unwind-protect 2791485))))
831 (max (ignore-errors a)
832 (let ((v6 (- v8 (restart-case 980))))
836 (assert (eql (funcall
837 (compile nil '(lambda (a b)
845 (load-time-value -6876935))))
846 (if (logbitp 1 a) b (setq a -1522022182249))))))))
847 -1802767029877 -12374959963)
850 ;;; various MISC.*, related to NODEs/LVARs with derived type NIL
851 (assert (eql (funcall (compile nil '(lambda (c)
852 (declare (type (integer -3924 1001809828) c))
853 (declare (optimize (speed 3)))
854 (min 47 (if (ldb-test (byte 2 14) c)
856 (ignore-errors -732893970)))))
859 (assert (eql (funcall
860 (compile nil '(lambda (b)
861 (declare (type (integer -1598566306 2941) b))
862 (declare (optimize (speed 3)))
863 (max -148949 (ignore-errors b))))
866 (assert (eql (funcall
867 (compile nil '(lambda (b c)
868 (declare (type (integer -4 -3) c))
870 (flet ((%f1 (f1-1 f1-2 f1-3)
871 (if (logbitp 0 (return-from b7
872 (- -815145138 f1-2)))
873 (return-from b7 -2611670)
875 (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2)))
879 (assert (eql (funcall
882 (declare (type (integer -29742055786 23602182204) b))
883 (declare (type (integer -7409 -2075) c))
884 (declare (optimize (speed 3)))
888 (ignore-errors (return-from b6
889 (if (= c 8) b 82674))))))
893 (assert (equal (multiple-value-list
895 (compile nil '(lambda (a)
896 (declare (type (integer -944 -472) a))
897 (declare (optimize (speed 3)))
901 (if (= 55957 a) -117 (ignore-errors
902 (return-from b3 a))))))))
907 (assert (zerop (funcall
910 (declare (type (integer 79828 2625480458) a))
911 (declare (type (integer -4363283 8171697) b))
912 (declare (type (integer -301 0) c))
913 (if (equal 6392154 (logxor a b))
917 (logior (logandc2 c v5)
918 (common-lisp:handler-case
919 (ash a (min 36 22477)))))))))
922 ;;; MISC.152, 153: deleted code and iteration var type inference
923 (assert (eql (funcall
927 (let ((v1 (let ((v8 (unwind-protect 9365)))
931 (labels ((%f11 (f11-1) f11-1))
935 (labels ((%f6 (f6-1 f6-2 f6-3) v1))
936 (dpb (unwind-protect a)
938 (labels ((%f4 () 27322826))
939 (%f6 -2 -108626545 (%f4))))))))))))
943 (assert (eql (funcall
948 ((-96879 -1035 -57680 -106404 -94516 -125088)
949 (unwind-protect 90309179))
950 ((-20811 -86901 -9368 -98520 -71594)
951 (let ((v9 (unwind-protect 136707)))
954 (let ((v4 (return-from b3 v9)))
955 (- (ignore-errors (return-from b3 v4))))))))
963 (assert (eql (funcall
974 &optional (f17-4 185155520) (f17-5 c)
977 (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817)))
978 (f15-5 a) (f15-6 -40))
979 (return-from b3 -16)))
980 (multiple-value-call #'%f15 (values -519354 a 121 c -1905))))))
985 (assert (eql (funcall
989 (declare (notinline list apply))
990 (declare (optimize (safety 3)))
991 (declare (optimize (speed 0)))
992 (declare (optimize (debug 0)))
993 (labels ((%f12 (f12-1 f12-2)
994 (labels ((%f2 (f2-1 f2-2)
1001 (return-from %f12 b)))
1004 (%f18 (%f18 150 -64 f12-1)
1011 &optional (f7-3 (%f6)))
1014 (%f2 b -36582571))))
1015 (apply #'%f12 (list 774 -4413)))))
1020 (assert (eql (funcall
1024 (declare (notinline values))
1025 (declare (optimize (safety 3)))
1026 (declare (optimize (speed 0)))
1027 (declare (optimize (debug 0)))
1030 &optional (f11-3 c) (f11-4 7947114)
1032 (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529))
1034 (multiple-value-call #'%f3
1035 (values (%f3 -30637724 b) c)))))
1037 (if (and nil (%f11 a a))
1038 (if (%f11 a 421778 4030 1)
1044 (%f11 c a c -4 214720)
1056 ;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
1057 ;;; local lambda argument
1063 (declare (type (integer 804561 7640697) a))
1064 (declare (type (integer -1 10441401) b))
1065 (declare (type (integer -864634669 55189745) c))
1066 (declare (ignorable a b c))
1067 (declare (optimize (speed 3)))
1068 (declare (optimize (safety 1)))
1069 (declare (optimize (debug 1)))
1072 (labels ((%f4 () (round 200048 (max 99 c))))
1075 (labels ((%f3 (f3-1) -162967612))
1076 (%f3 (let* ((v8 (%f4)))
1077 (setq f11-1 (%f4)))))))))
1078 (%f11 -120429363 (%f11 62362 b)))))
1079 6714367 9645616 -637681868)
1082 ;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
1084 (assert (equal (multiple-value-list
1086 (compile nil '(lambda ()
1087 (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
1090 (flet ((%f16 () 0)) (%f16))))))))
1099 (declare (type (integer 867934833 3293695878) a))
1100 (declare (type (integer -82111 1776797) b))
1101 (declare (type (integer -1432413516 54121964) c))
1102 (declare (optimize (speed 3)))
1103 (declare (optimize (safety 1)))
1104 (declare (optimize (debug 1)))
1106 (flet ((%f15 (f15-1 &optional (f15-2 c))
1107 (labels ((%f1 (f1-1 f1-2) 0))
1110 (multiple-value-call #'%f15
1111 (values (%f15 c 0) (%f15 0)))))
1113 (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0))
1117 3040851270 1664281 -1340106197)))
1125 (declare (notinline <=))
1126 (declare (optimize (speed 2) (space 3) (safety 0)
1127 (debug 1) (compilation-speed 3)))
1128 (if (if (<= 0) nil nil)
1129 (labels ((%f9 (f9-1 f9-2 f9-3)
1131 (dotimes (iv4 5 a) (%f9 0 0 b)))
1135 ;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
1141 (declare (type (integer 177547470 226026978) a))
1142 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
1143 (compilation-speed 1)))
1144 (logand a (* a 438810))))
1149 ;;;; Bugs in stack analysis
1150 ;;; bug 299 (reported by PFD)
1156 (declare (optimize (debug 1)))
1157 (multiple-value-call #'list
1158 (if (eval t) (eval '(values :a :b :c)) nil)
1159 (catch 'foo (throw 'foo (values :x :y)))))))
1161 ;;; bug 298 (= MISC.183)
1162 (assert (zerop (funcall
1166 (declare (type (integer -368154 377964) a))
1167 (declare (type (integer 5044 14959) b))
1168 (declare (type (integer -184859815 -8066427) c))
1169 (declare (ignorable a b c))
1170 (declare (optimize (speed 3)))
1171 (declare (optimize (safety 1)))
1172 (declare (optimize (debug 1)))
1174 (flet ((%f3 (f3-1 f3-2 f3-3) 0))
1175 (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil)))))
1177 (assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))))
1183 (multiple-value-call #'list
1187 (multiple-value-call #'list
1193 (return-from quux 1)
1194 (throw 'baz 2))))))))))))))
1195 (assert (equal (funcall f t) '(:b 1)))
1196 (assert (equal (funcall f nil) '(:a 2))))
1204 (declare (type (integer 5 155656586618) a))
1205 (declare (type (integer -15492 196529) b))
1206 (declare (type (integer 7 10) c))
1207 (declare (optimize (speed 3)))
1208 (declare (optimize (safety 1)))
1209 (declare (optimize (debug 1)))
1212 &optional (f3-4 a) (f3-5 0)
1214 (labels ((%f10 (f10-1 f10-2 f10-3)
1219 (- (if (equal a b) b (%f10 c a 0))
1220 (catch 'ct2 (throw 'ct2 c)))
1223 (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7)
1228 '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1))
1229 (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil)))
1232 (declare (type (integer -2 19) b)
1233 (type (integer -1520 218978) c)
1234 (optimize (speed 3) (safety 1) (debug 1)))
1237 (declare (notinline logeqv apply)
1238 (optimize (safety 3) (speed 0) (debug 0)))
1240 (cf1 (compile nil fn1))
1241 (cf2 (compile nil fn2))
1242 (result1 (multiple-value-list (funcall cf1 2 18886)))
1243 (result2 (multiple-value-list (funcall cf2 2 18886))))
1244 (if (equal result1 result2)
1246 (values result1 result2))))
1256 (optimize (speed 3) (space 3) (safety 1)
1257 (debug 2) (compilation-speed 0)))
1258 (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil))))))
1261 (assert (zerop (funcall
1265 (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
1266 (compilation-speed 2)))
1267 (apply (constantly 0)
1271 (apply (constantly 0)
1290 (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
1291 (multiple-value-prog1
1292 (the integer (catch 'ct8 (catch 'ct7 15867134)))
1293 (catch 'ct1 (throw 'ct1 0))))))
1296 ;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
1297 ;;; could transform known-values LVAR to UVL
1298 (assert (zerop (funcall
1302 (declare (notinline boole values denominator list))
1308 (compilation-speed 2)))
1313 (let ((v9 (ignore-errors (throw 'ct6 0))))
1315 (progv nil nil (values (boole boole-and 0 v9)))))))))
1318 ;;; non-continuous dead UVL blocks
1319 (defun non-continuous-stack-test (x)
1320 (multiple-value-call #'list
1321 (eval '(values 11 12))
1322 (eval '(values 13 14))
1324 (return-from non-continuous-stack-test
1325 (multiple-value-call #'list
1326 (eval '(values :b1 :b2))
1327 (eval '(values :b3 :b4))
1330 (multiple-value-call (eval #'values)
1331 (eval '(values 1 2))
1332 (eval '(values 3 4))
1335 (multiple-value-call (eval #'values)
1336 (eval '(values :a1 :a2))
1337 (eval '(values :a3 :a4))
1340 (multiple-value-call (eval #'values)
1341 (eval '(values 5 6))
1342 (eval '(values 7 8))
1345 (return-from int :int))))))))))))))))
1346 (assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
1347 (assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
1349 ;;; MISC.362: environment of UNWIND-PROTECTor is different from that
1351 (assert (equal (multiple-value-list (funcall
1355 (declare (optimize (speed 3) (space 3) (safety 2)
1356 (debug 2) (compilation-speed 3)))
1359 (labels ((%f15 (f15-1 f15-2 f15-3)
1360 (rational (throw 'ct5 0))))
1366 (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
1370 (common-lisp:handler-case 0)))))
1382 (declare (notinline funcall min coerce))
1388 (compilation-speed 1)))
1389 (flet ((%f12 (f12-1)
1392 (if f12-1 (multiple-value-prog1
1393 b (return-from %f12 0))
1396 (funcall #'%f12 0))))
1399 ;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
1400 ;;; potential problem: optimizers and type derivers for MAX and MIN
1401 ;;; were not consistent in treating EQUALP, but not EQL, arguments.
1402 (dolist (f '(min max))
1403 (loop for complex-arg-args in '((1d0 2d0) (0d0 1d0))
1404 for complex-arg = `(if x ,@complex-arg-args)
1406 (loop for args in `((1 ,complex-arg)
1408 for form = `(,f ,@args)
1409 for f1 = (compile nil `(lambda (x) ,form))
1410 and f2 = (compile nil `(lambda (x) (declare (notinline min max))
1413 (dolist (x '(nil t))
1414 (assert (eql (funcall f1 x) (funcall f2 x)))))))
1417 (handler-case (compile nil '(lambda (x)
1418 (declare (optimize (speed 3) (safety 0)))
1419 (the double-float (sqrt (the double-float x)))))
1420 (sb-ext:compiler-note (c)
1421 ;; Ignore the note for the float -> pointer conversion of the
1423 (unless (string= (car (last (sb-c::simple-condition-format-arguments c)))
1425 (error "Compiler does not trust result type assertion."))))
1427 (let ((f (compile nil '(lambda (x)
1428 (declare (optimize speed (safety 0)))
1431 (multiple-value-prog1
1432 (sqrt (the double-float x))
1434 (return :minus)))))))))
1435 (assert (eql (funcall f -1d0) :minus))
1436 (assert (eql (funcall f 4d0) 2d0)))
1438 ;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
1440 (compile nil '(lambda (a i)
1442 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
1443 (inhibit-warnings 0)))
1444 (declare (type (alien (* (unsigned 8))) a)
1445 (type (unsigned-byte 32) i))
1448 (unless (search "%ASH/RIGHT" (first (simple-condition-format-arguments c)))
1449 (error "The code is not optimized."))))
1452 (compile nil '(lambda (x)
1453 (declare (type (integer -100 100) x))
1454 (declare (optimize speed))
1455 (declare (notinline identity))
1457 (compiler-note () (error "IDENTITY derive-type not applied.")))
1459 (assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
1461 ;;; MISC.293 = easy variant of bug 303: repeated write to the same
1462 ;;; LVAR; here the first write may be cleared before the second is
1470 (declare (notinline complex))
1471 (declare (optimize (speed 1) (space 0) (safety 1)
1472 (debug 3) (compilation-speed 3)))
1473 (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
1474 (complex (%f) 0)))))))
1476 ;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
1477 (assert (zerop (funcall
1481 (declare (type (integer -1294746569 1640996137) a))
1482 (declare (type (integer -807801310 3) c))
1483 (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
1490 (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
1492 391833530 -32785211)))
1494 ;;; efficiency notes for ordinary code
1495 (macrolet ((frob (arglist &body body)
1498 (compile nil '(lambda ,arglist ,@body))
1499 (sb-ext:compiler-note (e)
1500 (error "bad compiler note for ~S:~% ~A" ',body e)))
1503 (compile nil '(lambda ,arglist (declare (optimize speed))
1505 (sb-ext:compiler-note (e) (throw :got-note nil)))
1506 (error "missing compiler note for ~S" ',body)))))
1507 (frob (x) (funcall x))
1508 (frob (x y) (find x y))
1509 (frob (x y) (find-if x y))
1510 (frob (x y) (find-if-not x y))
1511 (frob (x y) (position x y))
1512 (frob (x y) (position-if x y))
1513 (frob (x y) (position-if-not x y))
1514 (frob (x) (aref x 0)))
1516 (macrolet ((frob (style-warn-p form)
1518 `(catch :got-style-warning
1521 (style-warning (e) (throw :got-style-warning nil)))
1522 (error "missing style-warning for ~S" ',form))
1526 (error "bad style-warning for ~S: ~A" ',form e))))))
1527 (frob t (lambda (x &optional y &key z) (list x y z)))
1528 (frob nil (lambda (x &optional y z) (list x y z)))
1529 (frob nil (lambda (x &key y z) (list x y z)))
1530 (frob t (defgeneric #:foo (x &optional y &key z)))
1531 (frob nil (defgeneric #:foo (x &optional y z)))
1532 (frob nil (defgeneric #:foo (x &key y z)))
1533 (frob t (defun #:foo (x) (flet ((foo (x &optional y &key z) (list x y z))) (foo x x :z x)))))
1535 ;;; this was a bug in the LOGXOR type deriver. The top form gave a
1536 ;;; note, because the system failed to derive the fact that the return
1537 ;;; from LOGXOR was small and negative, though the bottom one worked.
1538 (handler-bind ((sb-ext:compiler-note #'error))
1539 (compile nil '(lambda ()
1540 (declare (optimize speed (safety 0)))
1542 (declare (type (integer 3 6) x)
1543 (type (integer -6 -3) y))
1544 (+ (logxor x y) most-positive-fixnum)))))
1545 (handler-bind ((sb-ext:compiler-note #'error))
1546 (compile nil '(lambda ()
1547 (declare (optimize speed (safety 0)))
1549 (declare (type (integer 3 6) y)
1550 (type (integer -6 -3) x))
1551 (+ (logxor x y) most-positive-fixnum)))))
1553 ;;; check that modular ash gives the right answer, to protect against
1554 ;;; possible misunderstandings about the hardware shift instruction.
1555 (assert (zerop (funcall
1556 (compile nil '(lambda (x y)
1557 (declare (optimize speed)
1558 (type (unsigned-byte 32) x y))
1559 (logand #xffffffff (ash x y))))
1562 ;;; code instrumenting problems
1565 (declare (optimize (debug 3)))
1566 (list (the integer (if nil 14 t)))))
1570 (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD))
1576 (COMPILATION-SPEED 0)))
1577 (MASK-FIELD (BYTE 7 26)
1579 (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
1583 '(lambda (buffer i end)
1584 (declare (optimize (debug 3)))
1585 (loop (when (not (eql 0 end)) (return)))
1586 (let ((s (make-string end)))
1587 (setf (schar s i) (schar buffer i))
1590 ;;; check that constant string prefix and suffix don't cause the
1591 ;;; compiler to emit code deletion notes.
1592 (handler-bind ((sb-ext:code-deletion-note #'error))
1593 (compile nil '(lambda (s x)
1594 (pprint-logical-block (s x :prefix "(")
1596 (compile nil '(lambda (s x)
1597 (pprint-logical-block (s x :per-line-prefix ";")
1599 (compile nil '(lambda (s x)
1600 (pprint-logical-block (s x :suffix ">")
1603 ;;; MISC.427: loop analysis requires complete DFO structure
1604 (assert (eql 17 (funcall
1608 (declare (notinline list reduce logior))
1609 (declare (optimize (safety 2) (compilation-speed 1)
1610 (speed 3) (space 2) (debug 2)))
1612 (let* ((v5 (reduce #'+ (list 0 a))))
1613 (declare (dynamic-extent v5))
1618 (assert (zerop (funcall
1622 (declare (type (integer -8431780939320 1571817471932) a))
1623 (declare (type (integer -4085 0) b))
1624 (declare (ignorable a b))
1627 (compilation-speed 0)
1628 #+sbcl (sb-c:insert-step-conditions 0)
1635 (elt '(1954479092053)
1639 (lognand iv1 (ash iv1 (min 53 iv1)))
1642 -7639589303599 -1368)))
1647 (declare (type (integer) a))
1648 (declare (type (integer) b))
1649 (declare (ignorable a b))
1650 (declare (optimize (space 2) (compilation-speed 0)
1651 (debug 0) (safety 0) (speed 3)))
1653 (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass
1654 (print (if (< iv1 iv1)
1655 (logand (ash iv1 iv1) 1)
1658 ;;; MISC.435: lambda var substitution in a deleted code.
1659 (assert (zerop (funcall
1663 (declare (notinline aref logandc2 gcd make-array))
1665 (optimize (space 0) (safety 0) (compilation-speed 3)
1666 (speed 3) (debug 1)))
1669 (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2)))))
1670 (declare (dynamic-extent v2))
1671 (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2))))
1674 3021871717588 -866608 -2 -17194)))
1676 ;;; MISC.436, 438: lost reoptimization
1677 (assert (zerop (funcall
1681 (declare (type (integer -2917822 2783884) a))
1682 (declare (type (integer 0 160159) b))
1683 (declare (ignorable a b))
1685 (optimize (compilation-speed 1)
1689 ; #+sbcl (sb-c:insert-step-conditions 0)
1703 '(-10197561 486 430631291
1709 (assert (zerop (funcall
1713 (declare (type (integer 0 1696) a))
1714 ; (declare (ignorable a))
1715 (declare (optimize (space 2) (debug 0) (safety 1)
1716 (compilation-speed 0) (speed 1)))
1717 (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0)))
1724 (declare (type (simple-array function (2)) s) (type ei ei))
1725 (funcall (aref s ei) x y))))
1727 ;;; MISC.320: ir1-transform can create an intercomponent reference to
1729 (assert (eql 102 (funcall
1733 (declare (optimize (speed 3) (space 0) (safety 2)
1734 (debug 2) (compilation-speed 0)))
1737 (flet ((%f12 () (rem 0 -43)))
1738 (multiple-value-call #'%f12 (values))))))))))
1740 ;;; MISC.437: lost reoptimization after FLUSH-DEST
1741 (assert (zerop (funcall
1744 '(lambda (a b c d e)
1745 (declare (notinline values complex eql))
1747 (optimize (compilation-speed 3)
1754 &optional (f10-4 (ignore-errors 0)) (f10-5 0)
1755 &key &allow-other-keys)
1756 (if (or (eql 0 0) t) 0 (if f10-1 0 0))))
1757 (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0))))
1758 80043 74953652306 33658947 -63099937105 -27842393)))
1760 ;;; bug #351 -- program-error for malformed LET and LET*, including those
1761 ;;; resulting from SETF of LET.
1762 (dolist (fun (list (compile nil '(lambda () (let :bogus-let :oops)))
1763 (compile nil '(lambda () (let* :bogus-let* :oops)))
1764 (compile nil '(lambda (x) (push x (let ((y 0)) y))))))
1765 (assert (functionp fun))
1766 (multiple-value-bind (res err) (ignore-errors (funcall fun))
1768 (assert (typep err 'program-error))))
1770 (let ((fun (compile nil '(lambda (x) (random (if x 10 20))))))
1771 (dotimes (i 100 (error "bad RANDOM distribution"))
1772 (when (> (funcall fun nil) 9)
1775 (when (> (funcall fun t) 9)
1776 (error "bad RANDOM event"))))
1778 ;;; 0.8.17.28-sma.1 lost derived type information.
1779 (with-test (:name :0.8.17.28-sma.1 :fails-on :sparc)
1780 (handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c))))
1783 (declare (optimize (speed 3) (safety 0)))
1784 (declare (type (integer 0 80) x)
1785 (type (integer 0 11) y)
1786 (type (simple-array (unsigned-byte 32) (*)) v))
1787 (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y))
1790 ;;; Bug reported by Robert J. Macomber: instrumenting of more-entry
1791 ;;; prevented open coding of %LISTIFY-REST-ARGS.
1792 (let ((f (compile nil '(lambda ()
1793 (declare (optimize (debug 3)))
1794 (with-simple-restart (blah "blah") (error "blah"))))))
1795 (handler-bind ((error (lambda (c) (invoke-restart 'blah))))
1796 (assert (equal (multiple-value-list (funcall f)) '(nil t)))))
1798 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
1799 ;;; constant index and value.
1800 (loop for n-bits = 1 then (* n-bits 2)
1801 for type = `(unsigned-byte ,n-bits)
1802 and v-max = (1- (ash 1 n-bits))
1803 while (<= n-bits sb-vm:n-word-bits)
1805 (let* ((n (* 2 (1+ (- sb-vm::n-word-bits n-bits))))
1806 (array1 (make-array n :element-type type))
1807 (array2 (make-array n :element-type type)))
1809 (dolist (v (list 0 v-max))
1810 (let ((f (compile nil `(lambda (a)
1811 (declare (type (simple-array ,type (,n)) a))
1812 (setf (aref a ,i) ,v)))))
1813 (fill array1 (- v-max v))
1814 (fill array2 (- v-max v))
1816 (setf (aref array2 i) v)
1817 (assert (every #'= array1 array2)))))))
1819 (let ((fn (compile nil '(lambda (x)
1820 (declare (type bit x))
1821 (declare (optimize speed))
1822 (let ((b (make-array 64 :element-type 'bit
1823 :initial-element 0)))
1825 (assert (= (funcall fn 0) 64))
1826 (assert (= (funcall fn 1) 0)))
1828 (let ((fn (compile nil '(lambda (x y)
1829 (declare (type simple-bit-vector x y))
1830 (declare (optimize speed))
1834 (make-array 64 :element-type 'bit :initial-element 0)
1835 (make-array 64 :element-type 'bit :initial-element 0)))
1839 (make-array 64 :element-type 'bit :initial-element 0)
1840 (let ((b (make-array 64 :element-type 'bit :initial-element 0)))
1841 (setf (sbit b 63) 1)
1844 ;;; MISC.535: compiler failure
1845 (let ((c0 #c(4196.088977268509d0 -15943.3603515625d0)))
1846 (assert (not (funcall
1850 (declare (optimize speed (safety 1))
1853 (eql (the (complex double-float) p1) p2)))
1854 c0 #c(12 612/979)))))
1856 ;;; reported by Lutz Euler: we shouldn't signal a compiler note for
1857 ;;; simple-bit-vector functions.
1858 (handler-bind ((sb-ext:compiler-note #'error))
1859 (compile nil '(lambda (x)
1860 (declare (type simple-bit-vector x))
1862 (handler-bind ((sb-ext:compiler-note #'error))
1863 (compile nil '(lambda (x y)
1864 (declare (type simple-bit-vector x y))
1867 ;;; MISC.550: CAST merging in IR1 finalization caused unexpected
1868 ;;; code transformations.
1869 (assert (eql (funcall
1873 (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
1876 (or p1 (the (eql t) p2))))
1880 ;;; MISC.548: type check weakening converts required type into
1887 (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
1888 (atom (the (member f assoc-if write-line t w) p1))))
1891 ;;; Free special bindings only apply to the body of the binding form, not
1892 ;;; the initialization forms.
1894 (funcall (compile 'nil
1897 (declare (special x))
1899 ((lambda (&optional (y x))
1900 (declare (special x)) y)))))))))
1902 ;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
1903 ;;; a rational was zero, but didn't do the substitution, leading to a
1904 ;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
1905 ;;; machine's ASH instruction's immediate field) that the compiler
1906 ;;; thought was legitimate.
1908 ;;; FIXME: this has been recorded as bug 383. The attempted fix (sbcl
1909 ;;; 0.9.2.6) led to lots of spurious optimization notes. So the bug stil
1910 ;;; exist and this test case serves as a reminder of the problem.
1911 ;;; --njf, 2005-07-05
1915 (DECLARE (TYPE (INTEGER -2 14) B))
1916 (DECLARE (IGNORABLE B))
1917 (ASH (IMAGPART B) 57)))
1919 ;;; bug reported by Eduardo Mu\~noz
1920 (multiple-value-bind (fun warnings failure)
1921 (compile nil '(lambda (struct first)
1922 (declare (optimize speed))
1923 (let* ((nodes (nodes struct))
1924 (bars (bars struct))
1925 (length (length nodes))
1926 (new (make-array length :fill-pointer 0)))
1927 (vector-push first new)
1928 (loop with i fixnum = 0
1929 for newl fixnum = (length new)
1930 while (< newl length) do
1931 (let ((oldl (length new)))
1932 (loop for j fixnum from i below newl do
1933 (dolist (n (node-neighbours (aref new j) bars))
1934 (unless (find n new)
1935 (vector-push n new))))
1938 (declare (ignore fun warnings failure))
1939 (assert (not failure)))
1941 ;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe
1943 (compile nil '(lambda (x y a b c)
1944 (- y (* (signum x) (sqrt (abs (- (* b x) c)))))))
1946 ;;; Type inference from CHECK-TYPE
1947 (let ((count0 0) (count1 0))
1948 (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count0))))
1949 (compile nil '(lambda (x)
1950 (declare (optimize (speed 3)))
1952 ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note
1953 (assert (> count0 1))
1954 (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1))))
1955 (compile nil '(lambda (x)
1956 (declare (optimize (speed 3)))
1957 (check-type x fixnum)
1959 ;; Only the posssible word -> bignum conversion note
1960 (assert (= count1 1)))
1962 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
1963 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
1964 (with-test (:name :sap-ref-float)
1965 (compile nil '(lambda (sap)
1966 (let ((x (setf (sb-vm::sap-ref-double sap 0) 1d0)))
1968 (compile nil '(lambda (sap)
1969 (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0)))
1973 (with-test (:name :string-union-types)
1974 (compile nil '(lambda (x)
1975 (declare (type (or (simple-array character (6))
1976 (simple-array character (5))) x))
1979 ;;; MISC.623: missing functions for constant-folding
1985 (declare (optimize (space 2) (speed 0) (debug 2)
1986 (compilation-speed 3) (safety 0)))
1987 (loop for lv3 below 1
1989 (loop for lv2 below 2
1991 (bit #*1001101001001
1992 (min 12 (max 0 lv3))))))))))))
1994 ;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs
2000 (declare (type (integer 21 28) a))
2001 (declare (optimize (compilation-speed 1) (safety 2)
2002 (speed 0) (debug 0) (space 1)))
2003 (let* ((v7 (flet ((%f3 (f3-1 f3-2)
2004 (loop for lv2 below 1
2008 (min 7 (max 0 (eval '0))))))))
2013 ;;; MISC.626: bandaged AVER was still wrong
2014 (assert (eql -829253
2019 (declare (type (integer -902970 2) a))
2020 (declare (optimize (space 2) (debug 0) (compilation-speed 1)
2021 (speed 0) (safety 3)))
2022 (prog2 (if (logbitp 30 a) 0 (block b3 0)) a)))
2025 ;; MISC.628: constant-folding %LOGBITP was buggy
2031 (declare (optimize (safety 3) (space 3) (compilation-speed 3)
2032 (speed 0) (debug 1)))
2033 (not (not (logbitp 0 (floor 2147483651 (min -23 0))))))))))
2035 ;; mistyping found by random-tester
2041 (declare (optimize (speed 1) (debug 0)
2042 (space 2) (safety 0) (compilation-speed 0)))
2044 (* (/ (multiple-value-prog1 -29457482 -5602513511) 1))))))))
2046 ;; aggressive constant folding (bug #400)
2048 (eq t (funcall (compile nil '(lambda () (or t (the integer (/ 1 0))))))))
2050 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-1))
2053 (compile nil '(lambda (x y)
2054 (when (eql x (length y))
2056 (declare (optimize (speed 3)))
2058 (compiler-note () (error "The code is not optimized.")))))
2060 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-2))
2063 (compile nil '(lambda (x y)
2064 (when (eql (length y) x)
2066 (declare (optimize (speed 3)))
2068 (compiler-note () (error "The code is not optimized.")))))
2070 (with-test (:name (:compiler :constraint-propagation :float-bounds-1))
2072 (compile nil '(lambda (x)
2073 (declare (type (single-float * (3.0)) x))
2077 (compiler-note () (error "Deleted reachable code."))))
2079 (with-test (:name (:compiler :constraint-propagation :float-bounds-2))
2082 (compile nil '(lambda (x)
2083 (declare (type single-float x))
2086 (error "This is unreachable.")))))
2087 (compiler-note () (throw :note nil)))
2088 (error "Unreachable code undetected.")))
2090 (with-test (:name (:compiler :constraint-propagation :float-bounds-3
2094 (compile nil '(lambda (x)
2095 (declare (type (single-float 0.0) x))
2098 (error "This is unreachable.")))))
2099 (compiler-note () (throw :note nil)))
2100 (error "Unreachable code undetected.")))
2102 (with-test (:name (:compiler :constraint-propagation :float-bounds-4
2106 (compile nil '(lambda (x y)
2107 (declare (type (single-float 0.0) x)
2108 (type (single-float (0.0)) y))
2111 (error "This is unreachable.")))))
2112 (compiler-note () (throw :note nil)))
2113 (error "Unreachable code undetected.")))
2115 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
2118 (compile nil '(lambda (x y)
2119 (when (typep y 'fixnum)
2121 (unless (typep x 'fixnum)
2122 (error "This is unreachable"))
2124 (compiler-note () (throw :note nil)))
2125 (error "Unreachable code undetected.")))
2127 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-2))
2130 (compile nil '(lambda (x y)
2131 (when (typep y 'fixnum)
2133 (unless (typep x 'fixnum)
2134 (error "This is unreachable"))
2136 (compiler-note () (throw :note nil)))
2137 (error "Unreachable code undetected.")))
2139 ;; Reported by John Wiseman, sbcl-devel
2140 ;; Subject: [Sbcl-devel] float type derivation bug?
2141 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700
2142 (with-test (:name (:type-derivation :float-bounds))
2143 (compile nil '(lambda (bits)
2144 (let* ((s (if (= (ash bits -31) 0) 1 -1))
2145 (e (logand (ash bits -23) #xff))
2147 (ash (logand bits #x7fffff) 1)
2148 (logior (logand bits #x7fffff) #x800000))))
2149 (float (* s m (expt 2 (- e 150))))))))
2151 ;; Reported by James Knight
2152 ;; Subject: [Sbcl-devel] AVER: "(EQ (SB-NAME (SC-SB (TN-SC TN))) 'REGISTERS)"
2153 ;; Date: Fri, 24 Mar 2006 19:30:00 -0500
2154 (with-test (:name :logbitp-vop)
2156 '(lambda (days shift)
2157 (declare (type fixnum shift days))
2159 (canonicalized-shift (+ shift 1))
2160 (first-wrapping-day (- 1 canonicalized-shift)))
2161 (declare (type fixnum result))
2162 (dotimes (source-day 7)
2163 (declare (type (integer 0 6) source-day))
2164 (when (logbitp source-day days)
2168 (if (< source-day first-wrapping-day)
2169 (+ source-day canonicalized-shift)
2171 canonicalized-shift) 7)))))))
2174 ;;; MISC.637: incorrect delaying of conversion of optional entries
2175 ;;; with hairy constant defaults
2176 (let ((f '(lambda ()
2177 (labels ((%f11 (f11-2 &key key1)
2178 (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0)))
2183 (assert (eq (funcall (compile nil f)) :good)))
2185 ;;; MISC.555: new reference to an already-optimized local function
2186 (let* ((l '(lambda (p1)
2187 (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1))
2189 (f (compile nil l)))
2190 (assert (funcall f :good))
2191 (assert (nth-value 1 (ignore-errors (funcall f 42)))))
2193 ;;; Check that the compiler doesn't munge *RANDOM-STATE*.
2194 (let* ((state (make-random-state))
2195 (*random-state* (make-random-state state))
2196 (a (random most-positive-fixnum)))
2197 (setf *random-state* state)
2198 (compile nil `(lambda (x a)
2199 (declare (single-float x)
2200 (type (simple-array double-float) a))
2201 (+ (loop for i across a
2204 (assert (= a (random most-positive-fixnum))))
2206 ;;; MISC.641: LET-conversion after physical environment analysis lost NLX-INFOs
2207 (let ((form '(lambda ()
2208 (declare (optimize (speed 1) (space 0) (debug 2)
2209 (compilation-speed 0) (safety 1)))
2210 (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #())))
2212 (apply #'%f3 0 nil)))))
2213 (assert (zerop (funcall (compile nil form)))))
2215 ;;; 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
2216 (compile nil '(lambda ()
2217 (let ((x (make-array '(1) :element-type '(signed-byte 32))))
2218 (setf (aref x 0) 1))))
2220 ;;; step instrumentation confusing the compiler, reported by Faré
2221 (handler-bind ((warning #'error))
2222 (compile nil '(lambda ()
2223 (declare (optimize (debug 2))) ; not debug 3!
2224 (let ((val "foobar"))
2225 (map-into (make-array (list (length val))
2226 :element-type '(unsigned-byte 8))
2227 #'char-code val)))))
2229 ;;; overconfident primitive type computation leading to bogus type
2231 (let* ((form1 '(lambda (x)
2232 (declare (type (and condition function) x))
2234 (fun1 (compile nil form1))
2236 (declare (type (and standard-object function) x))
2238 (fun2 (compile nil form2)))
2239 (assert (raises-error? (funcall fun1 (make-condition 'error))))
2240 (assert (raises-error? (funcall fun1 fun1)))
2241 (assert (raises-error? (funcall fun2 fun2)))
2242 (assert (eq (funcall fun2 #'print-object) #'print-object)))
2244 ;;; LET* + VALUES declaration: while the declaration is a non-standard
2245 ;;; and possibly a non-conforming extension, as long as we do support
2246 ;;; it, we might as well get it right.
2248 ;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
2249 (compile nil '(lambda () (let* () (declare (values list)))))
2252 ;;; test for some problems with too large immediates in x86-64 modular
2254 (compile nil '(lambda (x) (declare (fixnum x))
2255 (logand most-positive-fixnum (logxor x most-positive-fixnum))))
2257 (compile nil '(lambda (x) (declare (fixnum x))
2258 (logand most-positive-fixnum (+ x most-positive-fixnum))))
2260 (compile nil '(lambda (x) (declare (fixnum x))
2261 (logand most-positive-fixnum (* x most-positive-fixnum))))
2264 (with-test (:name :propagate-type-through-error-and-binding)
2265 (assert (let (warned-p)
2266 (handler-bind ((warning (lambda (w) (setf warned-p t))))
2269 (list (let ((y (the real x)))
2270 (unless (floatp y) (error ""))
2272 (integer-length x)))))
2275 ;; Dead / in safe code
2276 (with-test (:name :safe-dead-/)
2279 (funcall (compile nil
2281 (declare (optimize (safety 3)))
2286 (division-by-zero ()
2289 ;;; Dead unbound variable (bug 412)
2290 (with-test (:name :dead-unbound)
2293 (funcall (compile nil
2297 (unbound-variable ()
2300 ;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR.
2301 (handler-bind ((sb-ext:compiler-note 'error))
2304 (funcall (compile nil `(lambda (s p e)
2305 (declare (optimize speed)
2312 ;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR.
2313 (handler-bind ((sb-ext:compiler-note 'error))
2316 (funcall (compile nil `(lambda (s)
2317 (declare (optimize speed)
2320 (vector 1 2 3 4)))))
2322 ;;; bug in adding DATA-VECTOR-REF-WITH-OFFSET to x86-64
2323 (assert (not (mismatch #(1.0f0 2.0f0) (make-array 2 :element-type 'single-float :initial-contents (list 1.0f0 2.0f0)))))
2325 ;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too
2326 ;;; large bignums to floats
2327 (dolist (op '(* / + -))
2331 (declare (type (integer 0 #.(* 2 (truncate most-positive-double-float))) x))
2334 do (let ((arg (random (truncate most-positive-double-float))))
2335 (assert (eql (funcall fun arg)
2336 (funcall op 0.0d0 arg)))))))
2338 (with-test (:name :high-debug-known-function-inlining)
2339 (let ((fun (compile nil
2341 (declare (optimize (debug 3)) (inline append))
2342 (let ((fun (lambda (body)
2347 '((foo (bar)))))))))
2350 (with-test (:name :high-debug-known-function-transform-with-optional-arguments)
2351 (compile nil '(lambda (x y)
2352 (declare (optimize sb-c::preserve-single-use-debug-variables))
2354 (some-unknown-function
2356 (return (member x y))))
2361 ;;; Compiling W-P-O when the pinned objects are known to be fixnums
2363 (compile nil '(lambda (x y)
2364 (declare (fixnum y) (character x))
2365 (sb-sys:with-pinned-objects (x y)
2366 (some-random-function))))
2368 ;;; *CHECK-CONSISTENCY* and TRULY-THE
2370 (with-test (:name :bug-423)
2371 (let ((sb-c::*check-consistency* t))
2372 (handler-bind ((warning #'error))
2373 (flet ((make-lambda (type)
2377 (let ((q (truly-the list z)))
2380 (let ((q (truly-the vector z)))
2384 (compile nil (make-lambda 'list))
2385 (compile nil (make-lambda 'vector))))))
2387 ;;; this caused a momentary regression when an ill-adviced fix to
2388 ;;; bug 427 made ANY-REG suitable for primitive-type T:
2390 ;;; no :MOVE-ARG VOP defined to move #<SB-C:TN t1> (SC SB-VM::SINGLE-REG) to #<SB-C:TN t2> (SC SB-VM::ANY-REG)
2391 ;;; [Condition of type SIMPLE-ERROR]
2398 (setf (sb-alien:deref (sb-alien:cast (sb-alien:sap-alien (unknown1) (* unsigned-char))
2399 (* double-float))) frob))
2401 (%zig (the (values (single-float (0.0) 1.0) &optional) (unknown2)))
2405 ;;; non-required arguments in HANDLER-BIND
2406 (assert (eq :oops (car (funcall (compile nil
2409 (handler-bind ((error (lambda (&rest args) (return (cons :oops args)))))
2413 ;;; NIL is a legal function name
2414 (assert (eq 'a (flet ((nil () 'a)) (nil))))
2417 (assert (null (let* ((x 296.3066f0)
2419 (form `(lambda (r p2)
2420 (declare (optimize speed (safety 1))
2421 (type (simple-array single-float nil) r)
2422 (type (integer -9369756340 22717335) p2))
2423 (setf (aref r) (* ,x (the (eql 22717067) p2)))
2425 (r (make-array nil :element-type 'single-float))
2427 (funcall (compile nil form) r y)
2428 (let ((actual (aref r)))
2429 (unless (eql expected actual)
2430 (list expected actual))))))
2432 (assert (null (let* ((x -2367.3296f0)
2434 (form `(lambda (r p2)
2435 (declare (optimize speed (safety 1))
2436 (type (simple-array single-float nil) r)
2437 (type (eql 46790178) p2))
2438 (setf (aref r) (+ ,x (the (integer 45893897) p2)))
2440 (r (make-array nil :element-type 'single-float))
2442 (funcall (compile nil form) r y)
2443 (let ((actual (aref r)))
2444 (unless (eql expected actual)
2445 (list expected actual))))))
2450 (compile nil '(lambda (p1 p2)
2452 (optimize (speed 1) (safety 0)
2453 (debug 0) (space 0))
2454 (type (member 8174.8604) p1)
2455 (type (member -95195347) p2))
2457 8174.8604 -95195347)))
2465 (declare (optimize (speed 3) (safety 0) (debug 3) (space 1))
2466 (type (member -94430.086f0) p1))
2467 (floor (the single-float p1) 19311235)))
2476 (declare (optimize (speed 1) (safety 2)
2477 (debug 2) (space 3))
2478 (type (eql -39466.56f0) p1))
2479 (ffloor p1 305598613)))
2488 (declare (optimize (speed 1) (safety 1) (debug 1) (space 2))
2489 (type (eql -83232.09f0) p1))
2490 (ceiling p1 -83381228)))
2499 (declare (optimize (speed 1) (safety 1)
2500 (debug 1) (space 0))
2501 (type (member -66414.414f0) p1))
2502 (ceiling p1 -63019173f0)))
2511 (declare (optimize (speed 0) (safety 1)
2512 (debug 0) (space 1))
2513 (type (eql 20851.398f0) p1))
2514 (fceiling p1 80839863)))
2520 (compile nil '(lambda (x)
2521 (declare (type (eql -5067.2056) x))
2528 (compile nil '(lambda (x) (declare (type (eql -1.0) x))
2534 (assert (plusp (funcall
2538 (declare (optimize (speed 0) (safety 1) (debug 1) (space 1))
2539 (type (eql -39887.645) p1))
2540 (mod p1 382352925)))
2544 (assert (let ((result (funcall
2548 (declare (optimize (speed 0) (safety 3) (debug 1) (space 0))
2549 (type (eql 33558541) p2))
2552 (typep result 'single-float)))
2556 (let* ((form '(lambda (p2)
2557 (declare (optimize (speed 0) (safety 1)
2558 (debug 2) (space 2))
2559 (type (member -19261719) p2))
2560 (ceiling -46022.094 p2))))
2561 (values (funcall (compile nil form) -19261719)))))
2564 (assert (let* ((x 26899.875)
2566 (declare (optimize (speed 3) (safety 1) (debug 3) (space 1))
2567 (type (member ,x #:g5437 char-code #:g5438) p2))
2569 (floatp (funcall (compile nil form) x))))
2577 (declare (optimize (speed 3) (safety 2) (debug 3) (space 0))
2579 (+ 81535869 (the (member 17549.955 #:g35917) p2))))
2581 (+ 81535869 17549.955)))
2585 (let ((form '(lambda (p2)
2586 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2587 (type (member integer eql) p2))
2589 (funcall (compile nil form) 'integer))))
2593 (let ((form '(lambda (p2)
2594 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2595 (type (member integer mod) p2))
2597 (funcall (compile nil form) 'integer))))
2601 (let ((form '(lambda (p2)
2602 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2603 (type (member integer values) p2))
2605 (funcall (compile nil form) 'integer))))
2607 (with-test (:name :string-aref-type)
2608 (assert (eq 'character
2609 (funcall (compile nil
2611 (ctu:compiler-derived-type (aref (the string s) 0))))
2614 (with-test (:name :base-string-aref-type)
2615 (assert (eq #+sb-unicode 'base-char
2616 #-sb-unicode 'character
2617 (funcall (compile nil
2619 (ctu:compiler-derived-type (aref (the base-string s) 0))))
2620 (coerce "foo" 'base-string)))))
2622 (with-test (:name :dolist-constant-type-derivation)
2623 (assert (equal '(integer 1 3)
2624 (funcall (compile nil
2626 (dolist (y '(1 2 3))
2628 (return (ctu:compiler-derived-type y))))))
2631 (with-test (:name :dolist-simple-list-type-derivation)
2632 (assert (equal '(integer 1 3)
2633 (funcall (compile nil
2635 (dolist (y (list 1 2 3))
2637 (return (ctu:compiler-derived-type y))))))
2640 (with-test (:name :dolist-dotted-constant-list-type-derivation)
2642 (fun (handler-bind ((style-warning (lambda (c) (push c warned))))
2645 (dolist (y '(1 2 3 . 4) :foo)
2647 (return (ctu:compiler-derived-type y)))))))))
2648 (assert (equal '(integer 1 3) (funcall fun t)))
2649 (assert (= 1 (length warned)))
2650 (multiple-value-bind (res err) (ignore-errors (funcall fun nil))
2652 (assert (typep err 'type-error)))))
2654 (with-test (:name :constant-list-destructuring)
2655 (handler-bind ((sb-ext:compiler-note #'error))
2661 (destructuring-bind (a (b c) d) '(1 (2 3) 4)
2668 (destructuring-bind (a (b c) d) '(1 "foo" 4)
2672 ;;; Functions with non-required arguments used to end up with
2673 ;;; (&OPTIONAL-DISPATCH ...) as their names.
2674 (with-test (:name :hairy-function-name)
2675 (assert (eq 'read-line (nth-value 2 (function-lambda-expression #'read-line))))
2676 (assert (equal "#<FUNCTION READ-LINE>" (princ-to-string #'read-line))))
2678 ;;; PROGV + RESTRICT-COMPILER-POLICY
2679 (with-test (:name :progv-and-restrict-compiler-policy)
2680 (let ((sb-c::*policy-restrictions* sb-c::*policy-restrictions*))
2681 (restrict-compiler-policy 'debug 3)
2682 (let ((fun (compile nil '(lambda (x)
2684 (declare (special i))
2686 (progv '(i) (list (+ i 1))
2689 (assert (equal '(1 2 1) (funcall fun 1))))))
2691 ;;; It used to be possible to confuse the compiler into
2692 ;;; IR2-converting such a call to CONS
2693 (with-test (:name :late-bound-primitive)
2694 (compile nil `(lambda ()
2695 (funcall 'cons 1))))
2697 (with-test (:name :hairy-array-element-type-derivation)
2698 (compile nil '(lambda (x)
2699 (declare (type (and simple-string (satisfies array-has-fill-pointer-p)) x))
2700 (array-element-type x))))
2702 (with-test (:name :rest-list-type-derivation)
2703 (multiple-value-bind (type derivedp)
2704 (funcall (compile nil `(lambda (&rest args)
2705 (ctu:compiler-derived-type args)))
2707 (assert (eq 'list type))
2710 (with-test (:name :rest-list-type-derivation2)
2711 (multiple-value-bind (type derivedp)
2712 (funcall (funcall (compile nil `(lambda ()
2713 (lambda (&rest args)
2714 (ctu:compiler-derived-type args))))))
2715 (assert (eq 'list type))
2718 (with-test (:name :rest-list-type-derivation3)
2719 (multiple-value-bind (type derivedp)
2720 (funcall (funcall (compile nil `(lambda ()
2721 (lambda (&optional x &rest args)
2722 (unless x (error "oops"))
2723 (ctu:compiler-derived-type args)))))
2725 (assert (eq 'list type))
2728 (with-test (:name :rest-list-type-derivation4)
2729 (multiple-value-bind (type derivedp)
2730 (funcall (funcall (compile nil `(lambda ()
2731 (lambda (&optional x &rest args)
2732 (declare (type (or null integer) x))
2733 (when x (setf args x))
2734 (ctu:compiler-derived-type args)))))
2736 (assert (equal '(or cons null integer) type))
2739 (with-test (:name :base-char-typep-elimination)
2740 (assert (eq (funcall (compile nil
2742 (declare (type base-char ch) (optimize (speed 3) (safety 0)))
2743 (typep ch 'base-char)))
2747 (with-test (:name :regression-1.0.24.37)
2748 (compile nil '(lambda (&key (test (constantly t)))
2749 (when (funcall test)
2752 ;;; Attempt to test a decent cross section of conditions
2753 ;;; and values types to move conditionally.
2755 ((test-comparison (comparator type x y)
2757 ,@(loop for (result-type a b)
2763 (nil #c(1.0 1.0) #c(2.0 2.0))
2767 ((unsigned-byte #.sb-vm:n-word-bits)
2768 (1+ most-positive-fixnum)
2769 (+ 2 most-positive-fixnum))
2770 ((signed-byte #.sb-vm:n-word-bits)
2771 -1 (* 2 most-negative-fixnum))
2772 (single-float 0.0 1.0)
2773 (double-float 0d0 1d0))
2774 for lambda = (if result-type
2776 (declare (,type x y)
2778 (if (,comparator x y)
2781 (declare (,type x y))
2782 (if (,comparator x y)
2784 for args = `(,x ,y ,@(and result-type
2788 (eql (funcall (compile nil ',lambda)
2790 (eval '(,lambda ,@args))))))))
2791 (sb-vm::with-float-traps-masked
2792 (:divide-by-zero :overflow :inexact :invalid)
2793 (let (#+sb-eval (sb-ext:*evaluator-mode* :interpret))
2794 (declare (sb-ext:muffle-conditions style-warning))
2795 (test-comparison eql t t nil)
2796 (test-comparison eql t t t)
2798 (test-comparison = t 1 0)
2799 (test-comparison = t 1 1)
2800 (test-comparison = t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2801 (test-comparison = fixnum 1 0)
2802 (test-comparison = fixnum 0 0)
2803 (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2804 (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2805 (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 0)
2806 (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 1)
2808 (test-comparison = single-float 0.0 1.0)
2809 (test-comparison = single-float 1.0 1.0)
2810 (test-comparison = single-float (/ 1.0 0.0) (/ 1.0 0.0))
2811 (test-comparison = single-float (/ 1.0 0.0) 1.0)
2812 (test-comparison = single-float (/ 0.0 0.0) (/ 0.0 0.0))
2813 (test-comparison = single-float (/ 0.0 0.0) 0.0)
2815 (test-comparison = double-float 0d0 1d0)
2816 (test-comparison = double-float 1d0 1d0)
2817 (test-comparison = double-float (/ 1d0 0d0) (/ 1d0 0d0))
2818 (test-comparison = double-float (/ 1d0 0d0) 1d0)
2819 (test-comparison = double-float (/ 0d0 0d0) (/ 0d0 0d0))
2820 (test-comparison = double-float (/ 0d0 0d0) 0d0)
2822 (test-comparison < t 1 0)
2823 (test-comparison < t 0 1)
2824 (test-comparison < t 1 1)
2825 (test-comparison < t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2826 (test-comparison < t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum))
2827 (test-comparison < fixnum 1 0)
2828 (test-comparison < fixnum 0 1)
2829 (test-comparison < fixnum 0 0)
2830 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2831 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 1)
2832 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2833 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 0)
2834 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 0 1)
2835 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 1)
2837 (test-comparison < single-float 0.0 1.0)
2838 (test-comparison < single-float 1.0 0.0)
2839 (test-comparison < single-float 1.0 1.0)
2840 (test-comparison < single-float (/ 1.0 0.0) (/ 1.0 0.0))
2841 (test-comparison < single-float (/ 1.0 0.0) 1.0)
2842 (test-comparison < single-float 1.0 (/ 1.0 0.0))
2843 (test-comparison < single-float (/ 0.0 0.0) (/ 0.0 0.0))
2844 (test-comparison < single-float (/ 0.0 0.0) 0.0)
2846 (test-comparison < double-float 0d0 1d0)
2847 (test-comparison < double-float 1d0 0d0)
2848 (test-comparison < double-float 1d0 1d0)
2849 (test-comparison < double-float (/ 1d0 0d0) (/ 1d0 0d0))
2850 (test-comparison < double-float (/ 1d0 0d0) 1d0)
2851 (test-comparison < double-float 1d0 (/ 1d0 0d0))
2852 (test-comparison < double-float (/ 0d0 0d0) (/ 0d0 0d0))
2853 (test-comparison < double-float (/ 0d0 0d0) 0d0)
2854 (test-comparison < double-float 0d0 (/ 0d0 0d0))
2856 (test-comparison > t 1 0)
2857 (test-comparison > t 0 1)
2858 (test-comparison > t 1 1)
2859 (test-comparison > t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2860 (test-comparison > t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum))
2861 (test-comparison > fixnum 1 0)
2862 (test-comparison > fixnum 0 1)
2863 (test-comparison > fixnum 0 0)
2864 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2865 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 1)
2866 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2867 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 0)
2868 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 0 1)
2869 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 1)
2871 (test-comparison > single-float 0.0 1.0)
2872 (test-comparison > single-float 1.0 0.0)
2873 (test-comparison > single-float 1.0 1.0)
2874 (test-comparison > single-float (/ 1.0 0.0) (/ 1.0 0.0))
2875 (test-comparison > single-float (/ 1.0 0.0) 1.0)
2876 (test-comparison > single-float 1.0 (/ 1.0 0.0))
2877 (test-comparison > single-float (/ 0.0 0.0) (/ 0.0 0.0))
2878 (test-comparison > single-float (/ 0.0 0.0) 0.0)
2880 (test-comparison > double-float 0d0 1d0)
2881 (test-comparison > double-float 1d0 0d0)
2882 (test-comparison > double-float 1d0 1d0)
2883 (test-comparison > double-float (/ 1d0 0d0) (/ 1d0 0d0))
2884 (test-comparison > double-float (/ 1d0 0d0) 1d0)
2885 (test-comparison > double-float 1d0 (/ 1d0 0d0))
2886 (test-comparison > double-float (/ 0d0 0d0) (/ 0d0 0d0))
2887 (test-comparison > double-float (/ 0d0 0d0) 0d0)
2888 (test-comparison > double-float 0d0 (/ 0d0 0d0)))))
2890 (with-test (:name :car-and-cdr-type-derivation-conservative)
2891 (let ((f1 (compile nil
2893 (declare (optimize speed))
2894 (let ((x (the (cons fixnum fixnum) (cons 1 2))))
2895 (declare (type (cons t fixnum) x))
2897 (+ (car x) (cdr x))))))
2900 (declare (optimize speed))
2901 (let ((x (the (cons fixnum fixnum) (cons 1 2))))
2903 (+ (car x) (cdr x)))))))
2904 (flet ((test-error (e value)
2905 (assert (typep e 'type-error))
2906 (assert (eq 'number (type-error-expected-type e)))
2907 (assert (eq value (type-error-datum e)))))
2910 (multiple-value-bind (res err) (ignore-errors (funcall f1 v1))
2912 (test-error err v1))
2913 (multiple-value-bind (res err) (ignore-errors (funcall f2 v2))
2915 (test-error err v2))))))
2917 (with-test (:name :array-dimension-derivation-conservative)
2918 (let ((f (compile nil
2920 (declare (optimize speed))
2921 (declare (type (array * (4 4)) x))
2923 (setq x (make-array '(4 4)))
2924 (adjust-array y '(3 5))
2925 (array-dimension y 0))))))
2926 (assert (= 3 (funcall f (make-array '(4 4) :adjustable t))))))
2928 (with-test (:name :with-timeout-code-deletion-note)
2929 (handler-bind ((sb-ext:code-deletion-note #'error))
2930 (compile nil `(lambda ()
2931 (sb-ext:with-timeout 0
2934 (with-test (:name :full-warning-for-undefined-type-in-cl)
2937 (compile nil `(lambda (x) (the replace x)))
2943 (with-test (:name :single-warning-for-single-undefined-type)
2945 (handler-bind ((warning (lambda (c)
2946 (declare (ignore c))
2948 (compile nil `(lambda (x) (the #:no-type x)))
2950 (compile nil `(lambda (x) (the 'fixnum x)))
2953 (with-test (:name :complex-subtype-dumping-in-xc)
2955 (= sb-vm:complex-single-float-widetag
2956 (sb-kernel:widetag-of
2957 (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex single-float))))))
2959 (= sb-vm:complex-double-float-widetag
2960 (sb-kernel:widetag-of
2961 (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex double-float)))))))
2963 (with-test (:name :complex-single-float-fill)
2964 (assert (every (lambda (x) (= #c(1.0 2.0) x))
2968 (make-array (list n)
2969 :element-type '(complex single-float)
2970 :initial-element x)))
2974 (with-test (:name :regression-1.0.28.21)
2975 (let ((fun (compile nil `(lambda (x) (typep x '(simple-array * 1))))))
2976 (assert (funcall fun (vector 1 2 3)))
2977 (assert (funcall fun "abc"))
2978 (assert (not (funcall fun (make-array '(2 2)))))))
2980 (with-test (:name :no-silly-compiler-notes-from-character-function)
2982 (handler-bind ((compiler-note (lambda (e) (error "~S: ~A" current e))))
2983 (dolist (name '(char-code char-int character char-name standard-char-p
2984 graphic-char-p alpha-char-p upper-case-p lower-case-p
2985 both-case-p digit-char-p alphanumericp digit-char-p))
2987 (compile nil `(lambda (x)
2988 (declare (character x) (optimize speed))
2990 (dolist (name '(char= char/= char< char> char<= char>=
2991 char-lessp char-greaterp char-not-greaterp
2994 (compile nil `(lambda (x y)
2995 (declare (character x y) (optimize speed))
2998 ;;; optimizing make-array
2999 (with-test (:name (make-array :open-code-initial-contents))
3000 (assert (not (ctu:find-named-callees
3003 (make-array '(3) :initial-contents (list x y z)))))))
3004 (assert (not (ctu:find-named-callees
3007 (make-array '3 :initial-contents (vector x y z)))))))
3008 (assert (not (ctu:find-named-callees
3011 (make-array '3 :initial-contents `(,x ,y ,z))))))))
3013 ;;; optimizing array-in-bounds-p
3014 (with-test (:name :optimize-array-in-bounds-p)
3016 (macrolet ((find-callees (&body body)
3017 `(ctu:find-named-callees
3021 :name 'array-in-bounds-p))
3022 (must-optimize (&body exprs)
3024 ,@(loop for expr in exprs
3025 collect `(assert (not (find-callees
3027 (must-not-optimize (&body exprs)
3029 ,@(loop for expr in exprs
3030 collect `(assert (find-callees
3034 (let ((a (make-array '(1))))
3035 (array-in-bounds-p a 0))
3036 ;; exceeds upper bound (constant)
3037 (let ((a (make-array '(1))))
3038 (array-in-bounds-p a 1))
3039 ;; exceeds upper bound (interval)
3040 (let ((a (make-array '(1))))
3041 (array-in-bounds-p a (+ 1 (random 2))))
3042 ;; negative lower bound (constant)
3043 (let ((a (make-array '(1))))
3044 (array-in-bounds-p a -1))
3045 ;; negative lower bound (interval)
3046 (let ((a (make-array 3))
3047 (i (- (random 1) 20)))
3048 (array-in-bounds-p a i))
3049 ;; multiple known dimensions
3050 (let ((a (make-array '(1 1))))
3051 (array-in-bounds-p a 0 0))
3053 (let ((s (the (simple-string 10) (eval "0123456789"))))
3054 (array-in-bounds-p s 9)))
3056 ;; don't trust non-simple array length in safety=1
3057 (let ((a (the (array * (10)) (make-array 10 :adjustable t))))
3058 (eval `(adjust-array ,a 0))
3059 (array-in-bounds-p a 9))
3060 ;; same for a union type
3061 (let ((s (the (string 10) (make-array 10
3062 :element-type 'character
3064 (eval `(adjust-array ,s 0))
3065 (array-in-bounds-p s 9))
3066 ;; single unknown dimension
3067 (let ((a (make-array (random 20))))
3068 (array-in-bounds-p a 10))
3069 ;; multiple unknown dimensions
3070 (let ((a (make-array (list (random 20) (random 5)))))
3071 (array-in-bounds-p a 5 2))
3072 ;; some other known dimensions
3073 (let ((a (make-array (list 1 (random 5)))))
3074 (array-in-bounds-p a 0 2))
3075 ;; subscript might be negative
3076 (let ((a (make-array 5)))
3077 (array-in-bounds-p a (- (random 3) 2)))
3078 ;; subscript might be too large
3079 (let ((a (make-array 5)))
3080 (array-in-bounds-p a (random 6)))
3081 ;; unknown upper bound
3082 (let ((a (make-array 5)))
3083 (array-in-bounds-p a (get-universal-time)))
3084 ;; unknown lower bound
3085 (let ((a (make-array 5)))
3086 (array-in-bounds-p a (- (get-universal-time))))
3087 ;; in theory we should be able to optimize
3088 ;; the following but the current implementation
3089 ;; doesn't cut it because the array type's
3090 ;; dimensions get reported as (* *).
3091 (let ((a (make-array (list (random 20) 1))))
3092 (array-in-bounds-p a 5 2))))))
3094 ;;; optimizing (EXPT -1 INTEGER)
3095 (with-test (:name (expt -1 integer))
3096 (dolist (x '(-1 -1.0 -1.0d0))
3097 (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x))))))
3098 (assert (not (ctu:find-named-callees fun)))
3101 (assert (eql x (funcall fun i)))
3102 (assert (eql (- x) (funcall fun i))))))))
3104 (with-test (:name :float-division-using-exact-reciprocal)
3105 (flet ((test (lambda-form arg res &key (check-insts t))
3106 (let* ((fun (compile nil lambda-form))
3107 (disassembly (with-output-to-string (s)
3108 (disassemble fun :stream s))))
3109 ;; Let's make sure there is no division at runtime: for x86 and
3110 ;; x86-64 that implies an FDIV, DIVSS, or DIVSD instruction, so
3111 ;; look for DIV in the disassembly. It's a terrible KLUDGE, but
3115 (assert (not (search "DIV" disassembly))))
3116 ;; No generic arithmetic!
3117 (assert (not (search "GENERIC" disassembly)))
3118 (assert (eql res (funcall fun arg))))))
3119 (dolist (c '(128 64 32 16 8 4 2 1 1/2 1/4 1/8 1/16 1/32 1/64))
3120 (dolist (type '(single-float double-float))
3121 (let* ((cf (coerce c type))
3122 (arg (- (random (* 2 cf)) cf))
3123 (r1 (eval `(/ ,arg ,cf)))
3124 (r2 (eval `(/ ,arg ,(- cf)))))
3125 (test `(lambda (x) (declare (,type x)) (/ x ,cf)) arg r1)
3126 (test `(lambda (x) (declare (,type x)) (/ x ,(- cf))) arg r2)
3127 ;; rational args should get optimized as well
3128 (test `(lambda (x) (declare (,type x)) (/ x ,c)) arg r1)
3129 (test `(lambda (x) (declare (,type x)) (/ x ,(- c))) arg r2))))
3130 ;; Also check that inexact reciprocals (1) are not used by default (2) are
3131 ;; used with FLOAT-ACCURACY=0.
3132 (dolist (type '(single-float double-float))
3133 (let ((trey (coerce 3 type))
3134 (one (coerce 1 type)))
3135 (test `(lambda (x) (declare (,type x)) (/ x 3)) trey one
3139 (optimize (sb-c::float-accuracy 0)))
3141 trey (eval `(* ,trey (/ ,trey))))))))
3143 (with-test (:name :float-multiplication-by-one)
3144 (flet ((test (lambda-form arg &optional (result arg))
3145 (let* ((fun1 (compile nil lambda-form))
3146 (fun2 (funcall (compile nil `(lambda ()
3147 (declare (optimize (sb-c::float-accuracy 0)))
3149 (disassembly1 (with-output-to-string (s)
3150 (disassemble fun1 :stream s)))
3151 (disassembly2 (with-output-to-string (s)
3152 (disassemble fun2 :stream s))))
3153 ;; Multiplication at runtime should be eliminated only with
3154 ;; FLOAT-ACCURACY=0. (To catch SNaNs.)
3156 (assert (and (search "MUL" disassembly1)
3157 (not (search "MUL" disassembly2))))
3158 ;; Not generic arithmetic, please!
3159 (assert (and (not (search "GENERIC" disassembly1))
3160 (not (search "GENERIC" disassembly2))))
3161 (assert (eql result (funcall fun1 arg)))
3162 (assert (eql result (funcall fun2 arg))))))
3163 (dolist (type '(single-float double-float))
3164 (let* ((one (coerce 1 type))
3165 (arg (random (* 2 one)))
3167 (test `(lambda (x) (declare (,type x)) (* x 1)) arg)
3168 (test `(lambda (x) (declare (,type x)) (* x -1)) arg -r)
3169 (test `(lambda (x) (declare (,type x)) (* x ,one)) arg)
3170 (test `(lambda (x) (declare (,type x)) (* x ,(- one))) arg -r)))))
3172 (with-test (:name :float-addition-of-zero)
3173 (flet ((test (lambda-form arg &optional (result arg))
3174 (let* ((fun1 (compile nil lambda-form))
3175 (fun2 (funcall (compile nil `(lambda ()
3176 (declare (optimize (sb-c::float-accuracy 0)))
3178 (disassembly1 (with-output-to-string (s)
3179 (disassemble fun1 :stream s)))
3180 (disassembly2 (with-output-to-string (s)
3181 (disassemble fun2 :stream s))))
3182 ;; Let's make sure there is no addition at runtime: for x86 and
3183 ;; x86-64 that implies an FADD, ADDSS, or ADDSD instruction, so
3184 ;; look for the ADDs in the disassembly. It's a terrible KLUDGE,
3185 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3186 ;; addition in to catch SNaNs.
3188 (assert (and (search "FADD" disassembly1)
3189 (not (search "FADD" disassembly2))))
3191 (let ((inst (if (typep result 'double-float)
3193 (assert (and (search inst disassembly1)
3194 (not (search inst disassembly2)))))
3195 (assert (eql result (funcall fun1 arg)))
3196 (assert (eql result (funcall fun2 arg))))))
3197 (test `(lambda (x) (declare (single-float x)) (+ x 0)) 123.45)
3198 (test `(lambda (x) (declare (single-float x)) (+ x 0.0)) 543.21)
3199 (test `(lambda (x) (declare (single-float x)) (+ x 0.0d0)) 42.00 42.d0)
3200 (test `(lambda (x) (declare (double-float x)) (+ x 0)) 123.45d0)
3201 (test `(lambda (x) (declare (double-float x)) (+ x 0.0)) 543.21d0)
3202 (test `(lambda (x) (declare (double-float x)) (+ x 0.0d0)) 42.d0)))
3204 (with-test (:name :float-substraction-of-zero)
3205 (flet ((test (lambda-form arg &optional (result arg))
3206 (let* ((fun1 (compile nil lambda-form))
3207 (fun2 (funcall (compile nil `(lambda ()
3208 (declare (optimize (sb-c::float-accuracy 0)))
3210 (disassembly1 (with-output-to-string (s)
3211 (disassemble fun1 :stream s)))
3212 (disassembly2 (with-output-to-string (s)
3213 (disassemble fun2 :stream s))))
3214 ;; Let's make sure there is no substraction at runtime: for x86
3215 ;; and x86-64 that implies an FSUB, SUBSS, or SUBSD instruction,
3216 ;; so look for SUB in the disassembly. It's a terrible KLUDGE,
3217 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3218 ;; substraction in in to catch SNaNs.
3220 (assert (and (search "FSUB" disassembly1)
3221 (not (search "FSUB" disassembly2))))
3223 (let ((inst (if (typep result 'double-float)
3225 (assert (and (search inst disassembly1)
3226 (not (search inst disassembly2)))))
3227 (assert (eql result (funcall fun1 arg)))
3228 (assert (eql result (funcall fun2 arg))))))
3229 (test `(lambda (x) (declare (single-float x)) (- x 0)) 123.45)
3230 (test `(lambda (x) (declare (single-float x)) (- x 0.0)) 543.21)
3231 (test `(lambda (x) (declare (single-float x)) (- x 0.0d0)) 42.00 42.d0)
3232 (test `(lambda (x) (declare (double-float x)) (- x 0)) 123.45d0)
3233 (test `(lambda (x) (declare (double-float x)) (- x 0.0)) 543.21d0)
3234 (test `(lambda (x) (declare (double-float x)) (- x 0.0d0)) 42.d0)))
3236 (with-test (:name :float-multiplication-by-two)
3237 (flet ((test (lambda-form arg &optional (result arg))
3238 (let* ((fun1 (compile nil lambda-form))
3239 (fun2 (funcall (compile nil `(lambda ()
3240 (declare (optimize (sb-c::float-accuracy 0)))
3242 (disassembly1 (with-output-to-string (s)
3243 (disassemble fun1 :stream s)))
3244 (disassembly2 (with-output-to-string (s)
3245 (disassemble fun2 :stream s))))
3246 ;; Let's make sure there is no multiplication at runtime: for x86
3247 ;; and x86-64 that implies an FMUL, MULSS, or MULSD instruction,
3248 ;; so look for MUL in the disassembly. It's a terrible KLUDGE,
3251 (assert (and (not (search "MUL" disassembly1))
3252 (not (search "MUL" disassembly2))))
3253 (assert (eql result (funcall fun1 arg)))
3254 (assert (eql result (funcall fun2 arg))))))
3255 (test `(lambda (x) (declare (single-float x)) (* x 2)) 123.45 246.9)
3256 (test `(lambda (x) (declare (single-float x)) (* x 2.0)) 543.21 1086.42)
3257 (test `(lambda (x) (declare (single-float x)) (* x 2.0d0)) 42.00 84.d0)
3258 (test `(lambda (x) (declare (double-float x)) (* x 2)) 123.45d0 246.9d0)
3259 (test `(lambda (x) (declare (double-float x)) (* x 2.0)) 543.21d0 1086.42d0)
3260 (test `(lambda (x) (declare (double-float x)) (* x 2.0d0)) 42.0d0 84.0d0)))
3262 (with-test (:name :bug-392203)
3263 ;; Used to hit an AVER in COMVERT-MV-CALL.
3268 (flet ((k (&rest x) (declare (ignore x)) 0))
3269 (multiple-value-call #'k #'k))))))))
3271 (with-test (:name :allocate-closures-failing-aver)
3272 (let ((f (compile nil `(lambda ()
3273 (labels ((k (&optional x) #'k)))))))
3274 (assert (null (funcall f)))))
3276 (with-test (:name :flush-vector-creation)
3277 (let ((f (compile nil `(lambda ()
3281 (ctu:assert-no-consing (funcall f))))
3283 (with-test (:name :array-type-predicates)
3284 (dolist (et sb-kernel::*specialized-array-element-types*)
3286 (let* ((v (make-array 3 :element-type et))
3287 (fun (compile nil `(lambda ()
3289 (if (typep ,v '(simple-array ,et (*)))
3292 (if (typep (elt ,v 0) '(simple-array ,et (*)))
3295 (assert (equal '(:good :good) (funcall fun)))))))
3297 (with-test (:name :truncate-float)
3298 (let ((s (compile nil `(lambda (x)
3299 (declare (single-float x))
3301 (d (compile nil `(lambda (x)
3302 (declare (double-float x))
3304 (s-inlined (compile nil '(lambda (x)
3305 (declare (type (single-float 0.0s0 1.0s0) x))
3307 (d-inlined (compile nil '(lambda (x)
3308 (declare (type (double-float 0.0d0 1.0d0) x))
3310 ;; Check that there is no generic arithmetic
3311 (assert (not (search "GENERIC"
3312 (with-output-to-string (out)
3313 (disassemble s :stream out)))))
3314 (assert (not (search "GENERIC"
3315 (with-output-to-string (out)
3316 (disassemble d :stream out)))))
3317 ;; Check that we actually inlined the call when we were supposed to.
3318 (assert (not (search "UNARY-TRUNCATE"
3319 (with-output-to-string (out)
3320 (disassemble s-inlined :stream out)))))
3321 (assert (not (search "UNARY-TRUNCATE"
3322 (with-output-to-string (out)
3323 (disassemble d-inlined :stream out)))))))
3325 (with-test (:name :make-array-unnamed-dimension-leaf)
3326 (let ((fun (compile nil `(lambda (stuff)
3327 (make-array (map 'list 'length stuff))))))
3328 (assert (equalp #2A((0 0 0) (0 0 0))
3329 (funcall fun '((1 2) (1 2 3)))))))
3331 (with-test (:name :fp-decoding-funs-not-flushable-in-safe-code)
3332 (dolist (name '(float-sign float-radix float-digits float-precision decode-float
3333 integer-decode-float))
3334 (let ((fun (compile nil `(lambda (x)
3335 (declare (optimize safety))
3343 (error "(~S ~S) did not error"
3349 (when (member name '(decode-float integer-decode-float))
3350 (test sb-ext:single-float-positive-infinity))))))
3352 (with-test (:name :sap-ref-16)
3353 (let* ((fun (compile nil `(lambda (x y)
3354 (declare (type sb-sys:system-area-pointer x)
3355 (type (integer 0 100) y))
3356 (sb-sys:sap-ref-16 x (+ 4 y)))))
3357 (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
3358 '(simple-array (unsigned-byte 8) (*))))
3359 (sap (sb-sys:vector-sap vector))
3360 (ret (funcall fun sap 0)))
3361 ;; test for either endianness
3362 (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))
3364 (with-test (:name :coerce-type-warning)
3365 (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
3366 (signed-byte 8) (signed-byte 16) (signed-byte 32)))
3367 (multiple-value-bind (fun warningsp failurep)
3368 (compile nil `(lambda (x)
3369 (declare (type simple-vector x))
3370 (coerce x '(vector ,type))))
3371 (assert (null warningsp))
3372 (assert (null failurep))
3373 (assert (typep (funcall fun #(1)) `(simple-array ,type (*)))))))
3375 (with-test (:name :truncate-double-float)
3376 (let ((fun (compile nil `(lambda (x)
3377 (multiple-value-bind (q r)
3378 (truncate (coerce x 'double-float))
3379 (declare (type unsigned-byte q)
3380 (type double-float r))
3382 (assert (equal (funcall fun 1.0d0) '(1 0.0d0)))))
3384 (with-test (:name :set-slot-value-no-warning)
3386 (handler-bind ((warning #'error)
3387 (sb-ext:compiler-note (lambda (c)
3388 (declare (ignore c))
3390 (compile nil `(lambda (x y)
3391 (declare (optimize speed safety))
3392 (setf (slot-value x 'bar) y))))
3393 (assert (= 1 notes))))
3395 (with-test (:name :concatenate-string-opt)
3396 (flet ((test (type grep)
3397 (let* ((fun (compile nil `(lambda (a b c d e)
3398 (concatenate ',type a b c d e))))
3399 (args '("foo" #(#\.) "bar" (#\-) "quux"))
3400 (res (apply fun args)))
3401 (assert (search grep (with-output-to-string (out)
3402 (disassemble fun :stream out))))
3403 (assert (equal (apply #'concatenate type args)
3405 (assert (typep res type)))))
3406 (test 'string "%CONCATENATE-TO-STRING")
3407 (test 'simple-string "%CONCATENATE-TO-STRING")
3408 (test 'base-string "%CONCATENATE-TO-BASE-STRING")
3409 (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING")))
3411 (with-test (:name :satisfies-no-local-fun)
3412 (let ((fun (compile nil `(lambda (arg)
3413 (labels ((local-not-global-bug (x)
3416 (typep x '(satisfies local-not-global-bug))))
3418 (assert (eq 'local-not-global-bug
3421 (undefined-function (c)
3422 (cell-error-name c)))))))
3424 ;;; Prior to 1.0.32.x, dumping a fasl with a function with a default
3425 ;;; argument that is a complex structure (needing make-load-form
3426 ;;; processing) failed an AVER. The first attempt at a fix caused
3427 ;;; doing the same in-core to break.
3428 (with-test (:name :bug-310132)
3429 (compile nil '(lambda (&optional (foo #p"foo/bar")))))
3431 (with-test (:name :bug-309129)
3432 (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v))))
3434 (fun (handler-bind ((warning (lambda (c)
3435 (setf warningp t) (muffle-warning c))))
3436 (compile nil src))))
3438 (handler-case (funcall fun #(1))
3440 ;; we used to put simply VECTOR into EXPECTED-TYPE, rather
3441 ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY))
3442 (assert (not (typep (type-error-datum c) (type-error-expected-type c)))))
3443 (:no-error (&rest values)
3444 (declare (ignore values))
3445 (error "no error")))))
3447 (with-test (:name :unary-round-type-derivation)
3448 (let* ((src '(lambda (zone)
3449 (multiple-value-bind (h m) (truncate (abs zone) 1.0)
3450 (declare (ignore h))
3451 (round (* 60.0 m)))))
3452 (fun (compile nil src)))
3453 (assert (= (funcall fun 0.5) 30))))
3455 (with-test (:name :bug-525949)
3456 (let* ((src '(lambda ()
3457 (labels ((always-one () 1)
3459 (let ((n (funcall z)))
3460 (declare (fixnum n))
3461 (the double-float (expt n 1.0d0)))))
3464 (fun (handler-bind ((warning (lambda (c)
3465 (setf warningp t) (muffle-warning c))))
3466 (compile nil src))))
3467 (assert (not warningp))
3468 (assert (= 1.0d0 (funcall fun)))))
3470 (with-test (:name :%array-data-vector-type-derivation)
3471 (let* ((f (compile nil
3473 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3474 (setf (aref ary 0 0) 0))))
3475 (text (with-output-to-string (s)
3476 (disassemble f :stream s))))
3477 (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text)))))
3479 (with-test (:name :array-storage-vector-type-derivation)
3480 (let ((f (compile nil
3482 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3483 (ctu:compiler-derived-type (array-storage-vector ary))))))
3484 (assert (equal '(simple-array (unsigned-byte 32) (9))
3485 (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32)))))))
3487 (with-test (:name :bug-523612)
3490 `(lambda (&key toff)
3491 (make-array 3 :element-type 'double-float
3493 (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0)))))))
3494 (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil)))
3495 (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0)))))
3497 (with-test (:name :bug-309788)
3501 (declare (optimize speed))
3503 (typep x 'fixnum env))))))
3504 (assert (not (ctu:find-named-callees fun)))))
3506 (with-test (:name :bug-309124)
3510 (declare (integer x))
3511 (declare (optimize speed))
3512 (cond ((typep x 'fixnum)
3520 (assert (equal (list "hala" "hip")
3521 (sort (ctu:find-code-constants fun :type 'string)
3524 (with-test (:name :bug-316078)
3528 (declare (type (and simple-bit-vector (satisfies bar)) x)
3531 (assert (not (ctu:find-named-callees fun)))
3532 (assert (= 1 (funcall fun #*000001)))
3533 (assert (= 0 (funcall fun #*000010)))))
3535 (with-test (:name :mult-by-one-in-float-acc-zero)
3536 (assert (eql 1.0 (funcall (compile nil `(lambda (x)
3537 (declare (optimize (sb-c::float-accuracy 0)))
3540 (assert (eql -1.0 (funcall (compile nil `(lambda (x)
3541 (declare (optimize (sb-c::float-accuracy 0)))
3544 (assert (eql 1.0d0 (funcall (compile nil `(lambda (x)
3545 (declare (optimize (sb-c::float-accuracy 0)))
3548 (assert (eql -1.0d0 (funcall (compile nil `(lambda (x)
3549 (declare (optimize (sb-c::float-accuracy 0)))
3553 (with-test (:name :dotimes-non-integer-counter-value)
3554 (assert (raises-error? (dotimes (i 8.6)) type-error)))
3556 (with-test (:name :bug-454681)
3557 ;; This used to break due to reference to a dead lambda-var during
3558 ;; inline expansion.
3559 (assert (compile nil
3561 (multiple-value-bind (iterator+977 getter+978)
3562 (does-not-exist-but-does-not-matter)
3563 (flet ((iterator+976 ()
3564 (funcall iterator+977)))
3565 (declare (inline iterator+976))
3566 (let ((iterator+976 #'iterator+976))
3567 (funcall iterator+976))))))))
3569 (with-test (:name :complex-float-local-fun-args)
3570 ;; As of 1.0.27.14, the lambda below failed to compile due to the
3571 ;; compiler attempting to pass unboxed complex floats to Z and the
3572 ;; MOVE-ARG method not expecting the register being used as a
3573 ;; temporary frame pointer. Reported by sykopomp in #lispgames,
3574 ;; reduced test case provided by _3b`.
3575 (compile nil '(lambda (a)
3577 (declare ((complex double-float) b c))
3579 (loop for i below 10 do
3580 (setf a (z a a)))))))
3582 (with-test (:name :bug-309130)
3583 (assert (eq :warning
3585 (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1)))
3586 ((and warning (not style-warning)) ()
3588 (assert (eq :warning
3590 (compile nil `(lambda (x)
3591 (declare (optimize (debug 0)))
3592 (declare (type vector x))
3593 (list (fill-pointer x) (svref x 1))))
3594 ((and warning (not style-warning)) ()
3596 (assert (eq :warning
3598 (compile nil `(lambda (x)
3599 (list (vector-push (svref x 0) x))))
3600 ((and warning (not style-warning)) ()
3602 (assert (eq :warning
3604 (compile nil `(lambda (x)
3605 (list (vector-push-extend (svref x 0) x))))
3606 ((and warning (not style-warning)) ()
3609 (with-test (:name :bug-646796)
3614 (load-time-value (the (values fixnum) 42)))))))
3616 (with-test (:name :bug-654289)
3617 ;; Test that compile-times don't explode when quoted constants
3619 (labels ((time-n (n)
3620 (gc :full t) ; Let's not confuse the issue with GC
3621 (let* ((tree (make-tree (expt 10 n) nil))
3622 (t0 (get-internal-run-time))
3623 (f (compile nil `(lambda (x) (eq x (quote ,tree)))))
3624 (t1 (get-internal-run-time)))
3625 (assert (funcall f tree))
3628 (cond ((zerop n) acc)
3629 (t (make-tree (1- n) (cons acc acc))))))
3630 (let* ((times (loop for i from 0 upto 4
3631 collect (time-n i)))
3632 (max-small (reduce #'max times :end 3))
3633 (max-big (reduce #'max times :start 3)))
3634 ;; This way is hopefully fairly CPU-performance insensitive.
3635 (unless (> (+ (truncate internal-time-units-per-second 10)
3638 (error "Bad scaling or test? ~S" times)))))
3640 (with-test (:name :bug-309063)
3641 (let ((fun (compile nil `(lambda (x)
3642 (declare (type (integer 0 0) x))
3644 (assert (zerop (funcall fun 0)))))
3646 (with-test (:name :bug-655872)
3647 (let ((f (compile nil `(lambda (x)
3648 (declare (optimize (safety 3)))
3649 (aref (locally (declare (optimize (safety 0)))
3650 (coerce x '(simple-vector 128)))
3652 (long (make-array 100 :element-type 'fixnum)))
3654 (setf (aref long i) i))
3655 ;; 1. COERCE doesn't check the length in unsafe code.
3656 (assert (eql 60 (funcall f long)))
3657 ;; 2. The compiler doesn't trust the length from COERCE
3660 (funcall f (list 1 2 3))
3661 (sb-int:invalid-array-index-error (e)
3662 (assert (eql 60 (type-error-datum e)))
3663 (assert (equal '(integer 0 (3)) (type-error-expected-type e)))
3666 (with-test (:name :bug-655203-regression)
3667 (let ((fun (compile nil
3671 (&OPTIONAL DUMMY &REST OTHER)
3672 (DECLARE (IGNORE OTHER))
3675 (FUNCALL CONTINUATION (LIST 1 2)))))))
3676 ;; This used to signal a bogus type-error.
3677 (assert (equal (with-output-to-string (*standard-output*)
3681 (with-test (:name :constant-concatenate-compile-time)
3682 (flet ((make-lambda (n)
3684 (declare (optimize (speed 3) (space 0)))
3685 (concatenate 'string x ,(make-string n)))))
3686 (let* ((l0 (make-lambda 1))
3687 (l1 (make-lambda 10))
3688 (l2 (make-lambda 100))
3689 (l3 (make-lambda 1000))
3690 (t0 (get-internal-run-time))
3691 (f0 (compile nil l0))
3692 (t1 (get-internal-run-time))
3693 (f1 (compile nil l1))
3694 (t2 (get-internal-run-time))
3695 (f2 (compile nil l2))
3696 (t3 (get-internal-run-time))
3697 (f3 (compile nil l3))
3698 (t4 (get-internal-run-time))
3703 (short-avg (/ (+ d0 d1 d2) 3)))
3704 (assert (and f1 f2 f3))
3705 (assert (< d3 (* 10 short-avg))))))
3707 (with-test (:name :bug-384892)
3709 '(function (fixnum fixnum &key (:k1 (member nil t)))
3710 (values (member t) &optional))
3711 (sb-kernel:%simple-fun-type
3712 (compile nil `(lambda (x y &key k1)
3713 (declare (fixnum x y))
3714 (declare (boolean k1))
3715 (declare (ignore x y k1))
3718 (with-test (:name :bug-309448)
3719 ;; Like all tests trying to verify that something doesn't blow up
3720 ;; compile-times this is bound to be a bit brittle, but at least
3721 ;; here we try to establish a decent baseline.
3722 (labels ((time-it (lambda want &optional times)
3723 (gc :full t) ; let's keep GCs coming from other code out...
3724 (let* ((start (get-internal-run-time))
3728 for result = (compile nil lambda)
3729 finally (return result))
3730 (loop for result = (compile nil lambda)
3731 do (incf iterations)
3732 until (> (get-internal-run-time) (+ start 10))
3733 finally (return result))))
3734 (end (get-internal-run-time))
3735 (got (funcall fun)))
3736 (unless (eql want got)
3737 (error "wanted ~S, got ~S" want got))
3738 (values (- end start) iterations)))
3739 (test-it (simple result1 complex result2)
3740 (multiple-value-bind (time-simple iterations)
3741 (time-it simple result1)
3742 (assert (>= (* 10 (1+ time-simple))
3743 (time-it complex result2 iterations))))))
3744 ;; This is mostly identical as the next one, but doesn't create
3745 ;; hairy unions of numeric types.
3746 (test-it `(lambda ()
3747 (labels ((bar (baz bim)
3748 (let ((n (+ baz bim)))
3749 (* n (+ n 1) bim))))
3756 (labels ((bar (baz bim)
3757 (let ((n (+ baz bim)))
3758 (* n (+ n 1) bim))))
3764 (test-it `(lambda ()
3766 (let ((m (truncate 999 n)))
3767 (/ (* n m (1+ m)) 2))))
3774 (let ((m (truncate 999 n)))
3775 (/ (* n m (1+ m)) 2))))
3781 (with-test (:name :regression-1.0.44.34)
3782 (compile nil '(lambda (z &rest args)
3783 (declare (dynamic-extent args))
3784 (flet ((foo (w v) (list v w)))
3788 (declare (sb-int:truly-dynamic-extent #'foo))
3789 (call #'foo nil))))))
3791 (with-test (:name :bug-713626)
3792 (let ((f (eval '(constantly 42))))
3793 (handler-bind ((warning #'error))
3794 (assert (= 42 (funcall (compile nil `(lambda () (funcall ,f 1 2 3)))))))))
3796 (with-test (:name :known-fun-allows-other-keys)
3797 (handler-bind ((warning #'error))
3798 (funcall (compile nil '(lambda () (directory "." :allow-other-keys t))))
3799 (funcall (compile nil `(lambda () (directory "." :bar t :allow-other-keys t))))))
3801 (with-test (:name :bug-551227)
3802 ;; This function causes constraint analysis to perform a
3803 ;; ref-substitution that alters the A referred to in (G A) at in the
3804 ;; consequent of the IF to refer to be NUMBER, from the
3805 ;; LET-converted inline-expansion of MOD. This leads to attempting
3806 ;; to CLOSE-OVER a variable that simply isn't in scope when it is
3808 (compile nil '(lambda (a)
3818 (with-test (:name :funcall-lambda-inlined)
3820 (ctu:find-code-constants
3823 (+ x (funcall (lambda (z) z) y))))
3826 (with-test (:name :bug-720382)
3829 (handler-bind (((and warning (not style-warning))
3830 (lambda (c) (incf w))))
3831 (compile nil `(lambda (b) ((lambda () b) 1))))))
3834 (handler-case (funcall f 0)
3835 (error () :error)))))))
3837 (with-test (:name :multiple-args-to-function)
3838 (let ((form `(flet ((foo (&optional (x 13)) x))
3839 (funcall (function foo 42))))
3840 #+sb-eval (*evaluator-mode* :interpret))
3843 (handler-case (eval form)
3844 (error () :error))))
3845 (multiple-value-bind (fun warn fail)
3846 (compile nil `(lambda () ,form))
3847 (assert (and warn fail))
3849 (handler-case (funcall fun)
3850 (error () :error)))))))
3852 ;;; This doesn't test LVAR-FUN-IS directly, but captures it
3853 ;;; pretty accurately anyways.
3854 (with-test (:name :lvar-fun-is)
3856 (lambda (x) (member x x :test #'eq))
3857 (lambda (x) (member x x :test 'eq))
3858 (lambda (x) (member x x :test #.#'eq))))
3859 (assert (equal (list #'sb-kernel:%member-eq)
3860 (ctu:find-named-callees fun))))
3863 (declare (notinline eq))
3864 (member x x :test #'eq))
3866 (declare (notinline eq))
3867 (member x x :test 'eq))
3869 (declare (notinline eq))
3870 (member x x :test #.#'eq))))
3871 (assert (member #'sb-kernel:%member-test
3872 (ctu:find-named-callees fun)))))
3874 (with-test (:name :delete-to-delq-opt)
3875 (dolist (fun (list (lambda (x y)
3877 (delete x y :test #'eq))
3879 (declare (fixnum x) (list y))
3882 (declare (symbol x) (list y))
3883 (delete x y :test #'eql))))
3884 (assert (equal (list #'sb-int:delq)
3885 (ctu:find-named-callees fun)))))
3887 (with-test (:name :bug-767959)
3888 ;; This used to signal an error.
3889 (compile nil `(lambda ()
3890 (declare (optimize sb-c:store-coverage-data))
3893 '((:ordinary . ordinary-lambda-list))))))
3895 (with-test (:name :member-on-long-constant-list)
3896 ;; This used to blow stack with a sufficiently long list.
3897 (let ((cycle (list t)))
3899 (compile nil `(lambda (x)
3900 (member x ',cycle)))))
3902 (with-test (:name :bug-722734)
3903 (assert (raises-error?
3908 (list unbound-variable-1 unbound-variable-2))))))))
3910 (with-test (:name :bug-771673)
3911 (assert (equal `(the foo bar) (macroexpand `(truly-the foo bar))))
3912 ;; Make sure the compiler doesn't use THE, and check that setf-expansions
3914 (let ((f (compile nil `(lambda (x y)
3915 (setf (truly-the fixnum (car x)) y)))))
3916 (let* ((cell (cons t t)))
3917 (funcall f cell :ok)
3918 (assert (equal '(:ok . t) cell)))))
3920 (with-test (:name (:bug-793771 +))
3921 (let ((f (compile nil `(lambda (x y)
3922 (declare (type (single-float 2.0) x)
3923 (type (single-float (0.0)) y))
3925 (assert (equal `(function ((single-float 2.0) (single-float (0.0)))
3926 (values (single-float 2.0) &optional))
3927 (sb-kernel:%simple-fun-type f)))))
3929 (with-test (:name (:bug-793771 -))
3930 (let ((f (compile nil `(lambda (x y)
3931 (declare (type (single-float * 2.0) x)
3932 (type (single-float (0.0)) y))
3934 (assert (equal `(function ((single-float * 2.0) (single-float (0.0)))
3935 (values (single-float * 2.0) &optional))
3936 (sb-kernel:%simple-fun-type f)))))
3938 (with-test (:name (:bug-793771 *))
3939 (let ((f (compile nil `(lambda (x)
3940 (declare (type (single-float (0.0)) x))
3942 (assert (equal `(function ((single-float (0.0)))
3943 (values (or (member 0.0) (single-float (0.0))) &optional))
3944 (sb-kernel:%simple-fun-type f)))))
3946 (with-test (:name (:bug-793771 /))
3947 (let ((f (compile nil `(lambda (x)
3948 (declare (type (single-float (0.0)) x))
3950 (assert (equal `(function ((single-float (0.0)))
3951 (values (or (member 0.0) (single-float (0.0))) &optional))
3952 (sb-kernel:%simple-fun-type f)))))
3954 (with-test (:name (:bug-486812 single-float))
3955 (compile nil `(lambda ()
3956 (sb-kernel:make-single-float -1))))
3958 (with-test (:name (:bug-486812 double-float))
3959 (compile nil `(lambda ()
3960 (sb-kernel:make-double-float -1 0))))
3962 (with-test (:name :bug-729765)
3963 (compile nil `(lambda (a b)
3964 (declare ((integer 1 1) a)
3967 (lambda () (< b a)))))
3969 ;; Actually tests the assembly of RIP-relative operands to comparison
3970 ;; functions (one of the few x86 instructions that have extra bytes
3971 ;; *after* the mem operand's effective address, resulting in a wrong
3973 (with-test (:name :cmpps)
3974 (let ((foo (compile nil `(lambda (x)
3975 (= #C(2.0 3.0) (the (complex single-float) x))))))
3976 (assert (funcall foo #C(2.0 3.0)))
3977 (assert (not (funcall foo #C(1.0 2.0))))))
3979 (with-test (:name :cmppd)
3980 (let ((foo (compile nil `(lambda (x)
3981 (= #C(2d0 3d0) (the (complex double-float) x))))))
3982 (assert (funcall foo #C(2d0 3d0)))
3983 (assert (not (funcall foo #C(1d0 2d0))))))
3985 (with-test (:name :lvar-externally-checkable-type-nil)
3986 ;; Used to signal a BUG during compilation.
3987 (let ((fun (compile nil `(lambda (a) (parse-integer "12321321" (the (member :start) a) 1)))))
3988 (multiple-value-bind (i p) (funcall fun :start)
3989 (assert (= 2321321 i))
3991 (multiple-value-bind (i e) (ignore-errors (funcall fun :end))
3993 (assert (typep e 'type-error)))))
3995 (with-test (:name :simple-type-error-in-bound-propagation-a)
3996 (compile nil `(lambda (i)
3997 (declare (unsigned-byte i))
3998 (expt 10 (expt 7 (- 2 i))))))
4000 (with-test (:name :simple-type-error-in-bound-propagation-b)
4001 (assert (equal `(FUNCTION (UNSIGNED-BYTE)
4002 (VALUES (SINGLE-FLOAT -1F0 1F0) &OPTIONAL))
4003 (sb-kernel:%simple-fun-type
4004 (compile nil `(lambda (i)
4005 (declare (unsigned-byte i))
4006 (cos (expt 10 (+ 4096 i)))))))))
4008 (with-test (:name :fixed-%more-arg-values)
4009 (let ((fun (compile nil `(lambda (&rest rest)
4010 (declare (optimize (safety 0)))
4011 (apply #'cons rest)))))
4012 (assert (equal '(car . cdr) (funcall fun 'car 'cdr)))))
4014 (with-test (:name :bug-826970)
4015 (let ((fun (compile nil `(lambda (a b c)
4016 (declare (type (member -2 1) b))
4017 (array-in-bounds-p a 4 b c)))))
4018 (assert (funcall fun (make-array '(5 2 2)) 1 1))))
4020 (with-test (:name :bug-826971)
4022 (fun (compile nil `(lambda (p1 p2)
4023 (schar (the (eql ,foo) p1) p2)))))
4024 (assert (eql #\f (funcall fun foo 0)))))
4026 (with-test (:name :bug-738464)
4027 (multiple-value-bind (fun warn fail)
4028 (compile nil `(lambda ()
4030 (declare (ftype non-function-type foo))
4032 (assert (eql 42 (funcall fun)))
4033 (assert (and warn (not fail)))))
4035 (with-test (:name :bug-832005)
4036 (let ((fun (compile nil `(lambda (x)
4037 (declare (type (complex single-float) x))
4038 (+ #C(0.0 1.0) x)))))
4039 (assert (= (funcall fun #C(1.0 2.0))
4042 ;; A refactoring 1.0.12.18 caused lossy computation of primitive
4043 ;; types for member types.
4044 (with-test (:name :member-type-primitive-type)
4045 (let ((fun (compile nil `(lambda (p1 p2 p3)
4047 (the (member #c(1.2d0 1d0)) p2)
4048 (the (eql #c(1.0 1.0)) p3))))))
4049 (assert (eql (funcall fun 1 #c(1.2d0 1d0) #c(1.0 1.0))
4052 ;; Fall-through jump elimination made control flow fall through to trampolines.
4053 ;; Reported by Eric Marsden on sbcl-devel@ 2011.10.26, with a test case
4054 ;; reproduced below (triggered a corruption warning and a memory fault).
4055 (with-test (:name :bug-883500)
4056 (funcall (compile nil `(lambda (a)
4057 (declare (type (integer -50 50) a))
4058 (declare (optimize (speed 0)))
4059 (mod (mod a (min -5 a)) 5)))
4062 ;; Test for literals too large for the ISA (e.g. (SIGNED-BYTE 13) on SPARC).
4064 (with-test (:name :bug-883519)
4065 (compile nil `(lambda (x)
4066 (declare (type character x))
4067 (eql x #\U0010FFFF))))
4069 ;; Wide fixnum platforms had buggy address computation in atomic-incf/aref
4070 (with-test (:name :bug-887220)
4071 (let ((incfer (compile
4073 `(lambda (vector index)
4074 (declare (type (simple-array sb-ext:word (4))
4076 (type (mod 4) index))
4077 (sb-ext:atomic-incf (aref vector index) 1)
4079 (assert (equalp (funcall incfer
4080 (make-array 4 :element-type 'sb-ext:word
4085 (with-test (:name :catch-interferes-with-debug-names)
4091 (throw 'out (lambda () t))))
4093 (assert (equal '(lambda () :in foo) (sb-kernel:%fun-name fun)))))
4095 (with-test (:name :interval-div-signed-zero)
4096 (let ((fun (compile nil
4098 (declare (type (member 0 -272413371076) a))
4099 (ffloor (the number a) -63243.127451934015d0)))))
4100 (multiple-value-bind (q r) (funcall fun 0)
4101 (assert (eql -0d0 q))
4102 (assert (eql 0d0 r)))))
4104 (with-test (:name :non-constant-keyword-typecheck)
4105 (let ((fun (compile nil
4107 (declare (type keyword p3))
4108 (tree-equal p1 (cons 1 2) (the (member :test) p3) p4)))))
4109 (assert (funcall fun (cons 1.0 2.0) :test '=))))
4111 (with-test (:name :truncate-wild-values)
4112 (multiple-value-bind (q r)
4113 (handler-bind ((warning #'error))
4114 (let ((sb-c::*check-consistency* t))
4115 (funcall (compile nil
4117 (declare (type (member 1d0 2d0) a))
4118 (block return-value-tag
4121 (catch 'debug-catch-tag
4122 (return-from return-value-tag
4123 (progn (truncate a)))))))))
4126 (assert (eql 0d0 r))))
4128 (with-test (:name :boxed-fp-constant-for-full-call)
4129 (let ((fun (compile nil
4131 (declare (double-float x))
4132 (unknown-fun 1.0d0 (+ 1.0d0 x))))))
4133 (assert (equal '(1.0d0) (ctu:find-code-constants fun :type 'double-float)))))
4135 (with-test (:name :only-one-boxed-constant-for-multiple-uses)
4136 (let* ((big (1+ most-positive-fixnum))
4139 (unknown-fun ,big (+ ,big x))))))
4140 (assert (= 1 (length (ctu:find-code-constants fun :type `(eql ,big)))))))
4142 (with-test (:name :fixnum+float-coerces-fixnum
4144 (let ((fun (compile nil
4149 (assert (not (ctu:find-named-callees fun)))
4150 (assert (not (search "GENERIC"
4151 (with-output-to-string (s)
4152 (disassemble fun :stream s)))))))
4154 (with-test (:name :bug-803508)
4155 (compile nil `(lambda ()
4158 (declare (dynamic-extent bar))
4161 (with-test (:name :bug-803508-b)
4162 (compile nil `(lambda ()
4165 (declare (dynamic-extent bar))
4168 (with-test (:name :bug-803508-c)
4169 (compile nil `(lambda ()
4171 (lambda (bar &optional quux)
4172 (declare (dynamic-extent bar quux))
4175 (with-test (:name :cprop-with-constant-but-assigned-to-closure-variable)
4176 (compile nil `(lambda (b c d)
4177 (declare (type (integer -20545789 207590862) c))
4178 (declare (type (integer -1 -1) d))
4179 (let ((i (unwind-protect 32 (shiftf d -1))))
4180 (or (if (= d c) 2 (= 3 b)) 4)))))
4182 (with-test (:name :bug-913232)
4183 (compile nil `(lambda (x)
4184 (declare (optimize speed)
4185 (type (or (and (or (integer -100 -50)
4186 (integer 100 200)) (satisfies foo))
4187 (and (or (integer 0 10) (integer 20 30)) a)) x))
4189 (compile nil `(lambda (x)
4190 (declare (optimize speed)
4191 (type (and fixnum a) x))
4194 (with-test (:name :bug-959687)
4195 (multiple-value-bind (fun warn fail)
4196 (compile nil `(lambda (x)
4202 (assert (and warn fail))
4203 (assert (not (ignore-errors (funcall fun t)))))
4204 (multiple-value-bind (fun warn fail)
4205 (compile nil `(lambda (x)
4211 (assert (and warn fail))
4212 (assert (not (ignore-errors (funcall fun t))))))
4214 (with-test (:name :bug-924276)
4215 (assert (eq :style-warning
4217 (compile nil `(lambda (a)
4218 (cons a (symbol-macrolet ((b 1))
4219 (declare (ignorable a))
4224 (with-test (:name :bug-974406)
4225 (let ((fun32 (compile nil `(lambda (x)
4226 (declare (optimize speed (safety 0)))
4227 (declare (type (integer 53 86) x))
4228 (logand (+ x 1032791128) 11007078467))))
4229 (fun64 (compile nil `(lambda (x)
4230 (declare (optimize speed (safety 0)))
4231 (declare (type (integer 53 86) x))
4232 (logand (+ x 1152921504606846975)
4233 38046409652025950207)))))
4234 (assert (= (funcall fun32 61) 268574721))
4235 (assert (= (funcall fun64 61) 60)))
4237 (do ((width 5 (1+ width)))
4240 (let ((fun (compile nil `(lambda (x)
4241 (declare (optimize speed (safety 0)))
4242 (declare (type (integer 1 16) x))
4244 (+ x ,(1- (ash 1 width)))
4245 ,(logior (ash 1 (+ width 1 extra))
4246 (1- (ash 1 width))))))))
4247 (unless (= (funcall fun 16) (logand 15 (1- (ash 1 width))))
4248 (push (cons width extra) result)))))
4249 (assert (null result))))
4251 ;; On x86-64 MOVE-IMMEDIATE of fixnum values into memory either directly
4252 ;; uses a MOV into memory or goes through a temporary register if the
4253 ;; value is larger than a certain number of bits. Check that it respects
4254 ;; the limits of immediate arguments to the MOV instruction (if not, the
4255 ;; assembler will fail an assertion) and doesn't have sign-extension
4256 ;; problems. (The test passes fixnum constants through the MOVE VOP
4257 ;; which calls MOVE-IMMEDIATE.)
4258 (with-test (:name :constant-fixnum-move)
4259 (let ((f (compile nil `(lambda (g)
4261 ;; The first three args are
4262 ;; uninteresting as they are
4263 ;; passed in registers.
4265 ,@(loop for i from 27 to 32
4266 collect (expt 2 i)))))))
4267 (assert (every #'plusp (funcall f #'list)))))
4269 (with-test (:name (:malformed-ignore :lp-1000239))
4271 (eval '(lambda () (declare (ignore (function . a)))))
4272 sb-int:compiled-program-error)
4274 (eval '(lambda () (declare (ignore (function a b)))))
4275 sb-int:compiled-program-error)
4277 (eval '(lambda () (declare (ignore (function)))))
4278 sb-int:compiled-program-error)
4280 (eval '(lambda () (declare (ignore (a)))))
4281 sb-int:compiled-program-error)
4283 (eval '(lambda () (declare (ignorable (a b)))))
4284 sb-int:compiled-program-error))
4286 (with-test (:name :malformed-type-declaraions)
4287 (compile nil '(lambda (a) (declare (type (integer 1 2 . 3) a)))))
4289 (with-test (:name :compiled-program-error-escaped-source)
4292 (funcall (compile nil `(lambda () (lambda ("foo")))))
4293 (sb-int:compiled-program-error (e)
4294 (let ((source (read-from-string (sb-kernel::program-error-source e))))
4295 (equal source '#'(lambda ("foo"))))))))
4297 (with-test (:name :escape-analysis-for-nlxs)
4298 (flet ((test (check lambda &rest args)
4299 (let* ((cell-note nil)
4300 (fun (handler-bind ((compiler-note
4303 "Allocating a value-cell at runtime for"
4304 (princ-to-string note))
4305 (setf cell-note t)))))
4306 (compile nil lambda))))
4307 (assert (eql check cell-note))
4312 (dolist (arg args nil)
4313 (setf fun (funcall fun arg)))
4314 (sb-int:simple-control-error (e)
4316 (simple-condition-format-control e)
4317 "attempt to RETURN-FROM a block or GO to a tag that no longer exists")
4319 (ctu:assert-no-consing (apply fun args))))))
4320 (test nil `(lambda (x)
4321 (declare (optimize speed))
4323 (flet ((ex () (return-from out 'out!)))
4325 (cons (or (car x) (ex)))
4327 (test t `(lambda (x)
4328 (declare (optimize speed))
4331 (flet ((oops () (return-from nasty t)))
4333 (test t `(lambda (r)
4334 (declare (optimize speed))
4336 (flet ((ex () (return-from out r)))
4339 (cons (or (car x) (ex)))
4341 (test t `(lambda (x)
4342 (declare (optimize speed))
4344 (flet ((meh () (return-from eh 'meh)))
4347 (cons (or (car x) (meh)))
4349 (funcall (eh x)))) t t)))
4351 (with-test (:name (:bug-1050768 :symptom))
4352 ;; Used to signal an error.
4354 `(lambda (string position)
4355 (char string position)
4356 (array-in-bounds-p string (1+ position)))))
4358 (with-test (:name (:bug-1050768 :cause))
4359 (let ((types `((string string)
4360 ((or (simple-array character 24) (vector t 24))
4361 (or (simple-array character 24) (vector t))))))
4362 (dolist (pair types)
4363 (destructuring-bind (orig conservative) pair
4364 (assert sb-c::(type= (specifier-type cl-user::conservative)
4365 (conservative-type (specifier-type cl-user::orig))))))))
4367 (with-test (:name (:smodular64 :wrong-width))
4368 (let ((fun (compile nil
4370 (declare (type (signed-byte 64) x))
4371 (sb-c::mask-signed-field 64 (- x 7033717698976965573))))))
4372 (assert (= (funcall fun 10038) -7033717698976955535))))
4374 (with-test (:name (:smodular32 :wrong-width))
4375 (let ((fun (compile nil '(lambda (x)
4376 (declare (type (signed-byte 31) x))
4377 (sb-c::mask-signed-field 31 (- x 1055131947))))))
4378 (assert (= (funcall fun 10038) -1055121909))))
4380 (with-test (:name :first-open-coded)
4381 (let ((fun (compile nil `(lambda (x) (first x)))))
4382 (assert (not (ctu:find-named-callees fun)))))
4384 (with-test (:name :second-open-coded)
4385 (let ((fun (compile nil `(lambda (x) (second x)))))
4386 (assert (not (ctu:find-named-callees fun)))))
4388 (with-test (:name :svref-of-symbol-macro)
4389 (compile nil `(lambda (x)
4390 (symbol-macrolet ((sv x))
4391 (values (svref sv 0) (setf (svref sv 0) 99))))))
4393 ;; The compiler used to update the receiving LVAR's type too
4394 ;; aggressively when converting a large constant to a smaller
4395 ;; (potentially signed) one, causing other branches to be
4396 ;; inferred as dead.
4397 (with-test (:name :modular-cut-constant-to-width)
4398 (let ((test (compile nil
4403 ((2 2 0 -2 -1 2) 9223372036854775803)
4405 (assert (= (funcall test -10470605025) 26))))
4407 (with-test (:name :append-type-derivation)
4409 '((lambda () (append 10)) (integer 10 10)
4410 (lambda () (append nil 10)) (integer 10 10)
4411 (lambda (x) (append x 10)) (or (integer 10 10) cons)
4412 (lambda (x) (append x (cons 1 2))) cons
4413 (lambda (x y) (append x (cons 1 2) y)) cons
4414 (lambda (x y) (nconc x (the list y) x)) t
4415 (lambda (x y) (nconc (the atom x) y)) t
4416 (lambda (x y) (nconc (the (or null (eql 10)) x) y)) t
4417 (lambda (x y) (nconc (the (or cons vector) x) y)) cons
4418 (lambda (x y) (nconc (the sequence x) y)) t
4419 (lambda (x y) (print (length y)) (append x y)) sequence
4420 (lambda (x y) (print (length y)) (append x y)) sequence
4421 (lambda (x y) (append (the (member (a) (b)) x) y)) cons
4422 (lambda (x y) (append (the (member (a) (b) c) x) y)) cons
4423 (lambda (x y) (append (the (member (a) (b) nil) x) y)) t)))
4424 (loop for (function result-type) on test-cases by #'cddr
4425 do (assert (sb-kernel:type= (sb-kernel:specifier-type
4426 (car (cdaddr (sb-kernel:%simple-fun-type
4427 (compile nil function)))))
4428 (sb-kernel:specifier-type result-type))))))
4430 (with-test (:name :bug-504121)
4431 (compile nil `(lambda (s)
4432 (let ((p1 #'upper-case-p))
4436 (let ((p2 #'(lambda (char) (upper-case-p char))))
4439 (with-test (:name (:bug-504121 :optional-missing))
4440 (compile nil `(lambda (s)
4441 (let ((p1 #'upper-case-p))
4443 (lambda (g &optional x)
4445 (let ((p2 #'(lambda (char) (upper-case-p char))))
4448 (with-test (:name (:bug-504121 :optional-superfluous))
4449 (compile nil `(lambda (s)
4450 (let ((p1 #'upper-case-p))
4452 (lambda (g &optional x)
4455 (let ((p2 #'(lambda (char) (upper-case-p char))))
4458 (with-test (:name (:bug-504121 :key-odd))
4459 (compile nil `(lambda (s)
4460 (let ((p1 #'upper-case-p))
4465 (let ((p2 #'(lambda (char) (upper-case-p char))))
4468 (with-test (:name (:bug-504121 :key-unknown))
4469 (compile nil `(lambda (s)
4470 (let ((p1 #'upper-case-p))
4475 (let ((p2 #'(lambda (char) (upper-case-p char))))
4478 (with-test (:name :bug-1181684)
4479 (compile nil `(lambda ()
4480 (let ((hash #xD13CCD13))
4481 (setf hash (logand most-positive-word
4484 (with-test (:name (:local-&optional-recursive-inline :bug-1180992))
4487 (labels ((called (&optional a))
4488 (recursed (&optional b)
4491 (declare (inline recursed called))
4494 (with-test (:name :constant-fold-logtest)
4495 (assert (equal (sb-kernel:%simple-fun-type
4496 (compile nil `(lambda (x)
4497 (declare (type (mod 1024) x)
4500 '(function ((unsigned-byte 10)) (values null &optional)))))
4502 ;; type mismatches on LVARs with multiple potential sources used to
4503 ;; be reported as mismatches with the value NIL. Make sure we get
4504 ;; a warning, but that it doesn't complain about a constant NIL ...
4506 (with-test (:name (:multiple-use-lvar-interpreted-as-NIL :cast))
4508 (handler-bind ((sb-int:type-warning
4511 (not (search "Constant "
4512 (simple-condition-format-control
4515 (compile nil `(lambda (x y z)
4516 (declare (type fixnum y z))
4517 (aref (if x y z) 0))))
4518 (error "Where's my warning?")))
4520 (with-test (:name (:multiple-use-lvar-interpreted-as-NIL catch))
4522 (handler-bind ((style-warning
4527 (simple-condition-format-arguments c))))
4529 (compile nil `(lambda (x y z f)
4530 (declare (type fixnum y z))
4531 (catch (if x y z) (funcall f)))))
4532 (error "Where's my style-warning?")))
4534 ;; Smoke test for rightward shifts
4535 (with-test (:name (:ash/right-signed))
4536 (let* ((f (compile nil `(lambda (x y)
4537 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4538 (type sb-vm:signed-word x)
4541 (max (ash most-positive-word -1))
4544 (assert (= (ash x (- y))
4547 (dotimes (y (* 2 sb-vm:n-word-bits))
4551 (test (+ min x) y))))))
4553 (with-test (:name (:ash/right-unsigned))
4554 (let ((f (compile nil `(lambda (x y)
4555 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4559 (max most-positive-word))
4561 (assert (= (ash x (- y))
4564 (dotimes (y (* 2 sb-vm:n-word-bits))
4566 (test (- max x) y))))))
4568 (with-test (:name (:ash/right-fixnum))
4569 (let ((f (compile nil `(lambda (x y)
4570 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4575 (assert (= (ash x (- y))
4578 (dotimes (y (* 2 sb-vm:n-word-bits))
4581 (test (- most-positive-fixnum x) y)
4582 (test (+ most-negative-fixnum x) y))))))
4585 (with-test (:name :fold-index-addressing-positive-offset)
4586 (let ((f (compile nil `(lambda (i)
4587 (if (typep i '(integer -31 31))
4588 (aref #. (make-array 63) (+ i 31))
4592 ;; 5d3a728 broke something like this in CL-PPCRE
4593 (with-test (:name :fold-index-addressing-potentially-negative-index)
4594 (compile nil `(lambda (index vector)
4595 (declare (optimize speed (safety 0))
4596 ((simple-array character (*)) vector)
4597 ((unsigned-byte 24) index))
4598 (aref vector (1+ (mod index (1- (length vector))))))))
4600 (with-test (:name :constant-fold-ash/right-fixnum)
4601 (compile nil `(lambda (a b)
4602 (declare (type fixnum a)
4603 (type (integer * -84) b))
4606 (with-test (:name :constant-fold-ash/right-word)
4607 (compile nil `(lambda (a b)
4608 (declare (type word a)
4609 (type (integer * -84) b))
4612 (with-test (:name :nconc-derive-type)
4613 (let ((function (compile nil `(lambda (x y)
4614 (declare (type (or cons fixnum) x))
4616 (assert (equal (sb-kernel:%simple-fun-type function)
4617 '(function ((or cons fixnum) t) (values cons &optional))))))
4619 ;; make sure that all data-vector-ref-with-offset VOPs are either
4620 ;; specialised on a 0 offset or accept signed indices
4621 (with-test (:name :data-vector-ref-with-offset-signed-index)
4622 (let ((dvr (find-symbol "DATA-VECTOR-REF-WITH-OFFSET" "SB-KERNEL")))
4626 (loop for info in (sb-c::fun-info-templates
4627 (sb-c::fun-info-or-lose dvr))
4628 for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
4629 unless (or (typep second-arg '(cons (eql :constant)))
4630 (find '(integer 0 0) third-arg :test 'equal)
4632 `(:or ,(sb-c::primitive-type-or-lose
4633 'sb-vm::positive-fixnum)
4634 ,(sb-c::primitive-type-or-lose
4638 (with-test (:name :data-vector-set-with-offset-signed-index)
4639 (let ((dvr (find-symbol "DATA-VECTOR-SET-WITH-OFFSET" "SB-KERNEL")))
4643 (loop for info in (sb-c::fun-info-templates
4644 (sb-c::fun-info-or-lose dvr))
4645 for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
4646 unless (or (typep second-arg '(cons (eql :constant)))
4647 (find '(integer 0 0) third-arg :test 'equal)
4649 `(:or ,(sb-c::primitive-type-or-lose
4650 'sb-vm::positive-fixnum)
4651 ,(sb-c::primitive-type-or-lose
4655 (with-test (:name :maybe-inline-ref-to-dead-lambda)
4656 (compile nil `(lambda (string)
4657 (declare (optimize speed (space 0)))
4658 (cond ((every #'digit-char-p string)
4664 ;; the x87 backend used to sometimes signal FP errors during boxing,
4665 ;; because converting between double and single float values was a
4666 ;; noop (fixed), and no doubt many remaining issues. We now store
4667 ;; the value outside pseudo-atomic, so any SIGFPE should be handled
4670 ;; When it fails, this test lands into ldb.
4671 (with-test (:name :no-overflow-during-allocation)
4672 (handler-case (eval '(cosh 90))
4673 (floating-point-overflow ()
4676 ;; unbounded integer types could break integer arithmetic.
4677 (with-test (:name :bug-1199127)
4678 (compile nil `(lambda (b)
4679 (declare (type (integer -1225923945345 -832450738898) b))
4680 (declare (optimize (speed 3) (space 3) (safety 2)
4681 (debug 0) (compilation-speed 1)))
4682 (loop for lv1 below 3
4685 (ash b (min 25 lv1))
4689 ;; non-trivial modular arithmetic operations would evaluate to wider results
4690 ;; than expected, and never be cut to the right final bitwidth.
4691 (with-test (:name :bug-1199428-1)
4692 (let ((f1 (compile nil `(lambda (a c)
4693 (declare (type (integer -2 1217810089) a))
4694 (declare (type (integer -6895591104928 -561736648588) c))
4695 (declare (optimize (speed 2) (space 0) (safety 2) (debug 0)
4696 (compilation-speed 3)))
4699 (loop for lv2 below 1 count t))))))
4700 (f2 (compile nil `(lambda (a c)
4701 (declare (notinline - + gcd logandc1))
4702 (declare (optimize (speed 1) (space 1) (safety 0) (debug 1)
4703 (compilation-speed 3)))
4706 (loop for lv2 below 1 count t)))))))
4709 (assert (eql (funcall f1 a c)
4710 (funcall f2 a c))))))
4712 (with-test (:name :bug-1199428-2)
4713 (let ((f1 (compile nil `(lambda (a b)
4714 (declare (type (integer -1869232508 -6939151) a))
4715 (declare (type (integer -11466348357 -2645644006) b))
4716 (declare (optimize (speed 1) (space 0) (safety 2) (debug 2)
4717 (compilation-speed 2)))
4718 (logand (lognand a -6) (* b -502823994)))))
4719 (f2 (compile nil `(lambda (a b)
4720 (logand (lognand a -6) (* b -502823994))))))
4721 (let ((a -1491588365)
4723 (assert (eql (funcall f1 a b)
4724 (funcall f2 a b))))))
4726 ;; win32 is very specific about the order in which catch blocks
4727 ;; must be allocated on the stack
4728 (with-test (:name :bug-1072739)
4729 (let ((f (compile nil
4733 (WITH-OUTPUT-TO-STRING (G13908)
4736 (DECLARE (OPTIMIZE (SB-EXT:INHIBIT-WARNINGS 3)))
4738 (WITH-OUTPUT-TO-STRING (G13909) (PRINC %A%B% G13909) G13909)
4739 (UNBOUND-VARIABLE NIL
4741 (WITH-OUTPUT-TO-STRING (G13914)
4742 (PRINC %A%B% G13914)
4745 (UNBOUND-VARIABLE NIL
4747 (WITH-OUTPUT-TO-STRING (G13913)
4751 (UNBOUND-VARIABLE NIL
4753 (WITH-OUTPUT-TO-STRING (G13912)
4757 (UNBOUND-VARIABLE NIL
4759 (WITH-OUTPUT-TO-STRING (G13911)
4761 (PRINC "%b%" G13911)
4763 (UNBOUND-VARIABLE NIL
4765 (WITH-OUTPUT-TO-STRING (G13910)
4767 (PRINC "a%b%" G13910)
4769 (UNBOUND-VARIABLE NIL
4770 (ERROR "Interpolation error in \"%a%b%\"
4774 (assert (funcall f))))
4776 (with-test (:name :equal-equalp-transforms)
4778 (bit-vector #*11001100)
4779 (values `(nil 1 2 "test"
4780 ;; Floats duplicated here to ensure we get newly created instances
4781 (read-from-string "1.1") (read-from-string "1.2d0")
4782 (read-from-string "1.1") (read-from-string "1.2d0")
4783 1.1 1.2d0 '("foo" "bar" "test")
4784 #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file"
4785 ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)
4786 ,(make-hash-table) #\a #\b #\A #\C
4787 ,(make-random-state) 1/2 2/3)))
4788 ;; Test all permutations of different types
4795 (and (eq (funcall (compile nil `(lambda (x y)
4796 (equal (the ,(type-of x) x)
4797 (the ,(type-of y) y))))
4800 (eq (funcall (compile nil `(lambda (x y)
4801 (equalp (the ,(type-of x) x)
4802 (the ,(type-of y) y))))
4809 (equal (the (cons (or simple-bit-vector simple-base-string))
4811 (the (cons (or (and bit-vector (not simple-array))
4812 (simple-array character (*))))
4814 (list (string 'list))
4820 (equalp (the (cons (or simple-bit-vector simple-base-string))
4822 (the (cons (or (and bit-vector (not simple-array))
4823 (simple-array character (*))))
4825 (list (string 'list))
4828 (with-test (:name (restart-case optimize speed compiler-note))
4829 (handler-bind ((compiler-note #'error))
4830 (compile nil '(lambda ()
4831 (declare (optimize speed))
4832 (restart-case () (c ()))))
4833 (compile nil '(lambda ()
4834 (declare (optimize speed))
4836 (restart-case (setf x (car (compute-restarts)))
4840 (with-test (:name :copy-more-arg
4841 :fails-on '(not (or :x86 :x86-64)))
4842 ;; copy-more-arg might not copy in the right direction
4843 ;; when there are more fixed args than stack frame slots,
4844 ;; and thus end up splatting a single argument everywhere.
4845 ;; Fixed on x86oids only, but other platforms still start
4846 ;; their stack frames at 8 slots, so this is less likely
4850 (loop for i below n collect i))
4851 (test-function (function skip)
4852 ;; function should just be (subseq x skip)
4853 (loop for i from skip below (+ skip limit) do
4854 (let* ((values (iota i))
4855 (f (apply function values))
4856 (subseq (subseq values skip)))
4857 (assert (equal f subseq)))))
4859 (let ((gensyms (loop for i below n collect (gensym))))
4860 (compile nil `(lambda (,@gensyms &rest rest)
4861 (declare (ignore ,@gensyms))
4864 (test-function (make-function i) i)))))
4866 (with-test (:name :apply-aref)
4869 (handler-bind ((warning (lambda (c) (setf warning c))))
4870 (compile nil `(lambda (x y) (setf (apply #'sbit x y) 10))))
4871 (assert (not warning)))))
4872 (test `(lambda (x y) (setf (apply #'aref x y) 21)))
4873 (test `(lambda (x y) (setf (apply #'bit x y) 1)))
4874 (test `(lambda (x y) (setf (apply #'sbit x y) 0)))))
4876 (with-test (:name :warn-on-the-values-constant)
4877 (multiple-value-bind (fun warnings-p failure-p)
4879 ;; The compiler used to elide this test without
4880 ;; noting that the type demands multiple values.
4881 '(lambda () (the (values fixnum fixnum) 1)))
4882 (declare (ignore warnings-p))
4883 (assert (functionp fun))
4884 (assert failure-p)))
4886 ;; quantifiers shouldn't cons themselves.
4887 (with-test (:name :quantifiers-no-consing)
4888 (let ((constantly-t (lambda (x) x t))
4889 (constantly-nil (lambda (x) x nil))
4890 (list (make-list 1000 :initial-element nil))
4891 (vector (make-array 1000 :initial-element nil)))
4892 (macrolet ((test (quantifier)
4893 (let ((function (make-symbol (format nil "TEST-~A" quantifier))))
4894 `(flet ((,function (function sequence)
4895 (,quantifier function sequence)))
4896 (ctu:assert-no-consing (,function constantly-t list))
4897 (ctu:assert-no-consing (,function constantly-nil vector))))))
4903 (with-test (:name :propagate-complex-type-tests)
4904 (flet ((test (type value)
4905 (let ((ftype (sb-kernel:%simple-fun-type
4906 (compile nil `(lambda (x)
4907 (if (typep x ',type)
4910 (assert (typep ftype `(cons (eql function))))
4911 (assert (= 3 (length ftype)))
4912 (let* ((return (third ftype))
4913 (rtype (second return)))
4914 (assert (typep return `(cons (eql values)
4916 (cons (eql &optional)
4918 (assert (and (subtypep rtype type)
4919 (subtypep type rtype)))))))
4920 (mapc (lambda (params)
4921 (apply #'test params))
4922 `(((unsigned-byte 17) 0)
4923 ((member 1 3 5 7) 5)
4924 ((or symbol (eql 42)) t)))))
4926 (with-test (:name :constant-fold-complex-type-tests)
4927 (assert (equal (sb-kernel:%simple-fun-type
4928 (compile nil `(lambda (x)
4929 (if (typep x '(member 1 3))
4930 (typep x '(member 1 3 15))
4932 `(function (t) (values (member t) &optional))))
4933 (assert (equal (sb-kernel:%simple-fun-type
4934 (compile nil `(lambda (x)
4935 (declare (type (member 1 3) x))
4936 (typep x '(member 1 3 15)))))
4937 `(function ((or (integer 1 1) (integer 3 3)))
4938 (values (member t) &optional)))))
4940 (with-test (:name :quietly-row-major-index-no-dimensions)
4941 (assert (handler-case
4942 (compile nil `(lambda (x) (array-row-major-index x)))
4945 (with-test (:name :array-rank-transform)
4946 (compile nil `(lambda (a) (array-rank (the an-imaginary-type a)))))
4948 (with-test (:name (:array-rank-fold :bug-1252108))
4950 (handler-bind ((sb-ext::code-deletion-note
4957 (when (= (array-rank a) 3)
4958 (array-dimension a 2)))))))