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 (handler-bind ((sb-ext:compiler-note
#'error
))
532 (compile nil
'(lambda (x)
533 (declare (type (simple-array (simple-string 3) (5)) x
))
534 (aref (aref x
0) 0))))
537 (let ((f (compile nil
'(lambda (x) (typep x
'(not (member 0d0
)))))))
538 (assert (funcall f
1d0
)))
540 (compile nil
'(lambda (x)
541 (declare (double-float x
))
545 ;;; bogus optimization of BIT-NOT
546 (multiple-value-bind (result x
)
547 (eval '(let ((x (eval #*1001)))
548 (declare (optimize (speed 2) (space 3))
549 (type (bit-vector) x
))
550 (values (bit-not x nil
) x
)))
551 (assert (equal x
#*1001))
552 (assert (equal result
#*0110)))
554 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
555 (handler-bind ((sb-ext:compiler-note
#'error
))
556 (assert (equalp (funcall
560 (let ((x (make-sequence 'vector
10 :initial-element
'a
)))
563 #(a a a a b a a a a a
))))
565 ;;; this is not a check for a bug, but rather a test of compiler
567 (dolist (type '((integer 0 *) ; upper bound
570 (real * (-10)) ; lower bound
575 (declare (optimize (speed 3) (compilation-speed 0)))
576 (loop for i from
1 to
(the (integer -
17 10) n
) by
2
577 collect
(when (> (random 10) 5)
578 (the ,type
(- i
11)))))))))
582 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
583 ;;; compiler has an optimized VOP for +; so this code should cause an
585 (assert (eq (block nil
587 (compile nil
'(lambda (i)
588 (declare (optimize speed
))
589 (declare (type integer i
))
591 (sb-ext:compiler-note
(c) (return :good
))))
594 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
596 (assert (not (nth-value 1 (compile nil
'(lambda (u v
)
597 (symbol-macrolet ((x u
)
603 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
604 (loop for
(x type
) in
607 (-14/3 (rational -
8 11))
616 (#c
(-3 4) (complex fixnum
))
617 (#c
(-3 4) (complex rational
))
618 (#c
(-3/7 4) (complex rational
))
619 (#c
(2s0 3s0
) (complex short-float
))
620 (#c
(2f0 3f0
) (complex single-float
))
621 (#c
(2d0 3d0
) (complex double-float
))
622 (#c
(2l0 3l0) (complex long-float
))
623 (#c
(2d0 3s0
) (complex float
))
624 (#c
(2 3f0
) (complex real
))
625 (#c
(2 3d0
) (complex real
))
626 (#c
(-3/7 4) (complex real
))
629 do
(dolist (zero '(0 0s0
0f0
0d0
0l0))
630 (dolist (real-zero (list zero
(- zero
)))
631 (let* ((src `(lambda (x) (expt (the ,type x
) ,real-zero
)))
632 (fun (compile nil src
))
633 (result (1+ (funcall (eval #'*) x real-zero
))))
634 (assert (eql result
(funcall fun x
)))))))
636 ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
637 ;;; wasn't recognized as a good type specifier.
638 (let ((fun (lambda (x y
)
639 (declare (type (integer -
1 0) x y
) (optimize speed
))
641 (assert (= (funcall fun
0 0) 0))
642 (assert (= (funcall fun
0 -
1) -
1))
643 (assert (= (funcall fun -
1 -
1) 0)))
645 ;;; from PFD's torture test, triggering a bug in our effective address
650 (declare (type (integer 8 22337) b
))
653 (* (logandc1 (max -
29303 b
) 4) b
)
654 (abs (logorc1 (+ (logandc1 -
11 b
) 2607688420) -
31153924)))
655 (logeqv (max a
0) b
))))
657 ;;; Alpha floating point modes weren't being reset after an exception,
658 ;;; leading to an exception on the second compile, below.
659 (compile nil
'(lambda (x y
) (declare (type (double-float 0.0d0
) x y
)) (/ x y
)))
660 (handler-case (/ 1.0 0.0)
661 ;; provoke an exception
662 (arithmetic-error ()))
663 (compile nil
'(lambda (x y
) (declare (type (double-float 0.0d0
) x y
)) (/ x y
)))
665 ;;; bug reported by Paul Dietz: component last block does not have
669 (declare (notinline + logand
)
670 (optimize (speed 0)))
674 (RETURN-FROM B5 -
220)))
676 (+ 359749 35728422))))
679 ;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
680 (assert (= (funcall (compile nil
`(lambda (b)
681 (declare (optimize (speed 3))
682 (type (integer 2 152044363) b
))
683 (rem b
(min -
16 0))))
687 (assert (= (funcall (compile nil
`(lambda (c)
688 (declare (optimize (speed 3))
689 (type (integer 23062188 149459656) c
))
694 ;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
698 (LOGEQV (REM C -
6758)
699 (REM B
(MAX 44 (RETURN-FROM B6 A
)))))))
701 (compile nil
'(lambda ()
703 (flet ((foo (x y
) (if (> x y
) (print x
) (print y
))))
706 (foo (return 14) 2)))))
708 ;;; bug in Alpha backend: not enough sanity checking of arguments to
710 (assert (= (funcall (compile nil
717 ;;; bug found by WHN and pfdietz: compiler failure while referencing
718 ;;; an entry point inside a deleted lambda
719 (compile nil
'(lambda ()
724 (flet ((truly (fn bbd
)
728 (multiple-value-prog1
745 (wum #'bbfn
"hc3" (list)))
747 (compile nil
'(lambda () (flet ((%f
() (unwind-protect nil
))) nil
)))
749 ;;; the strength reduction of constant multiplication used (before
750 ;;; sbcl-0.8.4.x) to lie to the compiler. This meant that, under
751 ;;; certain circumstances, the compiler would derive that a perfectly
752 ;;; reasonable multiplication never returned, causing chaos. Fixed by
753 ;;; explicitly doing modular arithmetic, and relying on the backends
758 (declare (type (integer 178956970 178956970) x
)
764 ;;; bug in modular arithmetic and type specifiers
765 (assert (= (funcall (compile nil
(lambda (x) (logand x x
0)))
769 ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP
770 ;;; produced wrong result for shift >=32 on X86
771 (assert (= 0 (funcall
774 (declare (type (integer 4303063 101130078) a
))
775 (mask-field (byte 18 2) (ash a
77))))
777 ;;; rewrite the test case to get the unsigned-byte 32/64
778 ;;; implementation even after implementing some modular arithmetic
779 ;;; with signed-byte 30:
780 (assert (= 0 (funcall
783 (declare (type (integer 4303063 101130078) a
))
784 (mask-field (byte 30 2) (ash a
77))))
786 (assert (= 0 (funcall
789 (declare (type (integer 4303063 101130078) a
))
790 (mask-field (byte 64 2) (ash a
77))))
792 ;;; and a similar test case for the signed masking extension (not the
793 ;;; final interface, so change the call when necessary):
794 (assert (= 0 (funcall
797 (declare (type (integer 4303063 101130078) a
))
798 (sb-c::mask-signed-field
30 (ash a
77))))
800 (assert (= 0 (funcall
803 (declare (type (integer 4303063 101130078) a
))
804 (sb-c::mask-signed-field
61 (ash a
77))))
807 ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
808 ;;; type check regeneration
809 (assert (eql (funcall
810 (compile nil
'(lambda (a c
)
811 (declare (type (integer 185501219873 303014665162) a
))
812 (declare (type (integer -
160758 255724) c
))
813 (declare (optimize (speed 3)))
815 (- -
554046873252388011622614991634432
817 (unwind-protect 2791485))))
818 (max (ignore-errors a
)
819 (let ((v6 (- v8
(restart-case 980))))
823 (assert (eql (funcall
824 (compile nil
'(lambda (a b
)
832 (load-time-value -
6876935))))
833 (if (logbitp 1 a
) b
(setq a -
1522022182249))))))))
834 -
1802767029877 -
12374959963)
837 ;;; various MISC.*, related to NODEs/LVARs with derived type NIL
838 (assert (eql (funcall (compile nil
'(lambda (c)
839 (declare (type (integer -
3924 1001809828) c
))
840 (declare (optimize (speed 3)))
841 (min 47 (if (ldb-test (byte 2 14) c
)
843 (ignore-errors -
732893970)))))
846 (assert (eql (funcall
847 (compile nil
'(lambda (b)
848 (declare (type (integer -
1598566306 2941) b
))
849 (declare (optimize (speed 3)))
850 (max -
148949 (ignore-errors b
))))
853 (assert (eql (funcall
854 (compile nil
'(lambda (b c
)
855 (declare (type (integer -
4 -
3) c
))
857 (flet ((%f1
(f1-1 f1-2 f1-3
)
858 (if (logbitp 0 (return-from b7
859 (- -
815145138 f1-2
)))
860 (return-from b7 -
2611670)
862 (let ((v2 (%f1 -
2464 (%f1 -
1146 c c
) -
2)))
866 (assert (eql (funcall
869 (declare (type (integer -
29742055786 23602182204) b
))
870 (declare (type (integer -
7409 -
2075) c
))
871 (declare (optimize (speed 3)))
875 (ignore-errors (return-from b6
876 (if (= c
8) b
82674))))))
880 (assert (equal (multiple-value-list
882 (compile nil
'(lambda (a)
883 (declare (type (integer -
944 -
472) a
))
884 (declare (optimize (speed 3)))
888 (if (= 55957 a
) -
117 (ignore-errors
889 (return-from b3 a
))))))))
894 (assert (zerop (funcall
897 (declare (type (integer 79828 2625480458) a
))
898 (declare (type (integer -
4363283 8171697) b
))
899 (declare (type (integer -
301 0) c
))
900 (if (equal 6392154 (logxor a b
))
904 (logior (logandc2 c v5
)
905 (common-lisp:handler-case
906 (ash a
(min 36 22477)))))))))
909 ;;; MISC.152, 153: deleted code and iteration var type inference
910 (assert (eql (funcall
914 (let ((v1 (let ((v8 (unwind-protect 9365)))
918 (labels ((%f11
(f11-1) f11-1
))
922 (labels ((%f6
(f6-1 f6-2 f6-3
) v1
))
923 (dpb (unwind-protect a
)
925 (labels ((%f4
() 27322826))
926 (%f6 -
2 -
108626545 (%f4
))))))))))))
930 (assert (eql (funcall
935 ((-96879 -
1035 -
57680 -
106404 -
94516 -
125088)
936 (unwind-protect 90309179))
937 ((-20811 -
86901 -
9368 -
98520 -
71594)
938 (let ((v9 (unwind-protect 136707)))
941 (let ((v4 (return-from b3 v9
)))
942 (- (ignore-errors (return-from b3 v4
))))))))
950 (assert (eql (funcall
961 &optional
(f17-4 185155520) (f17-5 c
)
964 (%f17 -
1046 a
1115306 (%f17 b -
146330 422) -
337817)))
965 (f15-5 a
) (f15-6 -
40))
966 (return-from b3 -
16)))
967 (multiple-value-call #'%f15
(values -
519354 a
121 c -
1905))))))
972 (assert (eql (funcall
976 (declare (notinline list apply
))
977 (declare (optimize (safety 3)))
978 (declare (optimize (speed 0)))
979 (declare (optimize (debug 0)))
980 (labels ((%f12
(f12-1 f12-2
)
981 (labels ((%f2
(f2-1 f2-2
)
988 (return-from %f12 b
)))
991 (%f18
(%f18
150 -
64 f12-1
)
998 &optional
(f7-3 (%f6
)))
1001 (%f2 b -
36582571))))
1002 (apply #'%f12
(list 774 -
4413)))))
1007 (assert (eql (funcall
1011 (declare (notinline values
))
1012 (declare (optimize (safety 3)))
1013 (declare (optimize (speed 0)))
1014 (declare (optimize (debug 0)))
1017 &optional
(f11-3 c
) (f11-4 7947114)
1019 (flet ((%f3
(f3-1 &optional
(f3-2 b
) (f3-3 5529))
1021 (multiple-value-call #'%f3
1022 (values (%f3 -
30637724 b
) c
)))))
1024 (if (and nil
(%f11 a a
))
1025 (if (%f11 a
421778 4030 1)
1031 (%f11 c a c -
4 214720)
1043 ;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
1044 ;;; local lambda argument
1050 (declare (type (integer 804561 7640697) a
))
1051 (declare (type (integer -
1 10441401) b
))
1052 (declare (type (integer -
864634669 55189745) c
))
1053 (declare (ignorable a b c
))
1054 (declare (optimize (speed 3)))
1055 (declare (optimize (safety 1)))
1056 (declare (optimize (debug 1)))
1059 (labels ((%f4
() (round 200048 (max 99 c
))))
1062 (labels ((%f3
(f3-1) -
162967612))
1063 (%f3
(let* ((v8 (%f4
)))
1064 (setq f11-1
(%f4
)))))))))
1065 (%f11 -
120429363 (%f11
62362 b
)))))
1066 6714367 9645616 -
637681868)
1069 ;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
1071 (assert (equal (multiple-value-list
1073 (compile nil
'(lambda ()
1074 (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
1077 (flet ((%f16
() 0)) (%f16
))))))))
1086 (declare (type (integer 867934833 3293695878) a
))
1087 (declare (type (integer -
82111 1776797) b
))
1088 (declare (type (integer -
1432413516 54121964) c
))
1089 (declare (optimize (speed 3)))
1090 (declare (optimize (safety 1)))
1091 (declare (optimize (debug 1)))
1093 (flet ((%f15
(f15-1 &optional
(f15-2 c
))
1094 (labels ((%f1
(f1-1 f1-2
) 0))
1097 (multiple-value-call #'%f15
1098 (values (%f15 c
0) (%f15
0)))))
1100 (flet ((%f8
(f8-1 &optional
(f8-2 (%f4
)) (f8-3 0))
1104 3040851270 1664281 -
1340106197)))
1112 (declare (notinline <=))
1113 (declare (optimize (speed 2) (space 3) (safety 0)
1114 (debug 1) (compilation-speed 3)))
1115 (if (if (<= 0) nil nil
)
1116 (labels ((%f9
(f9-1 f9-2 f9-3
)
1118 (dotimes (iv4 5 a
) (%f9
0 0 b
)))
1122 ;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
1128 (declare (type (integer 177547470 226026978) a
))
1129 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
1130 (compilation-speed 1)))
1131 (logand a
(* a
438810))))
1136 ;;;; Bugs in stack analysis
1137 ;;; bug 299 (reported by PFD)
1143 (declare (optimize (debug 1)))
1144 (multiple-value-call #'list
1145 (if (eval t
) (eval '(values :a
:b
:c
)) nil
)
1146 (catch 'foo
(throw 'foo
(values :x
:y
)))))))
1148 ;;; bug 298 (= MISC.183)
1149 (assert (zerop (funcall
1153 (declare (type (integer -
368154 377964) a
))
1154 (declare (type (integer 5044 14959) b
))
1155 (declare (type (integer -
184859815 -
8066427) c
))
1156 (declare (ignorable a b c
))
1157 (declare (optimize (speed 3)))
1158 (declare (optimize (safety 1)))
1159 (declare (optimize (debug 1)))
1161 (flet ((%f3
(f3-1 f3-2 f3-3
) 0))
1162 (apply #'%f3
0 (catch 'foo
(return-from b7
(%f3
0 b c
))) c nil
)))))
1164 (assert (equal (eval '(let () (apply #'list
1 (list (catch 'a
(throw 'a
(block b
2)))))))
1170 (multiple-value-call #'list
1174 (multiple-value-call #'list
1180 (return-from quux
1)
1181 (throw 'baz
2))))))))))))))
1182 (assert (equal (funcall f t
) '(:b
1)))
1183 (assert (equal (funcall f nil
) '(:a
2))))
1191 (declare (type (integer 5 155656586618) a
))
1192 (declare (type (integer -
15492 196529) b
))
1193 (declare (type (integer 7 10) c
))
1194 (declare (optimize (speed 3)))
1195 (declare (optimize (safety 1)))
1196 (declare (optimize (debug 1)))
1199 &optional
(f3-4 a
) (f3-5 0)
1201 (labels ((%f10
(f10-1 f10-2 f10-3
)
1206 (- (if (equal a b
) b
(%f10 c a
0))
1207 (catch 'ct2
(throw 'ct2 c
)))
1210 (%f3
(%f3
(%f3 b
0 0 0) a
0) a b b b c
)))) 5 0 7)
1215 '(let* ((form '(labels ((%f3
(f3-1 f3-2
) f3-1
))
1216 (apply #'%f3 b
(catch 'ct8
(throw 'ct8
(logeqv (%f3 c
0)))) nil
)))
1219 (declare (type (integer -
2 19) b
)
1220 (type (integer -
1520 218978) c
)
1221 (optimize (speed 3) (safety 1) (debug 1)))
1224 (declare (notinline logeqv apply
)
1225 (optimize (safety 3) (speed 0) (debug 0)))
1227 (cf1 (compile nil fn1
))
1228 (cf2 (compile nil fn2
))
1229 (result1 (multiple-value-list (funcall cf1
2 18886)))
1230 (result2 (multiple-value-list (funcall cf2
2 18886))))
1231 (if (equal result1 result2
)
1233 (values result1 result2
))))
1243 (optimize (speed 3) (space 3) (safety 1)
1244 (debug 2) (compilation-speed 0)))
1245 (apply (constantly 0) (catch 'ct2
0) 0 (catch 'ct2
0) nil
))))))
1248 (assert (zerop (funcall
1252 (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
1253 (compilation-speed 2)))
1254 (apply (constantly 0)
1258 (apply (constantly 0)
1277 (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
1278 (multiple-value-prog1
1279 (the integer
(catch 'ct8
(catch 'ct7
15867134)))
1280 (catch 'ct1
(throw 'ct1
0))))))
1283 ;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
1284 ;;; could transform known-values LVAR to UVL
1285 (assert (zerop (funcall
1289 (declare (notinline boole values denominator list
))
1295 (compilation-speed 2)))
1300 (let ((v9 (ignore-errors (throw 'ct6
0))))
1302 (progv nil nil
(values (boole boole-and
0 v9
)))))))))
1305 ;;; non-continuous dead UVL blocks
1306 (defun non-continuous-stack-test (x)
1307 (multiple-value-call #'list
1308 (eval '(values 11 12))
1309 (eval '(values 13 14))
1311 (return-from non-continuous-stack-test
1312 (multiple-value-call #'list
1313 (eval '(values :b1
:b2
))
1314 (eval '(values :b3
:b4
))
1317 (multiple-value-call (eval #'values
)
1318 (eval '(values 1 2))
1319 (eval '(values 3 4))
1322 (multiple-value-call (eval #'values
)
1323 (eval '(values :a1
:a2
))
1324 (eval '(values :a3
:a4
))
1327 (multiple-value-call (eval #'values
)
1328 (eval '(values 5 6))
1329 (eval '(values 7 8))
1332 (return-from int
:int
))))))))))))))))
1333 (assert (equal (non-continuous-stack-test t
) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext
)))
1334 (assert (equal (non-continuous-stack-test nil
) '(:b1
:b2
:b3
:b4
:a1
:a2
:a3
:a4
:int
)))
1336 ;;; MISC.362: environment of UNWIND-PROTECTor is different from that
1338 (assert (equal (multiple-value-list (funcall
1342 (declare (optimize (speed 3) (space 3) (safety 2)
1343 (debug 2) (compilation-speed 3)))
1346 (labels ((%f15
(f15-1 f15-2 f15-3
)
1347 (rational (throw 'ct5
0))))
1353 (progv '(*s2
* *s5
*) (list 0 (%f15
0 g
0)) b
)
1357 (common-lisp:handler-case
0)))))
1369 (declare (notinline funcall min coerce
))
1375 (compilation-speed 1)))
1376 (flet ((%f12
(f12-1)
1379 (if f12-1
(multiple-value-prog1
1380 b
(return-from %f12
0))
1383 (funcall #'%f12
0))))
1386 ;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
1387 ;;; potential problem: optimizers and type derivers for MAX and MIN
1388 ;;; were not consistent in treating EQUALP, but not EQL, arguments.
1389 (dolist (f '(min max
))
1390 (loop for complex-arg-args in
'((1d0 2d0
) (0d0 1d0
))
1391 for complex-arg
= `(if x
,@complex-arg-args
)
1393 (loop for args in
`((1 ,complex-arg
)
1395 for form
= `(,f
,@args
)
1396 for f1
= (compile nil
`(lambda (x) ,form
))
1397 and f2
= (compile nil
`(lambda (x) (declare (notinline min max
))
1400 (dolist (x '(nil t
))
1401 (assert (eql (funcall f1 x
) (funcall f2 x
)))))))
1404 (handler-case (compile nil
'(lambda (x)
1405 (declare (optimize (speed 3) (safety 0)))
1406 (the double-float
(sqrt (the double-float x
)))))
1407 (sb-ext:compiler-note
(c)
1408 ;; Ignore the note for the float -> pointer conversion of the
1410 (unless (string= (car (last (sb-c::simple-condition-format-arguments c
)))
1412 (error "Compiler does not trust result type assertion."))))
1414 (let ((f (compile nil
'(lambda (x)
1415 (declare (optimize speed
(safety 0)))
1418 (multiple-value-prog1
1419 (sqrt (the double-float x
))
1421 (return :minus
)))))))))
1422 (assert (eql (funcall f -
1d0
) :minus
))
1423 (assert (eql (funcall f
4d0
) 2d0
)))
1425 ;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
1427 (compile nil
'(lambda (a i
)
1429 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
1430 (inhibit-warnings 0)))
1431 (declare (type (alien (* (unsigned 8))) a
)
1432 (type (unsigned-byte 32) i
))
1434 (compiler-note () (error "The code is not optimized.")))
1437 (compile nil
'(lambda (x)
1438 (declare (type (integer -
100 100) x
))
1439 (declare (optimize speed
))
1440 (declare (notinline identity
))
1442 (compiler-note () (error "IDENTITY derive-type not applied.")))
1444 (assert (null (funcall (compile nil
'(lambda (x) (funcall #'cddr x
))) nil
)))
1446 ;;; MISC.293 = easy variant of bug 303: repeated write to the same
1447 ;;; LVAR; here the first write may be cleared before the second is
1455 (declare (notinline complex
))
1456 (declare (optimize (speed 1) (space 0) (safety 1)
1457 (debug 3) (compilation-speed 3)))
1458 (flet ((%f
() (multiple-value-prog1 0 (return-from %f
0))))
1459 (complex (%f
) 0)))))))
1461 ;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
1462 (assert (zerop (funcall
1466 (declare (type (integer -
1294746569 1640996137) a
))
1467 (declare (type (integer -
807801310 3) c
))
1468 (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
1475 (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7
0))) 0 0) 0))))
1477 391833530 -
32785211)))
1479 ;;; efficiency notes for ordinary code
1480 (macrolet ((frob (arglist &body body
)
1483 (compile nil
'(lambda ,arglist
,@body
))
1484 (sb-ext:compiler-note
(e)
1485 (error "bad compiler note for ~S:~% ~A" ',body e
)))
1488 (compile nil
'(lambda ,arglist
(declare (optimize speed
))
1490 (sb-ext:compiler-note
(e) (throw :got-note nil
)))
1491 (error "missing compiler note for ~S" ',body
)))))
1492 (frob (x) (funcall x
))
1493 (frob (x y
) (find x y
))
1494 (frob (x y
) (find-if x y
))
1495 (frob (x y
) (find-if-not x y
))
1496 (frob (x y
) (position x y
))
1497 (frob (x y
) (position-if x y
))
1498 (frob (x y
) (position-if-not x y
))
1499 (frob (x) (aref x
0)))
1501 (macrolet ((frob (style-warn-p form
)
1503 `(catch :got-style-warning
1506 (style-warning (e) (throw :got-style-warning nil
)))
1507 (error "missing style-warning for ~S" ',form
))
1511 (error "bad style-warning for ~S: ~A" ',form e
))))))
1512 (frob t
(lambda (x &optional y
&key z
) (list x y z
)))
1513 (frob nil
(lambda (x &optional y z
) (list x y z
)))
1514 (frob nil
(lambda (x &key y z
) (list x y z
)))
1515 (frob t
(defgeneric #:foo
(x &optional y
&key z
)))
1516 (frob nil
(defgeneric #:foo
(x &optional y z
)))
1517 (frob nil
(defgeneric #:foo
(x &key y z
)))
1518 (frob t
(defun #:foo
(x) (flet ((foo (x &optional y
&key z
) (list x y z
))) (foo x x
:z x
)))))
1520 ;;; this was a bug in the LOGXOR type deriver. The top form gave a
1521 ;;; note, because the system failed to derive the fact that the return
1522 ;;; from LOGXOR was small and negative, though the bottom one worked.
1523 (handler-bind ((sb-ext:compiler-note
#'error
))
1524 (compile nil
'(lambda ()
1525 (declare (optimize speed
(safety 0)))
1527 (declare (type (integer 3 6) x
)
1528 (type (integer -
6 -
3) y
))
1529 (+ (logxor x y
) most-positive-fixnum
)))))
1530 (handler-bind ((sb-ext:compiler-note
#'error
))
1531 (compile nil
'(lambda ()
1532 (declare (optimize speed
(safety 0)))
1534 (declare (type (integer 3 6) y
)
1535 (type (integer -
6 -
3) x
))
1536 (+ (logxor x y
) most-positive-fixnum
)))))
1538 ;;; check that modular ash gives the right answer, to protect against
1539 ;;; possible misunderstandings about the hardware shift instruction.
1540 (assert (zerop (funcall
1541 (compile nil
'(lambda (x y
)
1542 (declare (optimize speed
)
1543 (type (unsigned-byte 32) x y
))
1544 (logand #xffffffff
(ash x y
))))
1547 ;;; code instrumenting problems
1550 (declare (optimize (debug 3)))
1551 (list (the integer
(if nil
14 t
)))))
1555 (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD
))
1561 (COMPILATION-SPEED 0)))
1562 (MASK-FIELD (BYTE 7 26)
1564 (TAGBODY (THE INTEGER
(CATCH 'CT4
(LOGORC1 C -
15950))) 1)
1568 '(lambda (buffer i end
)
1569 (declare (optimize (debug 3)))
1570 (loop (when (not (eql 0 end
)) (return)))
1571 (let ((s (make-string end
)))
1572 (setf (schar s i
) (schar buffer i
))
1575 ;;; check that constant string prefix and suffix don't cause the
1576 ;;; compiler to emit code deletion notes.
1577 (handler-bind ((sb-ext:code-deletion-note
#'error
))
1578 (compile nil
'(lambda (s x
)
1579 (pprint-logical-block (s x
:prefix
"(")
1581 (compile nil
'(lambda (s x
)
1582 (pprint-logical-block (s x
:per-line-prefix
";")
1584 (compile nil
'(lambda (s x
)
1585 (pprint-logical-block (s x
:suffix
">")
1588 ;;; MISC.427: loop analysis requires complete DFO structure
1589 (assert (eql 17 (funcall
1593 (declare (notinline list reduce logior
))
1594 (declare (optimize (safety 2) (compilation-speed 1)
1595 (speed 3) (space 2) (debug 2)))
1597 (let* ((v5 (reduce #'+ (list 0 a
))))
1598 (declare (dynamic-extent v5
))
1603 (assert (zerop (funcall
1607 (declare (type (integer -
8431780939320 1571817471932) a
))
1608 (declare (type (integer -
4085 0) b
))
1609 (declare (ignorable a b
))
1612 (compilation-speed 0)
1613 #+sbcl
(sb-c:insert-step-conditions
0)
1620 (elt '(1954479092053)
1624 (lognand iv1
(ash iv1
(min 53 iv1
)))
1627 -
7639589303599 -
1368)))
1632 (declare (type (integer) a
))
1633 (declare (type (integer) b
))
1634 (declare (ignorable a b
))
1635 (declare (optimize (space 2) (compilation-speed 0)
1636 (debug 0) (safety 0) (speed 3)))
1638 (when (< iv1
2) (print 'x
)) ;; request for second constraint propagation pass
1639 (print (if (< iv1 iv1
)
1640 (logand (ash iv1 iv1
) 1)
1643 ;;; MISC.435: lambda var substitution in a deleted code.
1644 (assert (zerop (funcall
1648 (declare (notinline aref logandc2 gcd make-array
))
1650 (optimize (space 0) (safety 0) (compilation-speed 3)
1651 (speed 3) (debug 1)))
1654 (let* ((v2 (make-array nil
:initial-element
(catch 'ct1
(go tag2
)))))
1655 (declare (dynamic-extent v2
))
1656 (gcd (go tag2
) (logandc2 (catch 'ct2 c
) (aref v2
))))
1659 3021871717588 -
866608 -
2 -
17194)))
1661 ;;; MISC.436, 438: lost reoptimization
1662 (assert (zerop (funcall
1666 (declare (type (integer -
2917822 2783884) a
))
1667 (declare (type (integer 0 160159) b
))
1668 (declare (ignorable a b
))
1670 (optimize (compilation-speed 1)
1674 ; #+sbcl (sb-c:insert-step-conditions 0)
1688 '(-10197561 486 430631291
1694 (assert (zerop (funcall
1698 (declare (type (integer 0 1696) a
))
1699 ; (declare (ignorable a))
1700 (declare (optimize (space 2) (debug 0) (safety 1)
1701 (compilation-speed 0) (speed 1)))
1702 (if (logbitp 0 (ash (1- a
) (min 11 a
))) 0 0)))
1709 (declare (type (simple-array function
(2)) s
) (type ei ei
))
1710 (funcall (aref s ei
) x y
))))
1712 ;;; MISC.320: ir1-transform can create an intercomponent reference to
1714 (assert (eql 102 (funcall
1718 (declare (optimize (speed 3) (space 0) (safety 2)
1719 (debug 2) (compilation-speed 0)))
1722 (flet ((%f12
() (rem 0 -
43)))
1723 (multiple-value-call #'%f12
(values))))))))))
1725 ;;; MISC.437: lost reoptimization after FLUSH-DEST
1726 (assert (zerop (funcall
1729 '(lambda (a b c d e
)
1730 (declare (notinline values complex eql
))
1732 (optimize (compilation-speed 3)
1739 &optional
(f10-4 (ignore-errors 0)) (f10-5 0)
1740 &key
&allow-other-keys
)
1741 (if (or (eql 0 0) t
) 0 (if f10-1
0 0))))
1742 (complex (multiple-value-call #'%f10
(values a c b
0 0)) 0))))
1743 80043 74953652306 33658947 -
63099937105 -
27842393)))
1745 ;;; bug #351 -- program-error for malformed LET and LET*, including those
1746 ;;; resulting from SETF of LET.
1747 (dolist (fun (list (compile nil
'(lambda () (let :bogus-let
:oops
)))
1748 (compile nil
'(lambda () (let* :bogus-let
* :oops
)))
1749 (compile nil
'(lambda (x) (push x
(let ((y 0)) y
))))))
1750 (assert (functionp fun
))
1751 (multiple-value-bind (res err
) (ignore-errors (funcall fun
))
1753 (assert (typep err
'program-error
))))
1755 (let ((fun (compile nil
'(lambda (x) (random (if x
10 20))))))
1756 (dotimes (i 100 (error "bad RANDOM distribution"))
1757 (when (> (funcall fun nil
) 9)
1760 (when (> (funcall fun t
) 9)
1761 (error "bad RANDOM event"))))
1763 ;;; 0.8.17.28-sma.1 lost derived type information.
1764 (with-test (:name
"0.8.17.28-sma.1" :fails-on
:sparc
)
1765 (handler-bind ((sb-ext:compiler-note
(lambda (c) (error "~A" c
))))
1768 (declare (optimize (speed 3) (safety 0)))
1769 (declare (type (integer 0 80) x
)
1770 (type (integer 0 11) y
)
1771 (type (simple-array (unsigned-byte 32) (*)) v
))
1772 (setf (aref v
0) (* (* x
#.
(floor (ash 1 32) (* 11 80))) y
))
1775 ;;; Bug reported by Robert J. Macomber: instrumenting of more-entry
1776 ;;; prevented open coding of %LISTIFY-REST-ARGS.
1777 (let ((f (compile nil
'(lambda ()
1778 (declare (optimize (debug 3)))
1779 (with-simple-restart (blah "blah") (error "blah"))))))
1780 (handler-bind ((error (lambda (c) (invoke-restart 'blah
))))
1781 (assert (equal (multiple-value-list (funcall f
)) '(nil t
)))))
1783 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
1784 ;;; constant index and value.
1785 (loop for n-bits
= 1 then
(* n-bits
2)
1786 for type
= `(unsigned-byte ,n-bits
)
1787 and v-max
= (1- (ash 1 n-bits
))
1788 while
(<= n-bits sb-vm
:n-word-bits
)
1790 (let* ((n (* 2 (1+ (- sb-vm
::n-word-bits n-bits
))))
1791 (array1 (make-array n
:element-type type
))
1792 (array2 (make-array n
:element-type type
)))
1794 (dolist (v (list 0 v-max
))
1795 (let ((f (compile nil
`(lambda (a)
1796 (declare (type (simple-array ,type
(,n
)) a
))
1797 (setf (aref a
,i
) ,v
)))))
1798 (fill array1
(- v-max v
))
1799 (fill array2
(- v-max v
))
1801 (setf (aref array2 i
) v
)
1802 (assert (every #'= array1 array2
)))))))
1804 (let ((fn (compile nil
'(lambda (x)
1805 (declare (type bit x
))
1806 (declare (optimize speed
))
1807 (let ((b (make-array 64 :element-type
'bit
1808 :initial-element
0)))
1810 (assert (= (funcall fn
0) 64))
1811 (assert (= (funcall fn
1) 0)))
1813 (let ((fn (compile nil
'(lambda (x y
)
1814 (declare (type simple-bit-vector x y
))
1815 (declare (optimize speed
))
1819 (make-array 64 :element-type
'bit
:initial-element
0)
1820 (make-array 64 :element-type
'bit
:initial-element
0)))
1824 (make-array 64 :element-type
'bit
:initial-element
0)
1825 (let ((b (make-array 64 :element-type
'bit
:initial-element
0)))
1826 (setf (sbit b
63) 1)
1829 ;;; MISC.535: compiler failure
1830 (let ((c0 #c
(4196.088977268509d0 -
15943.3603515625d0
)))
1831 (assert (not (funcall
1835 (declare (optimize speed
(safety 1))
1838 (eql (the (complex double-float
) p1
) p2
)))
1839 c0
#c
(12 612/979)))))
1841 ;;; reported by Lutz Euler: we shouldn't signal a compiler note for
1842 ;;; simple-bit-vector functions.
1843 (handler-bind ((sb-ext:compiler-note
#'error
))
1844 (compile nil
'(lambda (x)
1845 (declare (type simple-bit-vector x
))
1847 (handler-bind ((sb-ext:compiler-note
#'error
))
1848 (compile nil
'(lambda (x y
)
1849 (declare (type simple-bit-vector x y
))
1852 ;;; MISC.550: CAST merging in IR1 finalization caused unexpected
1853 ;;; code transformations.
1854 (assert (eql (funcall
1858 (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
1861 (or p1
(the (eql t
) p2
))))
1865 ;;; MISC.548: type check weakening converts required type into
1872 (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
1873 (atom (the (member f assoc-if write-line t w
) p1
))))
1876 ;;; Free special bindings only apply to the body of the binding form, not
1877 ;;; the initialization forms.
1879 (funcall (compile 'nil
1882 (declare (special x
))
1884 ((lambda (&optional
(y x
))
1885 (declare (special x
)) y
)))))))))
1887 ;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
1888 ;;; a rational was zero, but didn't do the substitution, leading to a
1889 ;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
1890 ;;; machine's ASH instruction's immediate field) that the compiler
1891 ;;; thought was legitimate.
1893 ;;; FIXME: this has been recorded as bug 383. The attempted fix (sbcl
1894 ;;; 0.9.2.6) led to lots of spurious optimization notes. So the bug stil
1895 ;;; exist and this test case serves as a reminder of the problem.
1896 ;;; --njf, 2005-07-05
1900 (DECLARE (TYPE (INTEGER -
2 14) B
))
1901 (DECLARE (IGNORABLE B
))
1902 (ASH (IMAGPART B
) 57)))
1904 ;;; bug reported by Eduardo Mu\~noz
1905 (multiple-value-bind (fun warnings failure
)
1906 (compile nil
'(lambda (struct first
)
1907 (declare (optimize speed
))
1908 (let* ((nodes (nodes struct
))
1909 (bars (bars struct
))
1910 (length (length nodes
))
1911 (new (make-array length
:fill-pointer
0)))
1912 (vector-push first new
)
1913 (loop with i fixnum
= 0
1914 for newl fixnum
= (length new
)
1915 while
(< newl length
) do
1916 (let ((oldl (length new
)))
1917 (loop for j fixnum from i below newl do
1918 (dolist (n (node-neighbours (aref new j
) bars
))
1919 (unless (find n new
)
1920 (vector-push n new
))))
1923 (declare (ignore fun warnings failure
))
1924 (assert (not failure
)))
1926 ;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe
1928 (compile nil
'(lambda (x y a b c
)
1929 (- y
(* (signum x
) (sqrt (abs (- (* b x
) c
)))))))
1931 ;;; Type inference from CHECK-TYPE
1932 (let ((count0 0) (count1 0))
1933 (handler-bind ((sb-ext:compiler-note
(lambda (c) (incf count0
))))
1934 (compile nil
'(lambda (x)
1935 (declare (optimize (speed 3)))
1937 ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note
1938 (assert (> count0
1))
1939 (handler-bind ((sb-ext:compiler-note
(lambda (c) (incf count1
))))
1940 (compile nil
'(lambda (x)
1941 (declare (optimize (speed 3)))
1942 (check-type x fixnum
)
1944 ;; Only the posssible word -> bignum conversion note
1945 (assert (= count1
1)))
1947 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
1948 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
1949 (with-test (:name
:sap-ref-float
)
1950 (compile nil
'(lambda (sap)
1951 (let ((x (setf (sb-vm::sap-ref-double sap
0) 1d0
)))
1953 (compile nil
'(lambda (sap)
1954 (let ((x (setf (sb-vm::sap-ref-single sap
0) 1d0
)))
1958 (with-test (:name
:string-union-types
)
1959 (compile nil
'(lambda (x)
1960 (declare (type (or (simple-array character
(6))
1961 (simple-array character
(5))) x
))
1964 ;;; MISC.623: missing functions for constant-folding
1970 (declare (optimize (space 2) (speed 0) (debug 2)
1971 (compilation-speed 3) (safety 0)))
1972 (loop for lv3 below
1
1974 (loop for lv2 below
2
1976 (bit #*1001101001001
1977 (min 12 (max 0 lv3
))))))))))))
1979 ;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs
1985 (declare (type (integer 21 28) a
))
1986 (declare (optimize (compilation-speed 1) (safety 2)
1987 (speed 0) (debug 0) (space 1)))
1988 (let* ((v7 (flet ((%f3
(f3-1 f3-2
)
1989 (loop for lv2 below
1
1993 (min 7 (max 0 (eval '0))))))))
1998 ;;; MISC.626: bandaged AVER was still wrong
1999 (assert (eql -
829253
2004 (declare (type (integer -
902970 2) a
))
2005 (declare (optimize (space 2) (debug 0) (compilation-speed 1)
2006 (speed 0) (safety 3)))
2007 (prog2 (if (logbitp 30 a
) 0 (block b3
0)) a
)))
2010 ;; MISC.628: constant-folding %LOGBITP was buggy
2016 (declare (optimize (safety 3) (space 3) (compilation-speed 3)
2017 (speed 0) (debug 1)))
2018 (not (not (logbitp 0 (floor 2147483651 (min -
23 0))))))))))
2020 ;; mistyping found by random-tester
2026 (declare (optimize (speed 1) (debug 0)
2027 (space 2) (safety 0) (compilation-speed 0)))
2029 (* (/ (multiple-value-prog1 -
29457482 -
5602513511) 1))))))))
2031 ;; aggressive constant folding (bug #400)
2033 (eq t
(funcall (compile nil
'(lambda () (or t
(the integer
(/ 1 0))))))))
2035 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-non-var-1
))
2038 (compile nil
'(lambda (x y
)
2039 (when (eql x
(length y
))
2041 (declare (optimize (speed 3)))
2043 (compiler-note () (error "The code is not optimized.")))))
2045 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-non-var-2
))
2048 (compile nil
'(lambda (x y
)
2049 (when (eql (length y
) x
)
2051 (declare (optimize (speed 3)))
2053 (compiler-note () (error "The code is not optimized.")))))
2055 (with-test (:name
(:compiler
:constraint-propagation
:float-bounds-1
))
2057 (compile nil
'(lambda (x)
2058 (declare (type (single-float * (3.0
)) x
))
2062 (compiler-note () (error "Deleted reachable code."))))
2064 (with-test (:name
(:compiler
:constraint-propagation
:float-bounds-2
))
2067 (compile nil
'(lambda (x)
2068 (declare (type single-float x
))
2071 (error "This is unreachable.")))))
2072 (compiler-note () (throw :note nil
)))
2073 (error "Unreachable code undetected.")))
2075 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-var-1
))
2078 (compile nil
'(lambda (x y
)
2079 (when (typep y
'fixnum
)
2081 (unless (typep x
'fixnum
)
2082 (error "This is unreachable"))
2084 (compiler-note () (throw :note nil
)))
2085 (error "Unreachable code undetected.")))
2087 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-var-2
))
2090 (compile nil
'(lambda (x y
)
2091 (when (typep y
'fixnum
)
2093 (unless (typep x
'fixnum
)
2094 (error "This is unreachable"))
2096 (compiler-note () (throw :note nil
)))
2097 (error "Unreachable code undetected.")))
2099 ;; Reported by John Wiseman, sbcl-devel
2100 ;; Subject: [Sbcl-devel] float type derivation bug?
2101 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700
2102 (with-test (:name
(:type-derivation
:float-bounds
))
2103 (compile nil
'(lambda (bits)
2104 (let* ((s (if (= (ash bits -
31) 0) 1 -
1))
2105 (e (logand (ash bits -
23) #xff
))
2107 (ash (logand bits
#x7fffff
) 1)
2108 (logior (logand bits
#x7fffff
) #x800000
))))
2109 (float (* s m
(expt 2 (- e
150))))))))
2111 ;; Reported by James Knight
2112 ;; Subject: [Sbcl-devel] AVER: "(EQ (SB-NAME (SC-SB (TN-SC TN))) 'REGISTERS)"
2113 ;; Date: Fri, 24 Mar 2006 19:30:00 -0500
2114 (with-test (:name
:logbitp-vop
)
2116 '(lambda (days shift
)
2117 (declare (type fixnum shift days
))
2119 (canonicalized-shift (+ shift
1))
2120 (first-wrapping-day (- 1 canonicalized-shift
)))
2121 (declare (type fixnum result
))
2122 (dotimes (source-day 7)
2123 (declare (type (integer 0 6) source-day
))
2124 (when (logbitp source-day days
)
2128 (if (< source-day first-wrapping-day
)
2129 (+ source-day canonicalized-shift
)
2131 canonicalized-shift
) 7)))))))
2134 ;;; MISC.637: incorrect delaying of conversion of optional entries
2135 ;;; with hairy constant defaults
2136 (let ((f '(lambda ()
2137 (labels ((%f11
(f11-2 &key key1
)
2138 (labels ((%f8
(f8-2 &optional
(f8-5 (if nil
(return-from %f11
0) 0)))
2143 (assert (eq (funcall (compile nil f
)) :good
)))
2145 ;;; MISC.555: new reference to an already-optimized local function
2146 (let* ((l '(lambda (p1)
2147 (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1
))
2149 (f (compile nil l
)))
2150 (assert (funcall f
:good
))
2151 (assert (nth-value 1 (ignore-errors (funcall f
42)))))
2153 ;;; Check that the compiler doesn't munge *RANDOM-STATE*.
2154 (let* ((state (make-random-state))
2155 (*random-state
* (make-random-state state
))
2156 (a (random most-positive-fixnum
)))
2157 (setf *random-state
* state
)
2158 (compile nil
`(lambda (x a
)
2159 (declare (single-float x
)
2160 (type (simple-array double-float
) a
))
2161 (+ (loop for i across a
2164 (assert (= a
(random most-positive-fixnum
))))
2166 ;;; MISC.641: LET-conversion after physical environment analysis lost NLX-INFOs
2167 (let ((form '(lambda ()
2168 (declare (optimize (speed 1) (space 0) (debug 2)
2169 (compilation-speed 0) (safety 1)))
2170 (flet ((%f3
(f3-1 &key
(key1 (count (floor 0 (min -
74 0)) #())))
2172 (apply #'%f3
0 nil
)))))
2173 (assert (zerop (funcall (compile nil form
)))))
2175 ;;; 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
2176 (compile nil
'(lambda ()
2177 (let ((x (make-array '(1) :element-type
'(signed-byte 32))))
2178 (setf (aref x
0) 1))))
2180 ;;; step instrumentation confusing the compiler, reported by Faré
2181 (handler-bind ((warning #'error
))
2182 (compile nil
'(lambda ()
2183 (declare (optimize (debug 2))) ; not debug 3!
2184 (let ((val "foobar"))
2185 (map-into (make-array (list (length val
))
2186 :element-type
'(unsigned-byte 8))
2187 #'char-code val
)))))
2189 ;;; overconfident primitive type computation leading to bogus type
2191 (let* ((form1 '(lambda (x)
2192 (declare (type (and condition function
) x
))
2194 (fun1 (compile nil form1
))
2196 (declare (type (and standard-object function
) x
))
2198 (fun2 (compile nil form2
)))
2199 (assert (raises-error?
(funcall fun1
(make-condition 'error
))))
2200 (assert (raises-error?
(funcall fun1 fun1
)))
2201 (assert (raises-error?
(funcall fun2 fun2
)))
2202 (assert (eq (funcall fun2
#'print-object
) #'print-object
)))
2204 ;;; LET* + VALUES declaration: while the declaration is a non-standard
2205 ;;; and possibly a non-conforming extension, as long as we do support
2206 ;;; it, we might as well get it right.
2208 ;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
2209 (compile nil
'(lambda () (let* () (declare (values list
)))))
2212 ;;; test for some problems with too large immediates in x86-64 modular
2214 (compile nil
'(lambda (x) (declare (fixnum x
))
2215 (logand most-positive-fixnum
(logxor x most-positive-fixnum
))))
2217 (compile nil
'(lambda (x) (declare (fixnum x
))
2218 (logand most-positive-fixnum
(+ x most-positive-fixnum
))))
2220 (compile nil
'(lambda (x) (declare (fixnum x
))
2221 (logand most-positive-fixnum
(* x most-positive-fixnum
))))
2224 (assert (let (warned-p)
2225 (handler-bind ((warning (lambda (w) (setf warned-p t
))))
2228 (list (let ((y (the real x
)))
2229 (unless (floatp y
) (error ""))
2231 (integer-length x
)))))
2234 ;; Dead / in safe code
2235 (with-test (:name
:safe-dead-
/)
2238 (funcall (compile nil
2240 (declare (optimize (safety 3)))
2245 (division-by-zero ()
2248 ;;; Dead unbound variable (bug 412)
2249 (with-test (:name
:dead-unbound
)
2252 (funcall (compile nil
2256 (unbound-variable ()
2259 ;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR.
2260 (handler-bind ((sb-ext:compiler-note
'error
))
2263 (funcall (compile nil
`(lambda (s p e
)
2264 (declare (optimize speed
)
2271 ;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR.
2272 (handler-bind ((sb-ext:compiler-note
'error
))
2275 (funcall (compile nil
`(lambda (s)
2276 (declare (optimize speed
)
2279 (vector 1 2 3 4)))))
2281 ;;; bug in adding DATA-VECTOR-REF-WITH-OFFSET to x86-64
2282 (assert (not (mismatch #(1.0f0
2.0f0
) (make-array 2 :element-type
'single-float
:initial-contents
(list 1.0f0
2.0f0
)))))
2284 ;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too
2285 ;;; large bignums to floats
2286 (dolist (op '(* / + -
))
2290 (declare (type (integer 0 #.
(* 2 (truncate most-positive-double-float
))) x
))
2293 do
(let ((arg (random (truncate most-positive-double-float
))))
2294 (assert (eql (funcall fun arg
)
2295 (funcall op
0.0d0 arg
)))))))
2297 (with-test (:name
:high-debug-known-function-inlining
)
2298 (let ((fun (compile nil
2300 (declare (optimize (debug 3)) (inline append
))
2301 (let ((fun (lambda (body)
2306 '((foo (bar)))))))))
2309 (with-test (:name
:high-debug-known-function-transform-with-optional-arguments
)
2310 (compile nil
'(lambda (x y
)
2311 (declare (optimize sb-c
::preserve-single-use-debug-variables
))
2313 (some-unknown-function
2315 (return (member x y
))))
2320 ;;; Compiling W-P-O when the pinned objects are known to be fixnums
2322 (compile nil
'(lambda (x y
)
2323 (declare (fixnum y
) (character x
))
2324 (sb-sys:with-pinned-objects
(x y
)
2325 (some-random-function))))
2327 ;;; *CHECK-CONSISTENCY* and TRULY-THE
2329 (with-test (:name
:bug-423
)
2330 (let ((sb-c::*check-consistency
* t
))
2331 (handler-bind ((warning #'error
))
2332 (flet ((make-lambda (type)
2336 (let ((q (truly-the list z
)))
2339 (let ((q (truly-the vector z
)))
2343 (compile nil
(make-lambda 'list
))
2344 (compile nil
(make-lambda 'vector
))))))