1 ;;;; various compiler tests without side effects
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (cl:in-package
:cl-user
)
16 ;; The tests in this file assume that EVAL will use the compiler
17 (when (eq sb-ext
:*evaluator-mode
* :interpret
)
18 (invoke-restart 'run-tests
::skip-file
))
20 ;;; Exercise a compiler bug (by crashing the compiler).
22 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
23 ;;; (2000-09-06 on cmucl-imp).
25 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
26 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
46 ;;; Exercise a compiler bug (by crashing the compiler).
48 ;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on
49 ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL.
53 (block used-by-some-y?
57 (return-from used-by-some-y? t
)))))
58 (declare (inline frob
))
64 ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally
65 ;;; from Bruno Haible in CMU CL bugs collection), fixed by
66 ;;; Alexey Dejneka 2002-01-27
67 (assert (= 1 ; (used to give 0 under bug 112)
72 (declare (special x
)) y
)))))
73 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
78 (declare (special x
)) y
)))))
80 ;;; another LET-related bug fixed by Alexey Dejneka at the same
82 (multiple-value-bind (fun warnings-p failure-p
)
83 ;; should complain about duplicate variable names in LET binding
89 (declare (ignore warnings-p
))
90 (assert (functionp fun
))
93 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
94 ;;; Lichteblau 2002-05-21)
96 (multiple-value-bind (fun warnings-p failure-p
)
98 ;; Compiling this code should cause a STYLE-WARNING
99 ;; about *X* looking like a special variable but not
103 (funcall (symbol-function 'x-getter
))
105 (assert (functionp fun
))
107 (assert (not failure-p
)))
108 (multiple-value-bind (fun warnings-p failure-p
)
110 ;; Compiling this code should not cause a warning
111 ;; (because the DECLARE turns *X* into a special
112 ;; variable as its name suggests it should be).
115 (declare (special *x
*))
116 (funcall (symbol-function 'x-getter
))
118 (assert (functionp fun
))
119 (assert (not warnings-p
))
120 (assert (not failure-p
))))
122 ;;; a bug in 0.7.4.11
123 (dolist (i '(a b
1 2 "x" "y"))
124 ;; In sbcl-0.7.4.11, the compiler tried to source-transform the
125 ;; TYPEP here but got confused and died, doing
126 ;; (ASSOC '(AND INTEGERP (SATISFIES PLUSP)))
127 ;; *BACKEND-TYPE-PREDICATES*
129 ;; and blowing up because TYPE= tried to call PLUSP on the
130 ;; characters of the MEMBER-TYPE representing STANDARD-CHAR.
131 (when (typep i
'(and integer
(satisfies oddp
)))
134 (when (typep i
'(and integer
(satisfies oddp
)))
137 ;;; bug 156 (reported by APD sbcl-devel 2002-04-12, fixed by CSR patch
138 ;;; sbcl-devel 2002-07-02): FUNCTION-LAMBDA-EXPRESSION of
139 ;;; interactively-compiled functions was broken by sleaziness and
140 ;;; confusion in the assault on 0.7.0, so this expression used to
141 ;;; signal TYPE-ERROR when it found NIL instead of a DEBUG-SOURCE.
142 (eval '(function-lambda-expression #'(lambda (x) x
)))
144 ;;; bug caught and fixed by Raymond Toy cmucl-imp 2002-07-10: &REST
145 ;;; variable is not optional.
146 (assert (null (ignore-errors (eval '(funcall (lambda (&rest
) 12))))))
148 ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
149 ;;; a while; fixed by CSR 2002-07-18
150 (multiple-value-bind (value error
)
151 (ignore-errors (some-undefined-function))
152 (assert (null value
))
153 (assert (eq (cell-error-name error
) 'some-undefined-function
)))
155 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
156 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
157 (assert (null (ignore-errors (eval '(lambda ("foo") 12)))))
158 (assert (ignore-errors (eval '(lambda (foo) 12))))
159 (assert (null (ignore-errors (eval '(lambda (&optional
12) "foo")))))
160 (assert (ignore-errors (eval '(lambda (&optional twelve
) "foo"))))
161 (assert (null (ignore-errors (eval '(lambda (&optional
(12 12)) "foo")))))
162 (assert (ignore-errors (eval '(lambda (&optional
(twelve 12)) "foo"))))
163 (assert (null (ignore-errors (eval '(lambda (&key
#\c
) "foo")))))
164 (assert (ignore-errors (eval '(lambda (&key c
) "foo"))))
165 (assert (null (ignore-errors (eval '(lambda (&key
(#\c
#\c
)) "foo")))))
166 (assert (ignore-errors (eval '(lambda (&key
(c #\c
)) "foo"))))
167 (assert (null (ignore-errors (eval '(lambda (&key
((#\c
#\c
) #\c
)) "foo")))))
168 (assert (ignore-errors (eval '(lambda (&key
((:c cbyanyothername
) #\c
)) "foo"))))
170 ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel
171 ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER
172 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
173 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y
3)) x
))) 14)
176 ;;; bug 181: bad type specifier dropped compiler into debugger
177 (assert (list (compile nil
'(lambda (x)
178 (declare (type (0) x
))
181 (let ((f (compile nil
'(lambda (x)
182 (make-array 1 :element-type
'(0))))))
183 (assert (null (ignore-errors (funcall f
)))))
185 ;;; the following functions must not be flushable
186 (dolist (form '((make-sequence 'fixnum
10)
187 (concatenate 'fixnum nil
)
188 (map 'fixnum
#'identity nil
)
189 (merge 'fixnum nil nil
#'<)))
190 (assert (not (eval `(locally (declare (optimize (safety 0)))
191 (ignore-errors (progn ,form t
)))))))
193 (dolist (form '((values-list (car (list '(1 .
2))))
195 (atan #c
(1 1) (car (list #c
(2 2))))
196 (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5))
197 (nthcdr (car (list 5)) '(1 2 .
3))))
198 (assert (not (eval `(locally (declare (optimize (safety 3)))
199 (ignore-errors (progn ,form t
)))))))
201 ;;; feature: we shall complain if functions which are only useful for
202 ;;; their result are called and their result ignored.
203 (loop for
(form expected-des
) in
204 '(((progn (nreverse (list 1 2)) t
)
205 "The return value of NREVERSE should not be discarded.")
206 ((progn (nreconc (list 1 2) (list 3 4)) t
)
207 "The return value of NRECONC should not be discarded.")
209 (declare (inline sort
))
210 (sort (list 1 2) #'<) t
)
211 ;; FIXME: it would be nice if this warned on non-inlined sort
212 ;; but the current simple boolean function attribute
213 ;; can't express the condition that would be required.
214 "The return value of STABLE-SORT-LIST should not be discarded.")
215 ((progn (sort (vector 1 2) #'<) t
)
216 ;; Apparently, SBCL (but not CL) guarantees in-place vector
217 ;; sort, so no warning.
219 ((progn (delete 2 (list 1 2)) t
)
220 "The return value of DELETE should not be discarded.")
221 ((progn (delete-if #'evenp
(list 1 2)) t
)
222 ("The return value of DELETE-IF should not be discarded."))
223 ((progn (delete-if #'evenp
(vector 1 2)) t
)
224 ("The return value of DELETE-IF should not be discarded."))
225 ((progn (delete-if-not #'evenp
(list 1 2)) t
)
226 "The return value of DELETE-IF-NOT should not be discarded.")
227 ((progn (delete-duplicates (list 1 2)) t
)
228 "The return value of DELETE-DUPLICATES should not be discarded.")
229 ((progn (merge 'list
(list 1 3) (list 2 4) #'<) t
)
230 "The return value of MERGE should not be discarded.")
231 ((progn (nreconc (list 1 3) (list 2 4)) t
)
232 "The return value of NRECONC should not be discarded.")
233 ((progn (nunion (list 1 3) (list 2 4)) t
)
234 "The return value of NUNION should not be discarded.")
235 ((progn (nintersection (list 1 3) (list 2 4)) t
)
236 "The return value of NINTERSECTION should not be discarded.")
237 ((progn (nset-difference (list 1 3) (list 2 4)) t
)
238 "The return value of NSET-DIFFERENCE should not be discarded.")
239 ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t
)
240 "The return value of NSET-EXCLUSIVE-OR should not be discarded."))
241 for expected
= (if (listp expected-des
)
245 (multiple-value-bind (fun warnings-p failure-p
)
246 (handler-bind ((style-warning (lambda (c)
248 (let ((expect-one (pop expected
)))
249 (assert (search expect-one
250 (with-standard-io-syntax
251 (let ((*print-right-margin
* nil
))
252 (princ-to-string c
))))
254 "~S should have warned ~S, but instead warned: ~A"
256 (error "~S shouldn't give a(nother) warning, but did: ~A" form c
)))))
257 (compile nil
`(lambda () ,form
)))
258 (declare (ignore warnings-p
))
259 (assert (functionp fun
))
260 (assert (null expected
)
262 "~S should have warned ~S, but didn't."
264 (assert (not failure-p
))))
266 ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers
267 ;;; to cause errors in the compiler. Fixed by CSR in 0.7.8.10
268 (assert (list (compile nil
'(lambda (x) (map 'simple-array
'identity x
)))))
270 ;;; bug 129: insufficient syntax checking in MACROLET
271 (multiple-value-bind (result error
)
272 (ignore-errors (eval '(macrolet ((foo x
`',x
)) (foo 1 2 3))))
273 (assert (null result
))
274 (assert (typep error
'error
)))
276 ;;; bug 124: environment of MACROLET-introduced macro expanders
278 (macrolet ((mext (x) `(cons :mext
,x
)))
279 (macrolet ((mint (y) `'(:mint
,(mext y
))))
282 '((:MEXT
1 2) (:MINT
(:MEXT
1 2)))))
284 ;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced
285 ;;; symbol is declared to be SPECIAL
286 (multiple-value-bind (result error
)
287 (ignore-errors (funcall (lambda ()
288 (symbol-macrolet ((s '(1 2)))
289 (declare (special s
))
291 (assert (null result
))
292 (assert (typep error
'program-error
)))
294 ;;; ECASE should treat a bare T as a literal key
295 (multiple-value-bind (result error
)
296 (ignore-errors (ecase 1 (t 0)))
297 (assert (null result
))
298 (assert (typep error
'type-error
)))
300 (multiple-value-bind (result error
)
301 (ignore-errors (ecase 1 (t 0) (1 2)))
302 (assert (eql result
2))
303 (assert (null error
)))
305 ;;; FTYPE should accept any functional type specifier
306 (compile nil
'(lambda (x) (declare (ftype function f
)) (f x
)))
308 ;;; FUNCALL of special operators and macros should signal an
309 ;;; UNDEFINED-FUNCTION error
310 (multiple-value-bind (result error
)
311 (ignore-errors (funcall 'quote
1))
312 (assert (null result
))
313 (assert (typep error
'undefined-function
))
314 (assert (eq (cell-error-name error
) 'quote
)))
315 (multiple-value-bind (result error
)
316 (ignore-errors (funcall 'and
1))
317 (assert (null result
))
318 (assert (typep error
'undefined-function
))
319 (assert (eq (cell-error-name error
) 'and
)))
321 ;;; PSETQ should behave when given complex symbol-macro arguments
322 (multiple-value-bind (sequence index
)
323 (symbol-macrolet ((x (aref a
(incf i
)))
324 (y (aref a
(incf i
))))
325 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
327 (psetq x
(aref a
(incf i
))
330 (assert (equalp sequence
#(0 2 2 4 4 5 6 7 8 9)))
331 (assert (= index
4)))
333 (multiple-value-bind (result error
)
335 (let ((x (list 1 2)))
338 (assert (null result
))
339 (assert (typep error
'program-error
)))
341 ;;; COPY-SEQ should work on known-complex vectors:
343 (let ((v (make-array 0 :fill-pointer
0)))
344 (vector-push-extend 1 v
)
347 ;;; to support INLINE functions inside MACROLET, it is necessary for
348 ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in
349 ;;; certain circumstances, one of which is when compile is called from
352 (function-lambda-expression
353 (compile nil
'(lambda (x) (block nil
(print x
)))))
354 '(lambda (x) (block nil
(print x
)))))
356 ;;; bug 62: too cautious type inference in a loop
361 (declare (optimize speed
(safety 0)))
363 (array (loop (print (car a
)))))))))
365 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
368 '(lambda (key tree collect-path-p
)
369 (let ((lessp (key-lessp tree
))
370 (equalp (key-equalp tree
)))
371 (declare (type (function (t t
) boolean
) lessp equalp
))
373 (loop for node
= (root-node tree
)
374 then
(if (funcall lessp key
(node-key node
))
378 do
(return (values nil nil nil
))
379 do
(when collect-path-p
381 (when (funcall equalp key
(node-key node
))
382 (return (values node path t
))))))))
384 ;;; CONSTANTLY should return a side-effect-free function (bug caught
385 ;;; by Paul Dietz' test suite)
387 (let ((fn (constantly (progn (incf i
) 1))))
389 (assert (= (funcall fn
) 1))
391 (assert (= (funcall fn
) 1))
394 ;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version)
395 (loop for
(fun warns-p
) in
396 '(((lambda (&optional
*x
*) *x
*) t
)
397 ((lambda (&optional
*x
* &rest y
) (values *x
* y
)) t
)
398 ((lambda (&optional
*print-length
*) (values *print-length
*)) nil
)
399 ((lambda (&optional
*print-length
* &rest y
) (values *print-length
* y
)) nil
)
400 ((lambda (&optional
*x
*) (declare (special *x
*)) (values *x
*)) nil
)
401 ((lambda (&optional
*x
* &rest y
) (declare (special *x
*)) (values *x
* y
)) nil
))
402 for real-warns-p
= (nth-value 1 (compile nil fun
))
403 do
(assert (eq warns-p real-warns-p
)))
405 ;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26
406 (assert (equal (funcall (eval '(lambda (x &optional
(y (pop x
))) (list x y
)))
410 ;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd
411 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
412 (assert (eq (eval '((lambda (&key
) 'u
) :allow-other-keys nil
)) 'u
))
415 (raises-error?
(multiple-value-bind (a b c
)
416 (eval '(truncate 3 4))
417 (declare (integer c
))
421 (assert (equal (multiple-value-list (the (values &rest integer
)
425 ;;; Bug relating to confused representation for the wild function
427 (assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
429 ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz'
431 (assert (eql (macrolet ((foo () 1))
432 (macrolet ((%f
(&optional
(x (macroexpand '(foo) env
)) &environment env
)
437 ;;; MACROLET should check for duplicated names
438 (dolist (ll '((x (z x
))
439 (x y
&optional z x w
)
443 (x &optional
(y nil x
))
444 (x &optional
(y nil y
))
447 (&key
(y nil z
) (z nil w
))
448 (&whole x
&optional x
)
449 (&environment x
&whole x
)))
454 (macrolet ((foo ,ll nil
)
455 (bar (&environment env
)
456 `',(macro-function 'foo env
)))
459 (values nil t t
))))))
461 (assert (typep (eval `(the arithmetic-error
462 ',(make-condition 'arithmetic-error
)))
465 (assert (not (nth-value
466 2 (compile nil
'(lambda ()
467 (make-array nil
:initial-element
11))))))
469 (assert (raises-error?
(funcall (eval #'open
) "assertoid.lisp"
470 :external-format
'#:nonsense
)))
471 (assert (raises-error?
(funcall (eval #'load
) "assertoid.lisp"
472 :external-format
'#:nonsense
)))
474 (assert (= (the (values integer symbol
) (values 1 'foo
13)) 1))
476 (let ((f (compile nil
478 (declare (optimize (safety 3)))
479 (list (the fixnum
(the (real 0) (eval v
))))))))
480 (assert (raises-error?
(funcall f
0.1) type-error
))
481 (assert (raises-error?
(funcall f -
1) type-error
)))
483 ;;; the implicit block does not enclose lambda list
484 (let ((forms '((defmacro #1=#:foo
(&optional
(x (return-from #1#))))
485 #+nil
(macrolet ((#2=#:foo
(&optional
(x (return-from #2#))))))
486 (define-compiler-macro #3=#:foo
(&optional
(x (return-from #3#))))
487 (deftype #4=#:foo
(&optional
(x (return-from #4#))))
488 (define-setf-expander #5=#:foo
(&optional
(x (return-from #5#))))
489 (defsetf #6=#:foo
(&optional
(x (return-from #6#))) ()))))
491 (assert (nth-value 2 (compile nil
`(lambda () ,form
))))))
493 (assert (nth-value 2 (compile nil
495 (svref (make-array '(8 9) :adjustable t
) 1)))))
497 ;;; CHAR= did not check types of its arguments (reported by Adam Warner)
498 (raises-error?
(funcall (compile nil
'(lambda (x y z
) (char= x y z
)))
501 (raises-error?
(funcall (compile nil
503 (declare (optimize (speed 3) (safety 3)))
508 ;;; Compiler lost return type of MAPCAR and friends
509 (dolist (fun '(mapcar mapc maplist mapl
))
510 (assert (nth-value 2 (compile nil
512 (1+ (,fun
#'print x
)))))))
514 (assert (nth-value 2 (compile nil
516 (declare (notinline mapcar
))
517 (1+ (mapcar #'print
'(1 2 3)))))))
519 ;;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant
520 ;;; index was effectless
521 (let ((f (compile nil
'(lambda (a v
)
522 (declare (type simple-bit-vector a
) (type bit v
))
523 (declare (optimize (speed 3) (safety 0)))
526 (let ((y (make-array 2 :element-type
'bit
:initial-element
0)))
527 (assert (equal y
#*00))
529 (assert (equal y
#*10))))
531 ;;; use of declared array types
532 (handler-bind ((sb-ext:compiler-note
#'error
))
533 (compile nil
'(lambda (x)
534 (declare (type (simple-array (simple-string 3) (5)) x
)
536 (aref (aref x
0) 0))))
538 (handler-bind ((sb-ext:compiler-note
#'error
))
539 (compile nil
'(lambda (x)
540 (declare (type (simple-array (simple-array bit
(10)) (10)) x
)
542 (1+ (aref (aref x
0) 0)))))
545 (let ((f (compile nil
'(lambda (x) (typep x
'(not (member 0d0
)))))))
546 (assert (funcall f
1d0
)))
548 (compile nil
'(lambda (x)
549 (declare (double-float x
))
553 ;;; bogus optimization of BIT-NOT
554 (multiple-value-bind (result x
)
555 (eval '(let ((x (eval #*1001)))
556 (declare (optimize (speed 2) (space 3))
557 (type (bit-vector) x
))
558 (values (bit-not x nil
) x
)))
559 (assert (equal x
#*1001))
560 (assert (equal result
#*0110)))
562 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
563 (handler-bind ((sb-ext:compiler-note
#'error
))
564 (assert (equalp (funcall
568 (let ((x (make-sequence 'vector
10 :initial-element
'a
)))
571 #(a a a a b a a a a a
))))
573 ;;; this is not a check for a bug, but rather a test of compiler
575 (dolist (type '((integer 0 *) ; upper bound
578 (real * (-10)) ; lower bound
583 (declare (optimize (speed 3) (compilation-speed 0)))
584 (loop for i from
1 to
(the (integer -
17 10) n
) by
2
585 collect
(when (> (random 10) 5)
586 (the ,type
(- i
11)))))))))
590 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
591 ;;; compiler has an optimized VOP for +; so this code should cause an
593 (assert (eq (block nil
595 (compile nil
'(lambda (i)
596 (declare (optimize speed
))
597 (declare (type integer i
))
599 (sb-ext:compiler-note
(c) (return :good
))))
602 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
604 (assert (not (nth-value 1 (compile nil
'(lambda (u v
)
605 (symbol-macrolet ((x u
)
611 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
612 (loop for
(x type
) in
615 (-14/3 (rational -
8 11))
624 (#c
(-3 4) (complex fixnum
))
625 (#c
(-3 4) (complex rational
))
626 (#c
(-3/7 4) (complex rational
))
627 (#c
(2s0 3s0
) (complex short-float
))
628 (#c
(2f0 3f0
) (complex single-float
))
629 (#c
(2d0 3d0
) (complex double-float
))
630 (#c
(2l0 3l0) (complex long-float
))
631 (#c
(2d0 3s0
) (complex float
))
632 (#c
(2 3f0
) (complex real
))
633 (#c
(2 3d0
) (complex real
))
634 (#c
(-3/7 4) (complex real
))
637 do
(dolist (zero '(0 0s0
0f0
0d0
0l0))
638 (dolist (real-zero (list zero
(- zero
)))
639 (let* ((src `(lambda (x) (expt (the ,type x
) ,real-zero
)))
640 (fun (compile nil src
))
641 (result (1+ (funcall (eval #'*) x real-zero
))))
642 (assert (eql result
(funcall fun x
)))))))
644 ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
645 ;;; wasn't recognized as a good type specifier.
646 (let ((fun (lambda (x y
)
647 (declare (type (integer -
1 0) x y
) (optimize speed
))
649 (assert (= (funcall fun
0 0) 0))
650 (assert (= (funcall fun
0 -
1) -
1))
651 (assert (= (funcall fun -
1 -
1) 0)))
653 ;;; from PFD's torture test, triggering a bug in our effective address
658 (declare (type (integer 8 22337) b
))
661 (* (logandc1 (max -
29303 b
) 4) b
)
662 (abs (logorc1 (+ (logandc1 -
11 b
) 2607688420) -
31153924)))
663 (logeqv (max a
0) b
))))
665 ;;; Alpha floating point modes weren't being reset after an exception,
666 ;;; leading to an exception on the second compile, below.
667 (compile nil
'(lambda (x y
) (declare (type (double-float 0.0d0
) x y
)) (/ x y
)))
668 (handler-case (/ 1.0 0.0)
669 ;; provoke an exception
670 (arithmetic-error ()))
671 (compile nil
'(lambda (x y
) (declare (type (double-float 0.0d0
) x y
)) (/ x y
)))
673 ;;; bug reported by Paul Dietz: component last block does not have
677 (declare (notinline + logand
)
678 (optimize (speed 0)))
682 (RETURN-FROM B5 -
220)))
684 (+ 359749 35728422))))
687 ;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
688 (assert (= (funcall (compile nil
`(lambda (b)
689 (declare (optimize (speed 3))
690 (type (integer 2 152044363) b
))
691 (rem b
(min -
16 0))))
695 (assert (= (funcall (compile nil
`(lambda (c)
696 (declare (optimize (speed 3))
697 (type (integer 23062188 149459656) c
))
702 ;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
706 (LOGEQV (REM C -
6758)
707 (REM B
(MAX 44 (RETURN-FROM B6 A
)))))))
709 (compile nil
'(lambda ()
711 (flet ((foo (x y
) (if (> x y
) (print x
) (print y
))))
714 (foo (return 14) 2)))))
716 ;;; bug in Alpha backend: not enough sanity checking of arguments to
718 (assert (= (funcall (compile nil
725 ;;; bug found by WHN and pfdietz: compiler failure while referencing
726 ;;; an entry point inside a deleted lambda
727 (compile nil
'(lambda ()
732 (flet ((truly (fn bbd
)
736 (multiple-value-prog1
753 (wum #'bbfn
"hc3" (list)))
755 (compile nil
'(lambda () (flet ((%f
() (unwind-protect nil
))) nil
)))
757 ;;; the strength reduction of constant multiplication used (before
758 ;;; sbcl-0.8.4.x) to lie to the compiler. This meant that, under
759 ;;; certain circumstances, the compiler would derive that a perfectly
760 ;;; reasonable multiplication never returned, causing chaos. Fixed by
761 ;;; explicitly doing modular arithmetic, and relying on the backends
766 (declare (type (integer 178956970 178956970) x
)
772 ;;; bug in modular arithmetic and type specifiers
773 (assert (= (funcall (compile nil
(lambda (x) (logand x x
0)))
777 ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP
778 ;;; produced wrong result for shift >=32 on X86
779 (assert (= 0 (funcall
782 (declare (type (integer 4303063 101130078) a
))
783 (mask-field (byte 18 2) (ash a
77))))
785 ;;; rewrite the test case to get the unsigned-byte 32/64
786 ;;; implementation even after implementing some modular arithmetic
787 ;;; with signed-byte 30:
788 (assert (= 0 (funcall
791 (declare (type (integer 4303063 101130078) a
))
792 (mask-field (byte 30 2) (ash a
77))))
794 (assert (= 0 (funcall
797 (declare (type (integer 4303063 101130078) a
))
798 (mask-field (byte 64 2) (ash a
77))))
800 ;;; and a similar test case for the signed masking extension (not the
801 ;;; final interface, so change the call when necessary):
802 (assert (= 0 (funcall
805 (declare (type (integer 4303063 101130078) a
))
806 (sb-c::mask-signed-field
30 (ash a
77))))
808 (assert (= 0 (funcall
811 (declare (type (integer 4303063 101130078) a
))
812 (sb-c::mask-signed-field
61 (ash a
77))))
815 ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
816 ;;; type check regeneration
817 (assert (eql (funcall
818 (compile nil
'(lambda (a c
)
819 (declare (type (integer 185501219873 303014665162) a
))
820 (declare (type (integer -
160758 255724) c
))
821 (declare (optimize (speed 3)))
823 (- -
554046873252388011622614991634432
825 (unwind-protect 2791485))))
826 (max (ignore-errors a
)
827 (let ((v6 (- v8
(restart-case 980))))
831 (assert (eql (funcall
832 (compile nil
'(lambda (a b
)
840 (load-time-value -
6876935))))
841 (if (logbitp 1 a
) b
(setq a -
1522022182249))))))))
842 -
1802767029877 -
12374959963)
845 ;;; various MISC.*, related to NODEs/LVARs with derived type NIL
846 (assert (eql (funcall (compile nil
'(lambda (c)
847 (declare (type (integer -
3924 1001809828) c
))
848 (declare (optimize (speed 3)))
849 (min 47 (if (ldb-test (byte 2 14) c
)
851 (ignore-errors -
732893970)))))
854 (assert (eql (funcall
855 (compile nil
'(lambda (b)
856 (declare (type (integer -
1598566306 2941) b
))
857 (declare (optimize (speed 3)))
858 (max -
148949 (ignore-errors b
))))
861 (assert (eql (funcall
862 (compile nil
'(lambda (b c
)
863 (declare (type (integer -
4 -
3) c
))
865 (flet ((%f1
(f1-1 f1-2 f1-3
)
866 (if (logbitp 0 (return-from b7
867 (- -
815145138 f1-2
)))
868 (return-from b7 -
2611670)
870 (let ((v2 (%f1 -
2464 (%f1 -
1146 c c
) -
2)))
874 (assert (eql (funcall
877 (declare (type (integer -
29742055786 23602182204) b
))
878 (declare (type (integer -
7409 -
2075) c
))
879 (declare (optimize (speed 3)))
883 (ignore-errors (return-from b6
884 (if (= c
8) b
82674))))))
888 (assert (equal (multiple-value-list
890 (compile nil
'(lambda (a)
891 (declare (type (integer -
944 -
472) a
))
892 (declare (optimize (speed 3)))
896 (if (= 55957 a
) -
117 (ignore-errors
897 (return-from b3 a
))))))))
902 (assert (zerop (funcall
905 (declare (type (integer 79828 2625480458) a
))
906 (declare (type (integer -
4363283 8171697) b
))
907 (declare (type (integer -
301 0) c
))
908 (if (equal 6392154 (logxor a b
))
912 (logior (logandc2 c v5
)
913 (common-lisp:handler-case
914 (ash a
(min 36 22477)))))))))
917 ;;; MISC.152, 153: deleted code and iteration var type inference
918 (assert (eql (funcall
922 (let ((v1 (let ((v8 (unwind-protect 9365)))
926 (labels ((%f11
(f11-1) f11-1
))
930 (labels ((%f6
(f6-1 f6-2 f6-3
) v1
))
931 (dpb (unwind-protect a
)
933 (labels ((%f4
() 27322826))
934 (%f6 -
2 -
108626545 (%f4
))))))))))))
938 (assert (eql (funcall
943 ((-96879 -
1035 -
57680 -
106404 -
94516 -
125088)
944 (unwind-protect 90309179))
945 ((-20811 -
86901 -
9368 -
98520 -
71594)
946 (let ((v9 (unwind-protect 136707)))
949 (let ((v4 (return-from b3 v9
)))
950 (- (ignore-errors (return-from b3 v4
))))))))
958 (assert (eql (funcall
969 &optional
(f17-4 185155520) (f17-5 c
)
972 (%f17 -
1046 a
1115306 (%f17 b -
146330 422) -
337817)))
973 (f15-5 a
) (f15-6 -
40))
974 (return-from b3 -
16)))
975 (multiple-value-call #'%f15
(values -
519354 a
121 c -
1905))))))
980 (assert (eql (funcall
984 (declare (notinline list apply
))
985 (declare (optimize (safety 3)))
986 (declare (optimize (speed 0)))
987 (declare (optimize (debug 0)))
988 (labels ((%f12
(f12-1 f12-2
)
989 (labels ((%f2
(f2-1 f2-2
)
996 (return-from %f12 b
)))
999 (%f18
(%f18
150 -
64 f12-1
)
1006 &optional
(f7-3 (%f6
)))
1009 (%f2 b -
36582571))))
1010 (apply #'%f12
(list 774 -
4413)))))
1015 (assert (eql (funcall
1019 (declare (notinline values
))
1020 (declare (optimize (safety 3)))
1021 (declare (optimize (speed 0)))
1022 (declare (optimize (debug 0)))
1025 &optional
(f11-3 c
) (f11-4 7947114)
1027 (flet ((%f3
(f3-1 &optional
(f3-2 b
) (f3-3 5529))
1029 (multiple-value-call #'%f3
1030 (values (%f3 -
30637724 b
) c
)))))
1032 (if (and nil
(%f11 a a
))
1033 (if (%f11 a
421778 4030 1)
1039 (%f11 c a c -
4 214720)
1051 ;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
1052 ;;; local lambda argument
1058 (declare (type (integer 804561 7640697) a
))
1059 (declare (type (integer -
1 10441401) b
))
1060 (declare (type (integer -
864634669 55189745) c
))
1061 (declare (ignorable a b c
))
1062 (declare (optimize (speed 3)))
1063 (declare (optimize (safety 1)))
1064 (declare (optimize (debug 1)))
1067 (labels ((%f4
() (round 200048 (max 99 c
))))
1070 (labels ((%f3
(f3-1) -
162967612))
1071 (%f3
(let* ((v8 (%f4
)))
1072 (setq f11-1
(%f4
)))))))))
1073 (%f11 -
120429363 (%f11
62362 b
)))))
1074 6714367 9645616 -
637681868)
1077 ;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
1079 (assert (equal (multiple-value-list
1081 (compile nil
'(lambda ()
1082 (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
1085 (flet ((%f16
() 0)) (%f16
))))))))
1094 (declare (type (integer 867934833 3293695878) a
))
1095 (declare (type (integer -
82111 1776797) b
))
1096 (declare (type (integer -
1432413516 54121964) c
))
1097 (declare (optimize (speed 3)))
1098 (declare (optimize (safety 1)))
1099 (declare (optimize (debug 1)))
1101 (flet ((%f15
(f15-1 &optional
(f15-2 c
))
1102 (labels ((%f1
(f1-1 f1-2
) 0))
1105 (multiple-value-call #'%f15
1106 (values (%f15 c
0) (%f15
0)))))
1108 (flet ((%f8
(f8-1 &optional
(f8-2 (%f4
)) (f8-3 0))
1112 3040851270 1664281 -
1340106197)))
1120 (declare (notinline <=))
1121 (declare (optimize (speed 2) (space 3) (safety 0)
1122 (debug 1) (compilation-speed 3)))
1123 (if (if (<= 0) nil nil
)
1124 (labels ((%f9
(f9-1 f9-2 f9-3
)
1126 (dotimes (iv4 5 a
) (%f9
0 0 b
)))
1130 ;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
1136 (declare (type (integer 177547470 226026978) a
))
1137 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
1138 (compilation-speed 1)))
1139 (logand a
(* a
438810))))
1144 ;;;; Bugs in stack analysis
1145 ;;; bug 299 (reported by PFD)
1151 (declare (optimize (debug 1)))
1152 (multiple-value-call #'list
1153 (if (eval t
) (eval '(values :a
:b
:c
)) nil
)
1154 (catch 'foo
(throw 'foo
(values :x
:y
)))))))
1156 ;;; bug 298 (= MISC.183)
1157 (assert (zerop (funcall
1161 (declare (type (integer -
368154 377964) a
))
1162 (declare (type (integer 5044 14959) b
))
1163 (declare (type (integer -
184859815 -
8066427) c
))
1164 (declare (ignorable a b c
))
1165 (declare (optimize (speed 3)))
1166 (declare (optimize (safety 1)))
1167 (declare (optimize (debug 1)))
1169 (flet ((%f3
(f3-1 f3-2 f3-3
) 0))
1170 (apply #'%f3
0 (catch 'foo
(return-from b7
(%f3
0 b c
))) c nil
)))))
1172 (assert (equal (eval '(let () (apply #'list
1 (list (catch 'a
(throw 'a
(block b
2)))))))
1178 (multiple-value-call #'list
1182 (multiple-value-call #'list
1188 (return-from quux
1)
1189 (throw 'baz
2))))))))))))))
1190 (assert (equal (funcall f t
) '(:b
1)))
1191 (assert (equal (funcall f nil
) '(:a
2))))
1199 (declare (type (integer 5 155656586618) a
))
1200 (declare (type (integer -
15492 196529) b
))
1201 (declare (type (integer 7 10) c
))
1202 (declare (optimize (speed 3)))
1203 (declare (optimize (safety 1)))
1204 (declare (optimize (debug 1)))
1207 &optional
(f3-4 a
) (f3-5 0)
1209 (labels ((%f10
(f10-1 f10-2 f10-3
)
1214 (- (if (equal a b
) b
(%f10 c a
0))
1215 (catch 'ct2
(throw 'ct2 c
)))
1218 (%f3
(%f3
(%f3 b
0 0 0) a
0) a b b b c
)))) 5 0 7)
1223 '(let* ((form '(labels ((%f3
(f3-1 f3-2
) f3-1
))
1224 (apply #'%f3 b
(catch 'ct8
(throw 'ct8
(logeqv (%f3 c
0)))) nil
)))
1227 (declare (type (integer -
2 19) b
)
1228 (type (integer -
1520 218978) c
)
1229 (optimize (speed 3) (safety 1) (debug 1)))
1232 (declare (notinline logeqv apply
)
1233 (optimize (safety 3) (speed 0) (debug 0)))
1235 (cf1 (compile nil fn1
))
1236 (cf2 (compile nil fn2
))
1237 (result1 (multiple-value-list (funcall cf1
2 18886)))
1238 (result2 (multiple-value-list (funcall cf2
2 18886))))
1239 (if (equal result1 result2
)
1241 (values result1 result2
))))
1251 (optimize (speed 3) (space 3) (safety 1)
1252 (debug 2) (compilation-speed 0)))
1253 (apply (constantly 0) (catch 'ct2
0) 0 (catch 'ct2
0) nil
))))))
1256 (assert (zerop (funcall
1260 (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
1261 (compilation-speed 2)))
1262 (apply (constantly 0)
1266 (apply (constantly 0)
1285 (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
1286 (multiple-value-prog1
1287 (the integer
(catch 'ct8
(catch 'ct7
15867134)))
1288 (catch 'ct1
(throw 'ct1
0))))))
1291 ;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
1292 ;;; could transform known-values LVAR to UVL
1293 (assert (zerop (funcall
1297 (declare (notinline boole values denominator list
))
1303 (compilation-speed 2)))
1308 (let ((v9 (ignore-errors (throw 'ct6
0))))
1310 (progv nil nil
(values (boole boole-and
0 v9
)))))))))
1313 ;;; non-continuous dead UVL blocks
1314 (defun non-continuous-stack-test (x)
1315 (multiple-value-call #'list
1316 (eval '(values 11 12))
1317 (eval '(values 13 14))
1319 (return-from non-continuous-stack-test
1320 (multiple-value-call #'list
1321 (eval '(values :b1
:b2
))
1322 (eval '(values :b3
:b4
))
1325 (multiple-value-call (eval #'values
)
1326 (eval '(values 1 2))
1327 (eval '(values 3 4))
1330 (multiple-value-call (eval #'values
)
1331 (eval '(values :a1
:a2
))
1332 (eval '(values :a3
:a4
))
1335 (multiple-value-call (eval #'values
)
1336 (eval '(values 5 6))
1337 (eval '(values 7 8))
1340 (return-from int
:int
))))))))))))))))
1341 (assert (equal (non-continuous-stack-test t
) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext
)))
1342 (assert (equal (non-continuous-stack-test nil
) '(:b1
:b2
:b3
:b4
:a1
:a2
:a3
:a4
:int
)))
1344 ;;; MISC.362: environment of UNWIND-PROTECTor is different from that
1346 (assert (equal (multiple-value-list (funcall
1350 (declare (optimize (speed 3) (space 3) (safety 2)
1351 (debug 2) (compilation-speed 3)))
1354 (labels ((%f15
(f15-1 f15-2 f15-3
)
1355 (rational (throw 'ct5
0))))
1361 (progv '(*s2
* *s5
*) (list 0 (%f15
0 g
0)) b
)
1365 (common-lisp:handler-case
0)))))
1377 (declare (notinline funcall min coerce
))
1383 (compilation-speed 1)))
1384 (flet ((%f12
(f12-1)
1387 (if f12-1
(multiple-value-prog1
1388 b
(return-from %f12
0))
1391 (funcall #'%f12
0))))
1394 ;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
1395 ;;; potential problem: optimizers and type derivers for MAX and MIN
1396 ;;; were not consistent in treating EQUALP, but not EQL, arguments.
1397 (dolist (f '(min max
))
1398 (loop for complex-arg-args in
'((1d0 2d0
) (0d0 1d0
))
1399 for complex-arg
= `(if x
,@complex-arg-args
)
1401 (loop for args in
`((1 ,complex-arg
)
1403 for form
= `(,f
,@args
)
1404 for f1
= (compile nil
`(lambda (x) ,form
))
1405 and f2
= (compile nil
`(lambda (x) (declare (notinline min max
))
1408 (dolist (x '(nil t
))
1409 (assert (eql (funcall f1 x
) (funcall f2 x
)))))))
1412 (handler-case (compile nil
'(lambda (x)
1413 (declare (optimize (speed 3) (safety 0)))
1414 (the double-float
(sqrt (the double-float x
)))))
1415 (sb-ext:compiler-note
(c)
1416 ;; Ignore the note for the float -> pointer conversion of the
1418 (unless (string= (car (last (sb-c::simple-condition-format-arguments c
)))
1420 (error "Compiler does not trust result type assertion."))))
1422 (let ((f (compile nil
'(lambda (x)
1423 (declare (optimize speed
(safety 0)))
1426 (multiple-value-prog1
1427 (sqrt (the double-float x
))
1429 (return :minus
)))))))))
1430 (assert (eql (funcall f -
1d0
) :minus
))
1431 (assert (eql (funcall f
4d0
) 2d0
)))
1433 ;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
1435 (compile nil
'(lambda (a i
)
1437 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
1438 (inhibit-warnings 0)))
1439 (declare (type (alien (* (unsigned 8))) a
)
1440 (type (unsigned-byte 32) i
))
1442 (compiler-note () (error "The code is not optimized.")))
1445 (compile nil
'(lambda (x)
1446 (declare (type (integer -
100 100) x
))
1447 (declare (optimize speed
))
1448 (declare (notinline identity
))
1450 (compiler-note () (error "IDENTITY derive-type not applied.")))
1452 (assert (null (funcall (compile nil
'(lambda (x) (funcall #'cddr x
))) nil
)))
1454 ;;; MISC.293 = easy variant of bug 303: repeated write to the same
1455 ;;; LVAR; here the first write may be cleared before the second is
1463 (declare (notinline complex
))
1464 (declare (optimize (speed 1) (space 0) (safety 1)
1465 (debug 3) (compilation-speed 3)))
1466 (flet ((%f
() (multiple-value-prog1 0 (return-from %f
0))))
1467 (complex (%f
) 0)))))))
1469 ;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
1470 (assert (zerop (funcall
1474 (declare (type (integer -
1294746569 1640996137) a
))
1475 (declare (type (integer -
807801310 3) c
))
1476 (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
1483 (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7
0))) 0 0) 0))))
1485 391833530 -
32785211)))
1487 ;;; efficiency notes for ordinary code
1488 (macrolet ((frob (arglist &body body
)
1491 (compile nil
'(lambda ,arglist
,@body
))
1492 (sb-ext:compiler-note
(e)
1493 (error "bad compiler note for ~S:~% ~A" ',body e
)))
1496 (compile nil
'(lambda ,arglist
(declare (optimize speed
))
1498 (sb-ext:compiler-note
(e) (throw :got-note nil
)))
1499 (error "missing compiler note for ~S" ',body
)))))
1500 (frob (x) (funcall x
))
1501 (frob (x y
) (find x y
))
1502 (frob (x y
) (find-if x y
))
1503 (frob (x y
) (find-if-not x y
))
1504 (frob (x y
) (position x y
))
1505 (frob (x y
) (position-if x y
))
1506 (frob (x y
) (position-if-not x y
))
1507 (frob (x) (aref x
0)))
1509 (macrolet ((frob (style-warn-p form
)
1511 `(catch :got-style-warning
1514 (style-warning (e) (throw :got-style-warning nil
)))
1515 (error "missing style-warning for ~S" ',form
))
1519 (error "bad style-warning for ~S: ~A" ',form e
))))))
1520 (frob t
(lambda (x &optional y
&key z
) (list x y z
)))
1521 (frob nil
(lambda (x &optional y z
) (list x y z
)))
1522 (frob nil
(lambda (x &key y z
) (list x y z
)))
1523 (frob t
(defgeneric #:foo
(x &optional y
&key z
)))
1524 (frob nil
(defgeneric #:foo
(x &optional y z
)))
1525 (frob nil
(defgeneric #:foo
(x &key y z
)))
1526 (frob t
(defun #:foo
(x) (flet ((foo (x &optional y
&key z
) (list x y z
))) (foo x x
:z x
)))))
1528 ;;; this was a bug in the LOGXOR type deriver. The top form gave a
1529 ;;; note, because the system failed to derive the fact that the return
1530 ;;; from LOGXOR was small and negative, though the bottom one worked.
1531 (handler-bind ((sb-ext:compiler-note
#'error
))
1532 (compile nil
'(lambda ()
1533 (declare (optimize speed
(safety 0)))
1535 (declare (type (integer 3 6) x
)
1536 (type (integer -
6 -
3) y
))
1537 (+ (logxor x y
) most-positive-fixnum
)))))
1538 (handler-bind ((sb-ext:compiler-note
#'error
))
1539 (compile nil
'(lambda ()
1540 (declare (optimize speed
(safety 0)))
1542 (declare (type (integer 3 6) y
)
1543 (type (integer -
6 -
3) x
))
1544 (+ (logxor x y
) most-positive-fixnum
)))))
1546 ;;; check that modular ash gives the right answer, to protect against
1547 ;;; possible misunderstandings about the hardware shift instruction.
1548 (assert (zerop (funcall
1549 (compile nil
'(lambda (x y
)
1550 (declare (optimize speed
)
1551 (type (unsigned-byte 32) x y
))
1552 (logand #xffffffff
(ash x y
))))
1555 ;;; code instrumenting problems
1558 (declare (optimize (debug 3)))
1559 (list (the integer
(if nil
14 t
)))))
1563 (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD
))
1569 (COMPILATION-SPEED 0)))
1570 (MASK-FIELD (BYTE 7 26)
1572 (TAGBODY (THE INTEGER
(CATCH 'CT4
(LOGORC1 C -
15950))) 1)
1576 '(lambda (buffer i end
)
1577 (declare (optimize (debug 3)))
1578 (loop (when (not (eql 0 end
)) (return)))
1579 (let ((s (make-string end
)))
1580 (setf (schar s i
) (schar buffer i
))
1583 ;;; check that constant string prefix and suffix don't cause the
1584 ;;; compiler to emit code deletion notes.
1585 (handler-bind ((sb-ext:code-deletion-note
#'error
))
1586 (compile nil
'(lambda (s x
)
1587 (pprint-logical-block (s x
:prefix
"(")
1589 (compile nil
'(lambda (s x
)
1590 (pprint-logical-block (s x
:per-line-prefix
";")
1592 (compile nil
'(lambda (s x
)
1593 (pprint-logical-block (s x
:suffix
">")
1596 ;;; MISC.427: loop analysis requires complete DFO structure
1597 (assert (eql 17 (funcall
1601 (declare (notinline list reduce logior
))
1602 (declare (optimize (safety 2) (compilation-speed 1)
1603 (speed 3) (space 2) (debug 2)))
1605 (let* ((v5 (reduce #'+ (list 0 a
))))
1606 (declare (dynamic-extent v5
))
1611 (assert (zerop (funcall
1615 (declare (type (integer -
8431780939320 1571817471932) a
))
1616 (declare (type (integer -
4085 0) b
))
1617 (declare (ignorable a b
))
1620 (compilation-speed 0)
1621 #+sbcl
(sb-c:insert-step-conditions
0)
1628 (elt '(1954479092053)
1632 (lognand iv1
(ash iv1
(min 53 iv1
)))
1635 -
7639589303599 -
1368)))
1640 (declare (type (integer) a
))
1641 (declare (type (integer) b
))
1642 (declare (ignorable a b
))
1643 (declare (optimize (space 2) (compilation-speed 0)
1644 (debug 0) (safety 0) (speed 3)))
1646 (when (< iv1
2) (print 'x
)) ;; request for second constraint propagation pass
1647 (print (if (< iv1 iv1
)
1648 (logand (ash iv1 iv1
) 1)
1651 ;;; MISC.435: lambda var substitution in a deleted code.
1652 (assert (zerop (funcall
1656 (declare (notinline aref logandc2 gcd make-array
))
1658 (optimize (space 0) (safety 0) (compilation-speed 3)
1659 (speed 3) (debug 1)))
1662 (let* ((v2 (make-array nil
:initial-element
(catch 'ct1
(go tag2
)))))
1663 (declare (dynamic-extent v2
))
1664 (gcd (go tag2
) (logandc2 (catch 'ct2 c
) (aref v2
))))
1667 3021871717588 -
866608 -
2 -
17194)))
1669 ;;; MISC.436, 438: lost reoptimization
1670 (assert (zerop (funcall
1674 (declare (type (integer -
2917822 2783884) a
))
1675 (declare (type (integer 0 160159) b
))
1676 (declare (ignorable a b
))
1678 (optimize (compilation-speed 1)
1682 ; #+sbcl (sb-c:insert-step-conditions 0)
1696 '(-10197561 486 430631291
1702 (assert (zerop (funcall
1706 (declare (type (integer 0 1696) a
))
1707 ; (declare (ignorable a))
1708 (declare (optimize (space 2) (debug 0) (safety 1)
1709 (compilation-speed 0) (speed 1)))
1710 (if (logbitp 0 (ash (1- a
) (min 11 a
))) 0 0)))
1717 (declare (type (simple-array function
(2)) s
) (type ei ei
))
1718 (funcall (aref s ei
) x y
))))
1720 ;;; MISC.320: ir1-transform can create an intercomponent reference to
1722 (assert (eql 102 (funcall
1726 (declare (optimize (speed 3) (space 0) (safety 2)
1727 (debug 2) (compilation-speed 0)))
1730 (flet ((%f12
() (rem 0 -
43)))
1731 (multiple-value-call #'%f12
(values))))))))))
1733 ;;; MISC.437: lost reoptimization after FLUSH-DEST
1734 (assert (zerop (funcall
1737 '(lambda (a b c d e
)
1738 (declare (notinline values complex eql
))
1740 (optimize (compilation-speed 3)
1747 &optional
(f10-4 (ignore-errors 0)) (f10-5 0)
1748 &key
&allow-other-keys
)
1749 (if (or (eql 0 0) t
) 0 (if f10-1
0 0))))
1750 (complex (multiple-value-call #'%f10
(values a c b
0 0)) 0))))
1751 80043 74953652306 33658947 -
63099937105 -
27842393)))
1753 ;;; bug #351 -- program-error for malformed LET and LET*, including those
1754 ;;; resulting from SETF of LET.
1755 (dolist (fun (list (compile nil
'(lambda () (let :bogus-let
:oops
)))
1756 (compile nil
'(lambda () (let* :bogus-let
* :oops
)))
1757 (compile nil
'(lambda (x) (push x
(let ((y 0)) y
))))))
1758 (assert (functionp fun
))
1759 (multiple-value-bind (res err
) (ignore-errors (funcall fun
))
1761 (assert (typep err
'program-error
))))
1763 (let ((fun (compile nil
'(lambda (x) (random (if x
10 20))))))
1764 (dotimes (i 100 (error "bad RANDOM distribution"))
1765 (when (> (funcall fun nil
) 9)
1768 (when (> (funcall fun t
) 9)
1769 (error "bad RANDOM event"))))
1771 ;;; 0.8.17.28-sma.1 lost derived type information.
1772 (with-test (:name
"0.8.17.28-sma.1" :fails-on
:sparc
)
1773 (handler-bind ((sb-ext:compiler-note
(lambda (c) (error "~A" c
))))
1776 (declare (optimize (speed 3) (safety 0)))
1777 (declare (type (integer 0 80) x
)
1778 (type (integer 0 11) y
)
1779 (type (simple-array (unsigned-byte 32) (*)) v
))
1780 (setf (aref v
0) (* (* x
#.
(floor (ash 1 32) (* 11 80))) y
))
1783 ;;; Bug reported by Robert J. Macomber: instrumenting of more-entry
1784 ;;; prevented open coding of %LISTIFY-REST-ARGS.
1785 (let ((f (compile nil
'(lambda ()
1786 (declare (optimize (debug 3)))
1787 (with-simple-restart (blah "blah") (error "blah"))))))
1788 (handler-bind ((error (lambda (c) (invoke-restart 'blah
))))
1789 (assert (equal (multiple-value-list (funcall f
)) '(nil t
)))))
1791 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
1792 ;;; constant index and value.
1793 (loop for n-bits
= 1 then
(* n-bits
2)
1794 for type
= `(unsigned-byte ,n-bits
)
1795 and v-max
= (1- (ash 1 n-bits
))
1796 while
(<= n-bits sb-vm
:n-word-bits
)
1798 (let* ((n (* 2 (1+ (- sb-vm
::n-word-bits n-bits
))))
1799 (array1 (make-array n
:element-type type
))
1800 (array2 (make-array n
:element-type type
)))
1802 (dolist (v (list 0 v-max
))
1803 (let ((f (compile nil
`(lambda (a)
1804 (declare (type (simple-array ,type
(,n
)) a
))
1805 (setf (aref a
,i
) ,v
)))))
1806 (fill array1
(- v-max v
))
1807 (fill array2
(- v-max v
))
1809 (setf (aref array2 i
) v
)
1810 (assert (every #'= array1 array2
)))))))
1812 (let ((fn (compile nil
'(lambda (x)
1813 (declare (type bit x
))
1814 (declare (optimize speed
))
1815 (let ((b (make-array 64 :element-type
'bit
1816 :initial-element
0)))
1818 (assert (= (funcall fn
0) 64))
1819 (assert (= (funcall fn
1) 0)))
1821 (let ((fn (compile nil
'(lambda (x y
)
1822 (declare (type simple-bit-vector x y
))
1823 (declare (optimize speed
))
1827 (make-array 64 :element-type
'bit
:initial-element
0)
1828 (make-array 64 :element-type
'bit
:initial-element
0)))
1832 (make-array 64 :element-type
'bit
:initial-element
0)
1833 (let ((b (make-array 64 :element-type
'bit
:initial-element
0)))
1834 (setf (sbit b
63) 1)
1837 ;;; MISC.535: compiler failure
1838 (let ((c0 #c
(4196.088977268509d0 -
15943.3603515625d0
)))
1839 (assert (not (funcall
1843 (declare (optimize speed
(safety 1))
1846 (eql (the (complex double-float
) p1
) p2
)))
1847 c0
#c
(12 612/979)))))
1849 ;;; reported by Lutz Euler: we shouldn't signal a compiler note for
1850 ;;; simple-bit-vector functions.
1851 (handler-bind ((sb-ext:compiler-note
#'error
))
1852 (compile nil
'(lambda (x)
1853 (declare (type simple-bit-vector x
))
1855 (handler-bind ((sb-ext:compiler-note
#'error
))
1856 (compile nil
'(lambda (x y
)
1857 (declare (type simple-bit-vector x y
))
1860 ;;; MISC.550: CAST merging in IR1 finalization caused unexpected
1861 ;;; code transformations.
1862 (assert (eql (funcall
1866 (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
1869 (or p1
(the (eql t
) p2
))))
1873 ;;; MISC.548: type check weakening converts required type into
1880 (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
1881 (atom (the (member f assoc-if write-line t w
) p1
))))
1884 ;;; Free special bindings only apply to the body of the binding form, not
1885 ;;; the initialization forms.
1887 (funcall (compile 'nil
1890 (declare (special x
))
1892 ((lambda (&optional
(y x
))
1893 (declare (special x
)) y
)))))))))
1895 ;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
1896 ;;; a rational was zero, but didn't do the substitution, leading to a
1897 ;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
1898 ;;; machine's ASH instruction's immediate field) that the compiler
1899 ;;; thought was legitimate.
1901 ;;; FIXME: this has been recorded as bug 383. The attempted fix (sbcl
1902 ;;; 0.9.2.6) led to lots of spurious optimization notes. So the bug stil
1903 ;;; exist and this test case serves as a reminder of the problem.
1904 ;;; --njf, 2005-07-05
1908 (DECLARE (TYPE (INTEGER -
2 14) B
))
1909 (DECLARE (IGNORABLE B
))
1910 (ASH (IMAGPART B
) 57)))
1912 ;;; bug reported by Eduardo Mu\~noz
1913 (multiple-value-bind (fun warnings failure
)
1914 (compile nil
'(lambda (struct first
)
1915 (declare (optimize speed
))
1916 (let* ((nodes (nodes struct
))
1917 (bars (bars struct
))
1918 (length (length nodes
))
1919 (new (make-array length
:fill-pointer
0)))
1920 (vector-push first new
)
1921 (loop with i fixnum
= 0
1922 for newl fixnum
= (length new
)
1923 while
(< newl length
) do
1924 (let ((oldl (length new
)))
1925 (loop for j fixnum from i below newl do
1926 (dolist (n (node-neighbours (aref new j
) bars
))
1927 (unless (find n new
)
1928 (vector-push n new
))))
1931 (declare (ignore fun warnings failure
))
1932 (assert (not failure
)))
1934 ;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe
1936 (compile nil
'(lambda (x y a b c
)
1937 (- y
(* (signum x
) (sqrt (abs (- (* b x
) c
)))))))
1939 ;;; Type inference from CHECK-TYPE
1940 (let ((count0 0) (count1 0))
1941 (handler-bind ((sb-ext:compiler-note
(lambda (c) (incf count0
))))
1942 (compile nil
'(lambda (x)
1943 (declare (optimize (speed 3)))
1945 ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note
1946 (assert (> count0
1))
1947 (handler-bind ((sb-ext:compiler-note
(lambda (c) (incf count1
))))
1948 (compile nil
'(lambda (x)
1949 (declare (optimize (speed 3)))
1950 (check-type x fixnum
)
1952 ;; Only the posssible word -> bignum conversion note
1953 (assert (= count1
1)))
1955 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
1956 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
1957 (with-test (:name
:sap-ref-float
)
1958 (compile nil
'(lambda (sap)
1959 (let ((x (setf (sb-vm::sap-ref-double sap
0) 1d0
)))
1961 (compile nil
'(lambda (sap)
1962 (let ((x (setf (sb-vm::sap-ref-single sap
0) 1d0
)))
1966 (with-test (:name
:string-union-types
)
1967 (compile nil
'(lambda (x)
1968 (declare (type (or (simple-array character
(6))
1969 (simple-array character
(5))) x
))
1972 ;;; MISC.623: missing functions for constant-folding
1978 (declare (optimize (space 2) (speed 0) (debug 2)
1979 (compilation-speed 3) (safety 0)))
1980 (loop for lv3 below
1
1982 (loop for lv2 below
2
1984 (bit #*1001101001001
1985 (min 12 (max 0 lv3
))))))))))))
1987 ;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs
1993 (declare (type (integer 21 28) a
))
1994 (declare (optimize (compilation-speed 1) (safety 2)
1995 (speed 0) (debug 0) (space 1)))
1996 (let* ((v7 (flet ((%f3
(f3-1 f3-2
)
1997 (loop for lv2 below
1
2001 (min 7 (max 0 (eval '0))))))))
2006 ;;; MISC.626: bandaged AVER was still wrong
2007 (assert (eql -
829253
2012 (declare (type (integer -
902970 2) a
))
2013 (declare (optimize (space 2) (debug 0) (compilation-speed 1)
2014 (speed 0) (safety 3)))
2015 (prog2 (if (logbitp 30 a
) 0 (block b3
0)) a
)))
2018 ;; MISC.628: constant-folding %LOGBITP was buggy
2024 (declare (optimize (safety 3) (space 3) (compilation-speed 3)
2025 (speed 0) (debug 1)))
2026 (not (not (logbitp 0 (floor 2147483651 (min -
23 0))))))))))
2028 ;; mistyping found by random-tester
2034 (declare (optimize (speed 1) (debug 0)
2035 (space 2) (safety 0) (compilation-speed 0)))
2037 (* (/ (multiple-value-prog1 -
29457482 -
5602513511) 1))))))))
2039 ;; aggressive constant folding (bug #400)
2041 (eq t
(funcall (compile nil
'(lambda () (or t
(the integer
(/ 1 0))))))))
2043 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-non-var-1
))
2046 (compile nil
'(lambda (x y
)
2047 (when (eql x
(length y
))
2049 (declare (optimize (speed 3)))
2051 (compiler-note () (error "The code is not optimized.")))))
2053 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-non-var-2
))
2056 (compile nil
'(lambda (x y
)
2057 (when (eql (length y
) x
)
2059 (declare (optimize (speed 3)))
2061 (compiler-note () (error "The code is not optimized.")))))
2063 (with-test (:name
(:compiler
:constraint-propagation
:float-bounds-1
))
2065 (compile nil
'(lambda (x)
2066 (declare (type (single-float * (3.0
)) x
))
2070 (compiler-note () (error "Deleted reachable code."))))
2072 (with-test (:name
(:compiler
:constraint-propagation
:float-bounds-2
))
2075 (compile nil
'(lambda (x)
2076 (declare (type single-float x
))
2079 (error "This is unreachable.")))))
2080 (compiler-note () (throw :note nil
)))
2081 (error "Unreachable code undetected.")))
2083 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-var-1
))
2086 (compile nil
'(lambda (x y
)
2087 (when (typep y
'fixnum
)
2089 (unless (typep x
'fixnum
)
2090 (error "This is unreachable"))
2092 (compiler-note () (throw :note nil
)))
2093 (error "Unreachable code undetected.")))
2095 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-var-2
))
2098 (compile nil
'(lambda (x y
)
2099 (when (typep y
'fixnum
)
2101 (unless (typep x
'fixnum
)
2102 (error "This is unreachable"))
2104 (compiler-note () (throw :note nil
)))
2105 (error "Unreachable code undetected.")))
2107 ;; Reported by John Wiseman, sbcl-devel
2108 ;; Subject: [Sbcl-devel] float type derivation bug?
2109 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700
2110 (with-test (:name
(:type-derivation
:float-bounds
))
2111 (compile nil
'(lambda (bits)
2112 (let* ((s (if (= (ash bits -
31) 0) 1 -
1))
2113 (e (logand (ash bits -
23) #xff
))
2115 (ash (logand bits
#x7fffff
) 1)
2116 (logior (logand bits
#x7fffff
) #x800000
))))
2117 (float (* s m
(expt 2 (- e
150))))))))
2119 ;; Reported by James Knight
2120 ;; Subject: [Sbcl-devel] AVER: "(EQ (SB-NAME (SC-SB (TN-SC TN))) 'REGISTERS)"
2121 ;; Date: Fri, 24 Mar 2006 19:30:00 -0500
2122 (with-test (:name
:logbitp-vop
)
2124 '(lambda (days shift
)
2125 (declare (type fixnum shift days
))
2127 (canonicalized-shift (+ shift
1))
2128 (first-wrapping-day (- 1 canonicalized-shift
)))
2129 (declare (type fixnum result
))
2130 (dotimes (source-day 7)
2131 (declare (type (integer 0 6) source-day
))
2132 (when (logbitp source-day days
)
2136 (if (< source-day first-wrapping-day
)
2137 (+ source-day canonicalized-shift
)
2139 canonicalized-shift
) 7)))))))
2142 ;;; MISC.637: incorrect delaying of conversion of optional entries
2143 ;;; with hairy constant defaults
2144 (let ((f '(lambda ()
2145 (labels ((%f11
(f11-2 &key key1
)
2146 (labels ((%f8
(f8-2 &optional
(f8-5 (if nil
(return-from %f11
0) 0)))
2151 (assert (eq (funcall (compile nil f
)) :good
)))
2153 ;;; MISC.555: new reference to an already-optimized local function
2154 (let* ((l '(lambda (p1)
2155 (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1
))
2157 (f (compile nil l
)))
2158 (assert (funcall f
:good
))
2159 (assert (nth-value 1 (ignore-errors (funcall f
42)))))
2161 ;;; Check that the compiler doesn't munge *RANDOM-STATE*.
2162 (let* ((state (make-random-state))
2163 (*random-state
* (make-random-state state
))
2164 (a (random most-positive-fixnum
)))
2165 (setf *random-state
* state
)
2166 (compile nil
`(lambda (x a
)
2167 (declare (single-float x
)
2168 (type (simple-array double-float
) a
))
2169 (+ (loop for i across a
2172 (assert (= a
(random most-positive-fixnum
))))
2174 ;;; MISC.641: LET-conversion after physical environment analysis lost NLX-INFOs
2175 (let ((form '(lambda ()
2176 (declare (optimize (speed 1) (space 0) (debug 2)
2177 (compilation-speed 0) (safety 1)))
2178 (flet ((%f3
(f3-1 &key
(key1 (count (floor 0 (min -
74 0)) #())))
2180 (apply #'%f3
0 nil
)))))
2181 (assert (zerop (funcall (compile nil form
)))))
2183 ;;; 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
2184 (compile nil
'(lambda ()
2185 (let ((x (make-array '(1) :element-type
'(signed-byte 32))))
2186 (setf (aref x
0) 1))))
2188 ;;; step instrumentation confusing the compiler, reported by Faré
2189 (handler-bind ((warning #'error
))
2190 (compile nil
'(lambda ()
2191 (declare (optimize (debug 2))) ; not debug 3!
2192 (let ((val "foobar"))
2193 (map-into (make-array (list (length val
))
2194 :element-type
'(unsigned-byte 8))
2195 #'char-code val
)))))
2197 ;;; overconfident primitive type computation leading to bogus type
2199 (let* ((form1 '(lambda (x)
2200 (declare (type (and condition function
) x
))
2202 (fun1 (compile nil form1
))
2204 (declare (type (and standard-object function
) x
))
2206 (fun2 (compile nil form2
)))
2207 (assert (raises-error?
(funcall fun1
(make-condition 'error
))))
2208 (assert (raises-error?
(funcall fun1 fun1
)))
2209 (assert (raises-error?
(funcall fun2 fun2
)))
2210 (assert (eq (funcall fun2
#'print-object
) #'print-object
)))
2212 ;;; LET* + VALUES declaration: while the declaration is a non-standard
2213 ;;; and possibly a non-conforming extension, as long as we do support
2214 ;;; it, we might as well get it right.
2216 ;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
2217 (compile nil
'(lambda () (let* () (declare (values list
)))))
2220 ;;; test for some problems with too large immediates in x86-64 modular
2222 (compile nil
'(lambda (x) (declare (fixnum x
))
2223 (logand most-positive-fixnum
(logxor x most-positive-fixnum
))))
2225 (compile nil
'(lambda (x) (declare (fixnum x
))
2226 (logand most-positive-fixnum
(+ x most-positive-fixnum
))))
2228 (compile nil
'(lambda (x) (declare (fixnum x
))
2229 (logand most-positive-fixnum
(* x most-positive-fixnum
))))
2232 (assert (let (warned-p)
2233 (handler-bind ((warning (lambda (w) (setf warned-p t
))))
2236 (list (let ((y (the real x
)))
2237 (unless (floatp y
) (error ""))
2239 (integer-length x
)))))
2242 ;; Dead / in safe code
2243 (with-test (:name
:safe-dead-
/)
2246 (funcall (compile nil
2248 (declare (optimize (safety 3)))
2253 (division-by-zero ()
2256 ;;; Dead unbound variable (bug 412)
2257 (with-test (:name
:dead-unbound
)
2260 (funcall (compile nil
2264 (unbound-variable ()
2267 ;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR.
2268 (handler-bind ((sb-ext:compiler-note
'error
))
2271 (funcall (compile nil
`(lambda (s p e
)
2272 (declare (optimize speed
)
2279 ;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR.
2280 (handler-bind ((sb-ext:compiler-note
'error
))
2283 (funcall (compile nil
`(lambda (s)
2284 (declare (optimize speed
)
2287 (vector 1 2 3 4)))))
2289 ;;; bug in adding DATA-VECTOR-REF-WITH-OFFSET to x86-64
2290 (assert (not (mismatch #(1.0f0
2.0f0
) (make-array 2 :element-type
'single-float
:initial-contents
(list 1.0f0
2.0f0
)))))
2292 ;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too
2293 ;;; large bignums to floats
2294 (dolist (op '(* / + -
))
2298 (declare (type (integer 0 #.
(* 2 (truncate most-positive-double-float
))) x
))
2301 do
(let ((arg (random (truncate most-positive-double-float
))))
2302 (assert (eql (funcall fun arg
)
2303 (funcall op
0.0d0 arg
)))))))
2305 (with-test (:name
:high-debug-known-function-inlining
)
2306 (let ((fun (compile nil
2308 (declare (optimize (debug 3)) (inline append
))
2309 (let ((fun (lambda (body)
2314 '((foo (bar)))))))))
2317 (with-test (:name
:high-debug-known-function-transform-with-optional-arguments
)
2318 (compile nil
'(lambda (x y
)
2319 (declare (optimize sb-c
::preserve-single-use-debug-variables
))
2321 (some-unknown-function
2323 (return (member x y
))))
2328 ;;; Compiling W-P-O when the pinned objects are known to be fixnums
2330 (compile nil
'(lambda (x y
)
2331 (declare (fixnum y
) (character x
))
2332 (sb-sys:with-pinned-objects
(x y
)
2333 (some-random-function))))
2335 ;;; *CHECK-CONSISTENCY* and TRULY-THE
2337 (with-test (:name
:bug-423
)
2338 (let ((sb-c::*check-consistency
* t
))
2339 (handler-bind ((warning #'error
))
2340 (flet ((make-lambda (type)
2344 (let ((q (truly-the list z
)))
2347 (let ((q (truly-the vector z
)))
2351 (compile nil
(make-lambda 'list
))
2352 (compile nil
(make-lambda 'vector
))))))
2354 ;;; this caused a momentary regression when an ill-adviced fix to
2355 ;;; bug 427 made ANY-REG suitable for primitive-type T:
2357 ;;; 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)
2358 ;;; [Condition of type SIMPLE-ERROR]
2365 (setf (sb-alien:deref
(sb-alien:cast
(sb-alien:sap-alien
(unknown1) (* unsigned-char
))
2366 (* double-float
))) frob
))
2368 (%zig
(the (values (single-float (0.0
) 1.0) &optional
) (unknown2)))
2372 ;;; non-required arguments in HANDLER-BIND
2373 (assert (eq :oops
(car (funcall (compile nil
2376 (handler-bind ((error (lambda (&rest args
) (return (cons :oops args
)))))
2380 ;;; NIL is a legal function name
2381 (assert (eq 'a
(flet ((nil () 'a
)) (nil))))