?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
1.0.15.36: fix bug 423
[sbcl/tcr.git] / tests / compiler.pure.lisp
blob88463e1333e227c9b846e3be2129d9a5c196d4d8
1 ;;;; various compiler tests without side effects
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
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
8 ;;;; from CMU CL.
9 ;;;;
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.
13
14 (cl:in-package :cl-user)
15
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))
19
20 ;;; Exercise a compiler bug (by crashing the compiler).
21 ;;;
22 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
23 ;;; (2000-09-06 on cmucl-imp).
24 ;;;
25 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
26 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
27 (funcall (compile nil
28 '(lambda ()
29 (labels ((fun1 ()
30 (fun2))
31 (fun2 ()
32 (when nil
33 (tagbody
34 tag
35 (fun2)
36 (go tag)))
37 (when nil
38 (tagbody
39 tag
40 (fun1)
41 (go tag)))))
42
43 (fun1)
44 nil))))
45
46 ;;; Exercise a compiler bug (by crashing the compiler).
47 ;;;
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.
50 (funcall (compile nil
51 '(lambda (x)
52 (or (integerp x)
53 (block used-by-some-y?
54 (flet ((frob (stk)
55 (dolist (y stk)
56 (unless (rejected? y)
57 (return-from used-by-some-y? t)))))
58 (declare (inline frob))
59 (frob (rstk x))
60 (frob (mrstk x)))
61 nil))))
62 13)
63
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)
68 (let ((x 0))
69 (declare (special x))
70 (let ((x 1))
71 (let ((y x))
72 (declare (special x)) y)))))
73 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
74 (let ((x 0))
75 (declare (special x))
76 (let ((x 1))
77 (let ((y x) (x 5))
78 (declare (special x)) y)))))
79
80 ;;; another LET-related bug fixed by Alexey Dejneka at the same
81 ;;; time as bug 112
82 (multiple-value-bind (fun warnings-p failure-p)
83 ;; should complain about duplicate variable names in LET binding
84 (compile nil
85 '(lambda ()
86 (let (x
87 (x 1))
88 (list x))))
89 (declare (ignore warnings-p))
90 (assert (functionp fun))
91 (assert failure-p))
92
93 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
94 ;;; Lichteblau 2002-05-21)
95 (progn
96 (multiple-value-bind (fun warnings-p failure-p)
97 (compile nil
98 ;; Compiling this code should cause a STYLE-WARNING
99 ;; about *X* looking like a special variable but not
100 ;; being one.
101 '(lambda (n)
102 (let ((*x* n))
103 (funcall (symbol-function 'x-getter))
104 (print *x*))))
105 (assert (functionp fun))
106 (assert warnings-p)
107 (assert (not failure-p)))
108 (multiple-value-bind (fun warnings-p failure-p)
109 (compile nil
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).
113 '(lambda (n)
114 (let ((*x* n))
115 (declare (special *x*))
116 (funcall (symbol-function 'x-getter))
117 (print *x*))))
118 (assert (functionp fun))
119 (assert (not warnings-p))
120 (assert (not failure-p))))
121
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*
128 ;; :TEST #'TYPE=)
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)))
132 (print i)))
133 (dotimes (i 14)
134 (when (typep i '(and integer (satisfies oddp)))
135 (print i)))
136
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)))
143
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))))))
147
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)))
154
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"))))
169
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)
174 17))
175
176 ;;; bug 181: bad type specifier dropped compiler into debugger
177 (assert (list (compile nil '(lambda (x)
178 (declare (type (0) x))
179 x))))
180
181 (let ((f (compile nil '(lambda (x)
182 (make-array 1 :element-type '(0))))))
183 (assert (null (ignore-errors (funcall f)))))
184
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)))))))
192
193 (dolist (form '((values-list (car (list '(1 . 2))))
194 (fboundp '(set bet))
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)))))))
200
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.")
208 ((locally
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.
218 nil)
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)
242 expected-des
243 (list expected-des))
244 do
245 (multiple-value-bind (fun warnings-p failure-p)
246 (handler-bind ((style-warning (lambda (c)
247 (if expected
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))))
253 ()
254 "~S should have warned ~S, but instead warned: ~A"
255 form expect-one c))
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)
261 ()
262 "~S should have warned ~S, but didn't."
263 form expected)
264 (assert (not failure-p))))
265
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)))))
269
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)))
275
276 ;;; bug 124: environment of MACROLET-introduced macro expanders
277 (assert (equal
278 (macrolet ((mext (x) `(cons :mext ,x)))
279 (macrolet ((mint (y) `'(:mint ,(mext y))))
280 (list (mext '(1 2))
281 (mint (1 2)))))
282 '((:MEXT 1 2) (:MINT (:MEXT 1 2)))))
283
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))
290 s))))
291 (assert (null result))
292 (assert (typep error 'program-error)))
293
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)))
299
300 (multiple-value-bind (result error)
301 (ignore-errors (ecase 1 (t 0) (1 2)))
302 (assert (eql result 2))
303 (assert (null error)))
304
305 ;;; FTYPE should accept any functional type specifier
306 (compile nil '(lambda (x) (declare (ftype function f)) (f x)))
307
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)))
320
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)))
326 (i 0))
327 (psetq x (aref a (incf i))
328 y (aref a (incf i)))
329 (values a i)))
330 (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9)))
331 (assert (= index 4)))
332
333 (multiple-value-bind (result error)
334 (ignore-errors
335 (let ((x (list 1 2)))
336 (psetq (car x) 3)
337 x))
338 (assert (null result))
339 (assert (typep error 'program-error)))
340
341 ;;; COPY-SEQ should work on known-complex vectors:
342 (assert (equalp #(1)
343 (let ((v (make-array 0 :fill-pointer 0)))
344 (vector-push-extend 1 v)
345 (copy-seq v))))
346
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
350 ;;; top-level.
351 (assert (equal
352 (function-lambda-expression
353 (compile nil '(lambda (x) (block nil (print x)))))
354 '(lambda (x) (block nil (print x)))))
355
356 ;;; bug 62: too cautious type inference in a loop
357 (assert (nth-value
358 2
359 (compile nil
360 '(lambda (a)
361 (declare (optimize speed (safety 0)))
362 (typecase a
363 (array (loop (print (car a)))))))))
364
365 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
366 ;;; failure
367 (compile nil
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))
372 (let ((path '(nil)))
373 (loop for node = (root-node tree)
374 then (if (funcall lessp key (node-key node))
375 (left-child node)
376 (right-child node))
377 when (null node)
378 do (return (values nil nil nil))
379 do (when collect-path-p
380 (push node path))
381 (when (funcall equalp key (node-key node))
382 (return (values node path t))))))))
383
384 ;;; CONSTANTLY should return a side-effect-free function (bug caught
385 ;;; by Paul Dietz' test suite)
386 (let ((i 0))
387 (let ((fn (constantly (progn (incf i) 1))))
388 (assert (= i 1))
389 (assert (= (funcall fn) 1))
390 (assert (= i 1))
391 (assert (= (funcall fn) 1))
392 (assert (= i 1))))
393
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)))
404
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)))
407 '(1 2))
408 '((2) 1)))
409
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))
413
414 (assert
415 (raises-error? (multiple-value-bind (a b c)
416 (eval '(truncate 3 4))
417 (declare (integer c))
418 (list a b c))
419 type-error))
420
421 (assert (equal (multiple-value-list (the (values &rest integer)
422 (eval '(values 3))))
423 '(3)))
424
425 ;;; Bug relating to confused representation for the wild function
426 ;;; type:
427 (assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
428
429 ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz'
430 ;;; test suite)
431 (assert (eql (macrolet ((foo () 1))
432 (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env)
433 x))
434 (%f)))
435 1))
436
437 ;;; MACROLET should check for duplicated names
438 (dolist (ll '((x (z x))
439 (x y &optional z x w)
440 (x y &optional z z)
441 (x &rest x)
442 (x &rest (y x))
443 (x &optional (y nil x))
444 (x &optional (y nil y))
445 (x &key x)
446 (x &key (y nil x))
447 (&key (y nil z) (z nil w))
448 (&whole x &optional x)
449 (&environment x &whole x)))
450 (assert (nth-value 2
451 (handler-case
452 (compile nil
453 `(lambda ()
454 (macrolet ((foo ,ll nil)
455 (bar (&environment env)
456 `',(macro-function 'foo env)))
457 (bar))))
458 (error (c)
459 (values nil t t))))))
460
461 (assert (typep (eval `(the arithmetic-error
462 ',(make-condition 'arithmetic-error)))
463 'arithmetic-error))
464
465 (assert (not (nth-value
466 2 (compile nil '(lambda ()
467 (make-array nil :initial-element 11))))))
468
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)))
473
474 (assert (= (the (values integer symbol) (values 1 'foo 13)) 1))
475
476 (let ((f (compile nil
477 '(lambda (v)
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)))
482
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#))) ()))))
490 (dolist (form forms)
491 (assert (nth-value 2 (compile nil `(lambda () ,form))))))
492
493 (assert (nth-value 2 (compile nil
494 '(lambda ()
495 (svref (make-array '(8 9) :adjustable t) 1)))))
496
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)))
499 #\a #\b nil)
500 type-error)
501 (raises-error? (funcall (compile nil
502 '(lambda (x y z)
503 (declare (optimize (speed 3) (safety 3)))
504 (char/= x y z)))
505 nil #\a #\a)
506 type-error)
507
508 ;;; Compiler lost return type of MAPCAR and friends
509 (dolist (fun '(mapcar mapc maplist mapl))
510 (assert (nth-value 2 (compile nil
511 `(lambda (x)
512 (1+ (,fun #'print x)))))))
513
514 (assert (nth-value 2 (compile nil
515 '(lambda ()
516 (declare (notinline mapcar))
517 (1+ (mapcar #'print '(1 2 3)))))))
518
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)))
524 (setf (aref a 0) v)
525 a))))
526 (let ((y (make-array 2 :element-type 'bit :initial-element 0)))
527 (assert (equal y #*00))
528 (funcall f y 1)
529 (assert (equal y #*10))))
530
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))))
535
536 ;;; compiler failure
537 (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0)))))))
538 (assert (funcall f 1d0)))
539
540 (compile nil '(lambda (x)
541 (declare (double-float x))
542 (let ((y (* x pi)))
543 (atan y y))))
544
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)))
553
554 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
555 (handler-bind ((sb-ext:compiler-note #'error))
556 (assert (equalp (funcall
557 (compile
558 nil
559 '(lambda ()
560 (let ((x (make-sequence 'vector 10 :initial-element 'a)))
561 (setf (aref x 4) 'b)
562 x))))
563 #(a a a a b a a a a a))))
564
565 ;;; this is not a check for a bug, but rather a test of compiler
566 ;;; quality
567 (dolist (type '((integer 0 *) ; upper bound
568 (real (-1) *)
569 float ; class
570 (real * (-10)) ; lower bound
571 ))
572 (assert (nth-value
573 1 (compile nil
574 `(lambda (n)
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)))))))))
579
580 ;;; bug 278b
581 ;;;
582 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
583 ;;; compiler has an optimized VOP for +; so this code should cause an
584 ;;; efficiency note.
585 (assert (eq (block nil
586 (handler-case
587 (compile nil '(lambda (i)
588 (declare (optimize speed))
589 (declare (type integer i))
590 (+ i 2)))
591 (sb-ext:compiler-note (c) (return :good))))
592 :good))
593
594 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
595 ;;; symbol macros
596 (assert (not (nth-value 1 (compile nil '(lambda (u v)
597 (symbol-macrolet ((x u)
598 (y v))
599 (declare (ignore x)
600 (ignorable y))
601 (list u v)))))))
602
603 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
604 (loop for (x type) in
605 '((14 integer)
606 (14 rational)
607 (-14/3 (rational -8 11))
608 (3s0 short-float)
609 (4f0 single-float)
610 (5d0 double-float)
611 (6l0 long-float)
612 (14 real)
613 (13/2 real)
614 (2s0 real)
615 (2d0 real)
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))
627 (#c(-3/7 4) complex)
628 (#c(2 3l0) complex))
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)))))))
635
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))
640 (logxor x y))))
641 (assert (= (funcall fun 0 0) 0))
642 (assert (= (funcall fun 0 -1) -1))
643 (assert (= (funcall fun -1 -1) 0)))
644
645 ;;; from PFD's torture test, triggering a bug in our effective address
646 ;;; treatment.
647 (compile
648 nil
649 `(lambda (a b)
650 (declare (type (integer 8 22337) b))
651 (logandc2
652 (logandc2
653 (* (logandc1 (max -29303 b) 4) b)
654 (abs (logorc1 (+ (logandc1 -11 b) 2607688420) -31153924)))
655 (logeqv (max a 0) b))))
656
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)))
664
665 ;;; bug reported by Paul Dietz: component last block does not have
666 ;;; start ctran
667 (compile nil
668 '(lambda ()
669 (declare (notinline + logand)
670 (optimize (speed 0)))
671 (LOGAND
672 (BLOCK B5
673 (FLET ((%F1 ()
674 (RETURN-FROM B5 -220)))
675 (LET ((V7 (%F1)))
676 (+ 359749 35728422))))
677 -24076)))
678
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))))
684 108251912)
685 8))
686
687 (assert (= (funcall (compile nil `(lambda (c)
688 (declare (optimize (speed 3))
689 (type (integer 23062188 149459656) c))
690 (mod c (min -2 0))))
691 95019853)
692 -1))
693
694 ;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
695 (compile nil
696 '(LAMBDA (A B C)
697 (BLOCK B6
698 (LOGEQV (REM C -6758)
699 (REM B (MAX 44 (RETURN-FROM B6 A)))))))
700
701 (compile nil '(lambda ()
702 (block nil
703 (flet ((foo (x y) (if (> x y) (print x) (print y))))
704 (foo 1 2)
705 (bar)
706 (foo (return 14) 2)))))
707
708 ;;; bug in Alpha backend: not enough sanity checking of arguments to
709 ;;; instructions
710 (assert (= (funcall (compile nil
711 '(lambda (x)
712 (declare (fixnum x))
713 (ash x -257)))
714 1024)
715 0))
716
717 ;;; bug found by WHN and pfdietz: compiler failure while referencing
718 ;;; an entry point inside a deleted lambda
719 (compile nil '(lambda ()
720 (let (r3533)
721 (flet ((bbfn ()
722 (setf r3533
723 (progn
724 (flet ((truly (fn bbd)
725 (let (r3534)
726 (let ((p3537 nil))
727 (unwind-protect
728 (multiple-value-prog1
729 (progn
730 (setf r3534
731 (progn
732 (bubf bbd t)
733 (flet ((c-3536 ()
734 (funcall fn)))
735 (cdec #'c-3536
736 (vector bbd))))))
737 (setf p3537 t))
738 (unless p3537
739 (error "j"))))
740 r3534))
741 (c (pd) (pdc pd)))
742 (let ((a (smock a))
743 (b (smock b))
744 (b (smock c)))))))))
745 (wum #'bbfn "hc3" (list)))
746 r3533)))
747 (compile nil '(lambda () (flet ((%f () (unwind-protect nil))) nil)))
748
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
754 ;;; being smart.
755 (assert (= (funcall
756 (compile nil
757 '(lambda (x)
758 (declare (type (integer 178956970 178956970) x)
759 (optimize speed))
760 (* x 24)))
761 178956970)
762 4294967280))
763
764 ;;; bug in modular arithmetic and type specifiers
765 (assert (= (funcall (compile nil (lambda (x) (logand x x 0)))
766 -1)
767 0))
768
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
772 (compile nil
773 '(lambda (a)
774 (declare (type (integer 4303063 101130078) a))
775 (mask-field (byte 18 2) (ash a 77))))
776 57132532)))
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
781 (compile nil
782 '(lambda (a)
783 (declare (type (integer 4303063 101130078) a))
784 (mask-field (byte 30 2) (ash a 77))))
785 57132532)))
786 (assert (= 0 (funcall
787 (compile nil
788 '(lambda (a)
789 (declare (type (integer 4303063 101130078) a))
790 (mask-field (byte 64 2) (ash a 77))))
791 57132532)))
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
795 (compile nil
796 '(lambda (a)
797 (declare (type (integer 4303063 101130078) a))
798 (sb-c::mask-signed-field 30 (ash a 77))))
799 57132532)))
800 (assert (= 0 (funcall
801 (compile nil
802 '(lambda (a)
803 (declare (type (integer 4303063 101130078) a))
804 (sb-c::mask-signed-field 61 (ash a 77))))
805 57132532)))
806
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)))
814 (let ((v8
815 (- -554046873252388011622614991634432
816 (ignore-errors c)
817 (unwind-protect 2791485))))
818 (max (ignore-errors a)
819 (let ((v6 (- v8 (restart-case 980))))
820 (min v8 v6))))))
821 259448422916 173715)
822 259448422916))
823 (assert (eql (funcall
824 (compile nil '(lambda (a b)
825 (min -80
826 (abs
827 (ignore-errors
828 (+
829 (logeqv b
830 (block b6
831 (return-from b6
832 (load-time-value -6876935))))
833 (if (logbitp 1 a) b (setq a -1522022182249))))))))
834 -1802767029877 -12374959963)
835 -80))
836
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)
842 -570344431
843 (ignore-errors -732893970)))))
844 705347625)
845 -570344431))
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))))
851 0)
852 0))
853 (assert (eql (funcall
854 (compile nil '(lambda (b c)
855 (declare (type (integer -4 -3) c))
856 (block b7
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)
861 99345)))
862 (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2)))
863 b)))))
864 2950453607 -4)
865 -815145134))
866 (assert (eql (funcall
867 (compile nil
868 '(lambda (b c)
869 (declare (type (integer -29742055786 23602182204) b))
870 (declare (type (integer -7409 -2075) c))
871 (declare (optimize (speed 3)))
872 (floor
873 (labels ((%f2 ()
874 (block b6
875 (ignore-errors (return-from b6
876 (if (= c 8) b 82674))))))
877 (%f2)))))
878 22992834060 -5833)
879 82674))
880 (assert (equal (multiple-value-list
881 (funcall
882 (compile nil '(lambda (a)
883 (declare (type (integer -944 -472) a))
884 (declare (optimize (speed 3)))
885 (round
886 (block b3
887 (return-from b3
888 (if (= 55957 a) -117 (ignore-errors
889 (return-from b3 a))))))))
890 -589))
891 '(-589 0)))
892
893 ;;; MISC.158
894 (assert (zerop (funcall
895 (compile nil
896 '(lambda (a b c)
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))
901 1706
902 (let ((v5 (abs c)))
903 (logand v5
904 (logior (logandc2 c v5)
905 (common-lisp:handler-case
906 (ash a (min 36 22477)))))))))
907 100000 0 0)))
908
909 ;;; MISC.152, 153: deleted code and iteration var type inference
910 (assert (eql (funcall
911 (compile nil
912 '(lambda (a)
913 (block b5
914 (let ((v1 (let ((v8 (unwind-protect 9365)))
915 8862008)))
916 (*
917 (return-from b5
918 (labels ((%f11 (f11-1) f11-1))
919 (%f11 87246015)))
920 (return-from b5
921 (setq v1
922 (labels ((%f6 (f6-1 f6-2 f6-3) v1))
923 (dpb (unwind-protect a)
924 (byte 18 13)
925 (labels ((%f4 () 27322826))
926 (%f6 -2 -108626545 (%f4))))))))))))
927 -6)
928 87246015))
929
930 (assert (eql (funcall
931 (compile nil
932 '(lambda (a)
933 (if (logbitp 3
934 (case -2
935 ((-96879 -1035 -57680 -106404 -94516 -125088)
936 (unwind-protect 90309179))
937 ((-20811 -86901 -9368 -98520 -71594)
938 (let ((v9 (unwind-protect 136707)))
939 (block b3
940 (setq v9
941 (let ((v4 (return-from b3 v9)))
942 (- (ignore-errors (return-from b3 v4))))))))
943 (t -50)))
944 -20343
945 a)))
946 0)
947 -20343))
948
949 ;;; MISC.165
950 (assert (eql (funcall
951 (compile
952 nil
953 '(lambda (a b c)
954 (block b3
955 (flet ((%f15
956 (f15-1 f15-2 f15-3
957 &optional
958 (f15-4
959 (flet ((%f17
960 (f17-1 f17-2 f17-3
961 &optional (f17-4 185155520) (f17-5 c)
962 (f17-6 37))
963 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))))))
968 0 0 -5)
969 -16))
970
971 ;;; MISC.172
972 (assert (eql (funcall
973 (compile
974 nil
975 '(lambda (a b c)
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)
982 (flet ((%f6 ()
983 (flet ((%f18
984 (f18-1
985 &optional (f18-2 a)
986 (f18-3 -207465075)
987 (f18-4 a))
988 (return-from %f12 b)))
989 (%f18 -3489553
990 -7
991 (%f18 (%f18 150 -64 f12-1)
992 (%f18 (%f18 -8531)
993 11410)
994 b)
995 56362666))))
996 (labels ((%f7
997 (f7-1 f7-2
998 &optional (f7-3 (%f6)))
999 7767415))
1000 f12-1))))
1001 (%f2 b -36582571))))
1002 (apply #'%f12 (list 774 -4413)))))
1003 0 1 2)
1004 774))
1005
1006 ;;; MISC.173
1007 (assert (eql (funcall
1008 (compile
1009 nil
1010 '(lambda (a b c)
1011 (declare (notinline values))
1012 (declare (optimize (safety 3)))
1013 (declare (optimize (speed 0)))
1014 (declare (optimize (debug 0)))
1015 (flet ((%f11
1016 (f11-1 f11-2
1017 &optional (f11-3 c) (f11-4 7947114)
1018 (f11-5
1019 (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529))
1020 8134))
1021 (multiple-value-call #'%f3
1022 (values (%f3 -30637724 b) c)))))
1023 (setq c 555910)))
1024 (if (and nil (%f11 a a))
1025 (if (%f11 a 421778 4030 1)
1026 (labels ((%f7
1027 (f7-1 f7-2
1028 &optional
1029 (f7-3
1030 (%f11 -79192293
1031 (%f11 c a c -4 214720)
1032 b
1033 b
1034 (%f11 b 985)))
1035 (f7-4 a))
1036 b))
1037 (%f11 c b -25644))
1038 54)
1039 -32326608))))
1040 1 2 3)
1041 -32326608))
1042
1043 ;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
1044 ;;; local lambda argument
1045 (assert
1046 (equal
1047 (funcall
1048 (compile nil
1049 '(lambda (a b c)
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)))
1057 (flet ((%f11
1058 (f11-1 f11-2)
1059 (labels ((%f4 () (round 200048 (max 99 c))))
1060 (logand
1061 f11-1
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)
1067 -264223548))
1068
1069 ;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
1070 ;;; transform
1071 (assert (equal (multiple-value-list
1072 (funcall
1073 (compile nil '(lambda ()
1074 (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
1075 (ceiling
1076 (ceiling
1077 (flet ((%f16 () 0)) (%f16))))))))
1078 '(0 0)))
1079
1080 ;;; MISC.184
1081 (assert (zerop
1082 (funcall
1083 (compile
1084 nil
1085 '(lambda (a b c)
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)))
1092 (if nil
1093 (flet ((%f15 (f15-1 &optional (f15-2 c))
1094 (labels ((%f1 (f1-1 f1-2) 0))
1095 (%f1 a 0))))
1096 (flet ((%f4 ()
1097 (multiple-value-call #'%f15
1098 (values (%f15 c 0) (%f15 0)))))
1099 (if nil (%f4)
1100 (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0))
1101 f8-3))
1102 0))))
1103 0)))
1104 3040851270 1664281 -1340106197)))
1105
1106 ;;; MISC.249
1107 (assert (zerop
1108 (funcall
1109 (compile
1110 nil
1111 '(lambda (a b)
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)
1117 (ignore-errors 0)))
1118 (dotimes (iv4 5 a) (%f9 0 0 b)))
1119 0)))
1120 1 2)))
1121
1122 ;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
1123 (assert
1124 (= (funcall
1125 (compile
1126 nil
1127 '(lambda (a)
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))))
1132 215067723)
1133 13739018))
1134
1135 \f
1136 ;;;; Bugs in stack analysis
1137 ;;; bug 299 (reported by PFD)
1138 (assert
1139 (equal (funcall
1140 (compile
1141 nil
1142 '(lambda ()
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)))))))
1147 '(:a :b :c :x :y)))
1148 ;;; bug 298 (= MISC.183)
1149 (assert (zerop (funcall
1150 (compile
1151 nil
1152 '(lambda (a b c)
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)))
1160 (block b7
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)))))
1163 0 6000 -9000000)))
1164 (assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))))
1165 '(1 2)))
1166 (let ((f (compile
1167 nil
1168 '(lambda (x)
1169 (block foo
1170 (multiple-value-call #'list
1171 :a
1172 (block bar
1173 (return-from foo
1174 (multiple-value-call #'list
1175 :b
1176 (block quux
1177 (return-from bar
1178 (catch 'baz
1179 (if x
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))))
1184
1185 ;;; MISC.185
1186 (assert (equal
1187 (funcall
1188 (compile
1189 nil
1190 '(lambda (a b c)
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)))
1197 (flet ((%f3
1198 (f3-1 f3-2 f3-3
1199 &optional (f3-4 a) (f3-5 0)
1200 (f3-6
1201 (labels ((%f10 (f10-1 f10-2 f10-3)
1202 0))
1203 (apply #'%f10
1204 0
1205 a
1206 (- (if (equal a b) b (%f10 c a 0))
1207 (catch 'ct2 (throw 'ct2 c)))
1208 nil))))
1209 0))
1210 (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7)
1211 0))
1212 ;;; MISC.186
1213 (assert (eq
1214 (eval
1215 '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1))
1216 (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil)))
1217 (vars '(b c))
1218 (fn1 `(lambda ,vars
1219 (declare (type (integer -2 19) b)
1220 (type (integer -1520 218978) c)
1221 (optimize (speed 3) (safety 1) (debug 1)))
1222 ,form))
1223 (fn2 `(lambda ,vars
1224 (declare (notinline logeqv apply)
1225 (optimize (safety 3) (speed 0) (debug 0)))
1226 ,form))
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)
1232 :good
1233 (values result1 result2))))
1234 :good))
1235
1236 ;;; MISC.290
1237 (assert (zerop
1238 (funcall
1239 (compile
1240 nil
1241 '(lambda ()
1242 (declare
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))))))
1246
1247 ;;; MISC.292
1248 (assert (zerop (funcall
1249 (compile
1250 nil
1251 '(lambda (a b)
1252 (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
1253 (compilation-speed 2)))
1254 (apply (constantly 0)
1255 a
1256 0
1257 (catch 'ct6
1258 (apply (constantly 0)
1259 0
1260 0
1261 (let* ((v1
1262 (let ((*s7* 0))
1263 b)))
1264 0)
1265 0
1266 nil))
1267 0
1268 nil)))
1269 1 2)))
1270
1271 ;;; misc.295
1272 (assert (eql
1273 (funcall
1274 (compile
1275 nil
1276 '(lambda ()
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))))))
1281 15867134))
1282
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
1286 (compile
1287 nil
1288 '(lambda (a b c)
1289 (declare (notinline boole values denominator list))
1290 (declare
1291 (optimize (speed 2)
1292 (space 0)
1293 (safety 1)
1294 (debug 0)
1295 (compilation-speed 2)))
1296 (catch 'ct6
1297 (progv
1298 '(*s8*)
1299 (list 0)
1300 (let ((v9 (ignore-errors (throw 'ct6 0))))
1301 (denominator
1302 (progv nil nil (values (boole boole-and 0 v9)))))))))
1303 1 2 3)))
1304
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))
1310 (block ext
1311 (return-from non-continuous-stack-test
1312 (multiple-value-call #'list
1313 (eval '(values :b1 :b2))
1314 (eval '(values :b3 :b4))
1315 (block int
1316 (return-from ext
1317 (multiple-value-call (eval #'values)
1318 (eval '(values 1 2))
1319 (eval '(values 3 4))
1320 (block ext
1321 (return-from int
1322 (multiple-value-call (eval #'values)
1323 (eval '(values :a1 :a2))
1324 (eval '(values :a3 :a4))
1325 (block int
1326 (return-from ext
1327 (multiple-value-call (eval #'values)
1328 (eval '(values 5 6))
1329 (eval '(values 7 8))
1330 (if x
1331 :ext
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)))
1335
1336 ;;; MISC.362: environment of UNWIND-PROTECTor is different from that
1337 ;;; if ENTRY.
1338 (assert (equal (multiple-value-list (funcall
1339 (compile
1340 nil
1341 '(lambda (b g h)
1342 (declare (optimize (speed 3) (space 3) (safety 2)
1343 (debug 2) (compilation-speed 3)))
1344 (catch 'ct5
1345 (unwind-protect
1346 (labels ((%f15 (f15-1 f15-2 f15-3)
1347 (rational (throw 'ct5 0))))
1348 (%f15 0
1349 (apply #'%f15
1350 0
1351 h
1352 (progn
1353 (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
1354 0)
1355 nil)
1356 0))
1357 (common-lisp:handler-case 0)))))
1358 1 2 3))
1359 '(0)))
1360
1361 \f
1362 ;;; MISC.275
1363 (assert
1364 (zerop
1365 (funcall
1366 (compile
1367 nil
1368 '(lambda (b)
1369 (declare (notinline funcall min coerce))
1370 (declare
1371 (optimize (speed 1)
1372 (space 2)
1373 (safety 2)
1374 (debug 1)
1375 (compilation-speed 1)))
1376 (flet ((%f12 (f12-1)
1377 (coerce
1378 (min
1379 (if f12-1 (multiple-value-prog1
1380 b (return-from %f12 0))
1381 0))
1382 'integer)))
1383 (funcall #'%f12 0))))
1384 -33)))
1385
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)
1392 do
1393 (loop for args in `((1 ,complex-arg)
1394 (,complex-arg 1))
1395 for form = `(,f ,@args)
1396 for f1 = (compile nil `(lambda (x) ,form))
1397 and f2 = (compile nil `(lambda (x) (declare (notinline min max))
1398 ,form))
1399 do
1400 (dolist (x '(nil t))
1401 (assert (eql (funcall f1 x) (funcall f2 x)))))))
1402
1403 ;;;
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
1409 ;; return value.
1410 (unless (string= (car (last (sb-c::simple-condition-format-arguments c)))
1411 "<return value>")
1412 (error "Compiler does not trust result type assertion."))))
1413
1414 (let ((f (compile nil '(lambda (x)
1415 (declare (optimize speed (safety 0)))
1416 (block nil
1417 (the double-float
1418 (multiple-value-prog1
1419 (sqrt (the double-float x))
1420 (when (< x 0)
1421 (return :minus)))))))))
1422 (assert (eql (funcall f -1d0) :minus))
1423 (assert (eql (funcall f 4d0) 2d0)))
1424
1425 ;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
1426 (handler-case
1427 (compile nil '(lambda (a i)
1428 (locally
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))
1433 (deref a i))))
1434 (compiler-note () (error "The code is not optimized.")))
1435
1436 (handler-case
1437 (compile nil '(lambda (x)
1438 (declare (type (integer -100 100) x))
1439 (declare (optimize speed))
1440 (declare (notinline identity))
1441 (1+ (identity x))))
1442 (compiler-note () (error "IDENTITY derive-type not applied.")))
1443
1444 (assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
1445
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
1448 ;;; made.
1449 (assert
1450 (zerop
1451 (funcall
1452 (compile
1453 nil
1454 '(lambda ()
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)))))))
1460
1461 ;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
1462 (assert (zerop (funcall
1463 (compile
1464 nil
1465 '(lambda (a c)
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)))
1469 (catch 'ct7
1470 (if
1471 (logbitp 0
1472 (if (/= 0 a)
1473 c
1474 (ignore-errors
1475 (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
1476 0 0))))
1477 391833530 -32785211)))
1478
1479 ;;; efficiency notes for ordinary code
1480 (macrolet ((frob (arglist &body body)
1481 `(progn
1482 (handler-case
1483 (compile nil '(lambda ,arglist ,@body))
1484 (sb-ext:compiler-note (e)
1485 (error "bad compiler note for ~S:~% ~A" ',body e)))
1486 (catch :got-note
1487 (handler-case
1488 (compile nil '(lambda ,arglist (declare (optimize speed))
1489 ,@body))
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)))
1500
1501 (macrolet ((frob (style-warn-p form)
1502 (if style-warn-p
1503 `(catch :got-style-warning
1504 (handler-case
1505 (eval ',form)
1506 (style-warning (e) (throw :got-style-warning nil)))
1507 (error "missing style-warning for ~S" ',form))
1508 `(handler-case
1509 (eval ',form)
1510 (style-warning (e)
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)))))
1519
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)))
1526 (lambda (x y)
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)))
1533 (lambda (x y)
1534 (declare (type (integer 3 6) y)
1535 (type (integer -6 -3) x))
1536 (+ (logxor x y) most-positive-fixnum)))))
1537
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))))
1545 1 257)))
1546
1547 ;;; code instrumenting problems
1548 (compile nil
1549 '(lambda ()
1550 (declare (optimize (debug 3)))
1551 (list (the integer (if nil 14 t)))))
1552
1553 (compile nil
1554 '(LAMBDA (A B C D)
1555 (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD))
1556 (DECLARE
1557 (OPTIMIZE (SPEED 1)
1558 (SPACE 1)
1559 (SAFETY 1)
1560 (DEBUG 3)
1561 (COMPILATION-SPEED 0)))
1562 (MASK-FIELD (BYTE 7 26)
1563 (PROGN
1564 (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
1565 B))))
1566
1567 (compile nil
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))
1573 s)))
1574
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 "(")
1580 (print x s))))
1581 (compile nil '(lambda (s x)
1582 (pprint-logical-block (s x :per-line-prefix ";")
1583 (print x s))))
1584 (compile nil '(lambda (s x)
1585 (pprint-logical-block (s x :suffix ">")
1586 (print x s)))))
1587
1588 ;;; MISC.427: loop analysis requires complete DFO structure
1589 (assert (eql 17 (funcall
1590 (compile
1591 nil
1592 '(lambda (a)
1593 (declare (notinline list reduce logior))
1594 (declare (optimize (safety 2) (compilation-speed 1)
1595 (speed 3) (space 2) (debug 2)))
1596 (logior
1597 (let* ((v5 (reduce #'+ (list 0 a))))
1598 (declare (dynamic-extent v5))
1599 v5))))
1600 17)))
1601
1602 ;;; MISC.434
1603 (assert (zerop (funcall
1604 (compile
1605 nil
1606 '(lambda (a b)
1607 (declare (type (integer -8431780939320 1571817471932) a))
1608 (declare (type (integer -4085 0) b))
1609 (declare (ignorable a b))
1610 (declare
1611 (optimize (space 2)
1612 (compilation-speed 0)
1613 #+sbcl (sb-c:insert-step-conditions 0)
1614 (debug 2)
1615 (safety 0)
1616 (speed 3)))
1617 (let ((*s5* 0))
1618 (dotimes (iv1 2 0)
1619 (let ((*s5*
1620 (elt '(1954479092053)
1621 (min 0
1622 (max 0
1623 (if (< iv1 iv1)
1624 (lognand iv1 (ash iv1 (min 53 iv1)))
1625 iv1))))))
1626 0)))))
1627 -7639589303599 -1368)))
1628
1629 (compile
1630 nil
1631 '(lambda (a b)
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)))
1637 (dotimes (iv1 2 0)
1638 (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass
1639 (print (if (< iv1 iv1)
1640 (logand (ash iv1 iv1) 1)
1641 iv1)))))
1642
1643 ;;; MISC.435: lambda var substitution in a deleted code.
1644 (assert (zerop (funcall
1645 (compile
1646 nil
1647 '(lambda (a b c d)
1648 (declare (notinline aref logandc2 gcd make-array))
1649 (declare
1650 (optimize (space 0) (safety 0) (compilation-speed 3)
1651 (speed 3) (debug 1)))
1652 (progn
1653 (tagbody
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))))
1657 tag2)
1658 0)))
1659 3021871717588 -866608 -2 -17194)))
1660
1661 ;;; MISC.436, 438: lost reoptimization
1662 (assert (zerop (funcall
1663 (compile
1664 nil
1665 '(lambda (a b)
1666 (declare (type (integer -2917822 2783884) a))
1667 (declare (type (integer 0 160159) b))
1668 (declare (ignorable a b))
1669 (declare
1670 (optimize (compilation-speed 1)
1671 (speed 3)
1672 (safety 3)
1673 (space 0)
1674 ; #+sbcl (sb-c:insert-step-conditions 0)
1675 (debug 0)))
1676 (if
1677 (oddp
1678 (loop for
1679 lv1
1680 below
1681 2
1682 count
1683 (logbitp 0
1684 (1-
1685 (ash b
1686 (min 8
1687 (count 0
1688 '(-10197561 486 430631291
1689 9674068))))))))
1690 b
1691 0)))
1692 1265797 110757)))
1693
1694 (assert (zerop (funcall
1695 (compile
1696 nil
1697 ' (lambda (a)
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)))
1703 805)))
1704
1705 ;;; bug #302
1706 (assert (compile
1707 nil
1708 '(lambda (s ei x y)
1709 (declare (type (simple-array function (2)) s) (type ei ei))
1710 (funcall (aref s ei) x y))))
1711
1712 ;;; MISC.320: ir1-transform can create an intercomponent reference to
1713 ;;; a DEFINED-FUN.
1714 (assert (eql 102 (funcall
1715 (compile
1716 nil
1717 '(lambda ()
1718 (declare (optimize (speed 3) (space 0) (safety 2)
1719 (debug 2) (compilation-speed 0)))
1720 (catch 'ct2
1721 (elt '(102)
1722 (flet ((%f12 () (rem 0 -43)))
1723 (multiple-value-call #'%f12 (values))))))))))
1724
1725 ;;; MISC.437: lost reoptimization after FLUSH-DEST
1726 (assert (zerop (funcall
1727 (compile
1728 nil
1729 '(lambda (a b c d e)
1730 (declare (notinline values complex eql))
1731 (declare
1732 (optimize (compilation-speed 3)
1733 (speed 3)
1734 (debug 1)
1735 (safety 1)
1736 (space 0)))
1737 (flet ((%f10
1738 (f10-1 f10-2 f10-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)))
1744
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))
1752 (assert (not res))
1753 (assert (typep err 'program-error))))
1754
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)
1758 (return t)))
1759 (dotimes (i 100)
1760 (when (> (funcall fun t) 9)
1761 (error "bad RANDOM event"))))
1762
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))))
1766 (compile nil
1767 '(lambda (x y v)
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))
1773 nil))))
1774
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)))))
1782
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)
1789 do
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)))
1793 (dotimes (i n)
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))
1800 (funcall f array1)
1801 (setf (aref array2 i) v)
1802 (assert (every #'= array1 array2)))))))
1803
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)))
1809 (count x b))))))
1810 (assert (= (funcall fn 0) 64))
1811 (assert (= (funcall fn 1) 0)))
1812
1813 (let ((fn (compile nil '(lambda (x y)
1814 (declare (type simple-bit-vector x y))
1815 (declare (optimize speed))
1816 (equal x y)))))
1817 (assert (funcall
1818 fn
1819 (make-array 64 :element-type 'bit :initial-element 0)
1820 (make-array 64 :element-type 'bit :initial-element 0)))
1821 (assert (not
1822 (funcall
1823 fn
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)
1827 b)))))
1828
1829 ;;; MISC.535: compiler failure
1830 (let ((c0 #c(4196.088977268509d0 -15943.3603515625d0)))
1831 (assert (not (funcall
1832 (compile
1833 nil
1834 `(lambda (p1 p2)
1835 (declare (optimize speed (safety 1))
1836 (type (eql ,c0) p1)
1837 (type number p2))
1838 (eql (the (complex double-float) p1) p2)))
1839 c0 #c(12 612/979)))))
1840
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))
1846 (count 1 x))))
1847 (handler-bind ((sb-ext:compiler-note #'error))
1848 (compile nil '(lambda (x y)
1849 (declare (type simple-bit-vector x y))
1850 (equal x y))))
1851
1852 ;;; MISC.550: CAST merging in IR1 finalization caused unexpected
1853 ;;; code transformations.
1854 (assert (eql (funcall
1855 (compile
1856 nil
1857 '(lambda (p1 p2)
1858 (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
1859 (type atom p1)
1860 (type symbol p2))
1861 (or p1 (the (eql t) p2))))
1862 nil t)
1863 t))
1864
1865 ;;; MISC.548: type check weakening converts required type into
1866 ;;; optional
1867 (assert (eql t
1868 (funcall
1869 (compile
1870 nil
1871 '(lambda (p1)
1872 (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
1873 (atom (the (member f assoc-if write-line t w) p1))))
1874 t)))
1875
1876 ;;; Free special bindings only apply to the body of the binding form, not
1877 ;;; the initialization forms.
1878 (assert (eq :good
1879 (funcall (compile 'nil
1880 (lambda ()
1881 (let ((x :bad))
1882 (declare (special x))
1883 (let ((x :good))
1884 ((lambda (&optional (y x))
1885 (declare (special x)) y)))))))))
1886
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.
1892 ;;;
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
1897 #+nil
1898 (compile 'nil
1899 (LAMBDA (B)
1900 (DECLARE (TYPE (INTEGER -2 14) B))
1901 (DECLARE (IGNORABLE B))
1902 (ASH (IMAGPART B) 57)))
1903
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))))
1921 (setq i oldl)))
1922 new)))
1923 (declare (ignore fun warnings failure))
1924 (assert (not failure)))
1925
1926 ;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe
1927 ;;; sbcl-devel)
1928 (compile nil '(lambda (x y a b c)
1929 (- y (* (signum x) (sqrt (abs (- (* b x) c)))))))
1930
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)))
1936 (1+ x))))
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)
1943 (1+ x))))
1944 ;; Only the posssible word -> bignum conversion note
1945 (assert (= count1 1)))
1946
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)))
1952 (1+ x))))
1953 (compile nil '(lambda (sap)
1954 (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0)))
1955 (1+ x)))))
1956
1957 ;;; bug #399
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))
1962 (aref x 0))))
1963
1964 ;;; MISC.623: missing functions for constant-folding
1965 (assert (eql 0
1966 (funcall
1967 (compile
1968 nil
1969 '(lambda ()
1970 (declare (optimize (space 2) (speed 0) (debug 2)
1971 (compilation-speed 3) (safety 0)))
1972 (loop for lv3 below 1
1973 count (minusp
1974 (loop for lv2 below 2
1975 count (logbitp 0
1976 (bit #*1001101001001
1977 (min 12 (max 0 lv3))))))))))))
1978
1979 ;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs
1980 (assert (eql 0
1981 (funcall
1982 (compile
1983 nil
1984 '(lambda (a)
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
1990 count
1991 (logbitp 29
1992 (sbit #*10101111
1993 (min 7 (max 0 (eval '0))))))))
1994 (%f3 0 a))))
1995 0)))
1996 22)))
1997
1998 ;;; MISC.626: bandaged AVER was still wrong
1999 (assert (eql -829253
2000 (funcall
2001 (compile
2002 nil
2003 '(lambda (a)
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)))
2008 -829253)))
2009
2010 ;; MISC.628: constant-folding %LOGBITP was buggy
2011 (assert (eql t
2012 (funcall
2013 (compile
2014 nil
2015 '(lambda ()
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))))))))))
2019
2020 ;; mistyping found by random-tester
2021 (assert (zerop
2022 (funcall
2023 (compile
2024 nil
2025 '(lambda ()
2026 (declare (optimize (speed 1) (debug 0)
2027 (space 2) (safety 0) (compilation-speed 0)))
2028 (unwind-protect 0
2029 (* (/ (multiple-value-prog1 -29457482 -5602513511) 1))))))))
2030
2031 ;; aggressive constant folding (bug #400)
2032 (assert
2033 (eq t (funcall (compile nil '(lambda () (or t (the integer (/ 1 0))))))))
2034
2035 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-1))
2036 (assert
2037 (handler-case
2038 (compile nil '(lambda (x y)
2039 (when (eql x (length y))
2040 (locally
2041 (declare (optimize (speed 3)))
2042 (1+ x)))))
2043 (compiler-note () (error "The code is not optimized.")))))
2044
2045 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-2))
2046 (assert
2047 (handler-case
2048 (compile nil '(lambda (x y)
2049 (when (eql (length y) x)
2050 (locally
2051 (declare (optimize (speed 3)))
2052 (1+ x)))))
2053 (compiler-note () (error "The code is not optimized.")))))
2054
2055 (with-test (:name (:compiler :constraint-propagation :float-bounds-1))
2056 (handler-case
2057 (compile nil '(lambda (x)
2058 (declare (type (single-float * (3.0)) x))
2059 (when (<= x 2.0)
2060 (when (<= 2.0 x)
2061 x))))
2062 (compiler-note () (error "Deleted reachable code."))))
2063
2064 (with-test (:name (:compiler :constraint-propagation :float-bounds-2))
2065 (catch :note
2066 (handler-case
2067 (compile nil '(lambda (x)
2068 (declare (type single-float x))
2069 (when (< 1.0 x)
2070 (when (<= x 1.0)
2071 (error "This is unreachable.")))))
2072 (compiler-note () (throw :note nil)))
2073 (error "Unreachable code undetected.")))
2074
2075 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
2076 (catch :note
2077 (handler-case
2078 (compile nil '(lambda (x y)
2079 (when (typep y 'fixnum)
2080 (when (eql x y)
2081 (unless (typep x 'fixnum)
2082 (error "This is unreachable"))
2083 (setq y nil)))))
2084 (compiler-note () (throw :note nil)))
2085 (error "Unreachable code undetected.")))
2086
2087 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-2))
2088 (catch :note
2089 (handler-case
2090 (compile nil '(lambda (x y)
2091 (when (typep y 'fixnum)
2092 (when (eql y x)
2093 (unless (typep x 'fixnum)
2094 (error "This is unreachable"))
2095 (setq y nil)))))
2096 (compiler-note () (throw :note nil)))
2097 (error "Unreachable code undetected.")))
2098
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))
2106 (m (if (= e 0)
2107 (ash (logand bits #x7fffff) 1)
2108 (logior (logand bits #x7fffff) #x800000))))
2109 (float (* s m (expt 2 (- e 150))))))))
2110
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)
2115 (compile nil
2116 '(lambda (days shift)
2117 (declare (type fixnum shift days))
2118 (let* ((result 0)
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)
2125 (setf result
2126 (logior result
2127 (the fixnum
2128 (if (< source-day first-wrapping-day)
2129 (+ source-day canonicalized-shift)
2130 (- (+ source-day
2131 canonicalized-shift) 7)))))))
2132 result))))
2133
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)))
2139 :bad1))
2140 (%f8 (%f8 0)))
2141 :bad2))
2142 :good))))
2143 (assert (eq (funcall (compile nil f)) :good)))
2144
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))
2148 (keywordp p1)))
2149 (f (compile nil l)))
2150 (assert (funcall f :good))
2151 (assert (nth-value 1 (ignore-errors (funcall f 42)))))
2152
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
2162 summing i)
2163 x)))
2164 (assert (= a (random most-positive-fixnum))))
2165
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)) #())))
2171 0))
2172 (apply #'%f3 0 nil)))))
2173 (assert (zerop (funcall (compile nil form)))))
2174
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))))
2179
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)))))
2188
2189 ;;; overconfident primitive type computation leading to bogus type
2190 ;;; checking.
2191 (let* ((form1 '(lambda (x)
2192 (declare (type (and condition function) x))
2193 x))
2194 (fun1 (compile nil form1))
2195 (form2 '(lambda (x)
2196 (declare (type (and standard-object function) x))
2197 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)))
2203
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.
2207 ;;;
2208 ;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
2209 (compile nil '(lambda () (let* () (declare (values list)))))
2210
2211
2212 ;;; test for some problems with too large immediates in x86-64 modular
2213 ;;; arithmetic vops
2214 (compile nil '(lambda (x) (declare (fixnum x))
2215 (logand most-positive-fixnum (logxor x most-positive-fixnum))))
2216
2217 (compile nil '(lambda (x) (declare (fixnum x))
2218 (logand most-positive-fixnum (+ x most-positive-fixnum))))
2219
2220 (compile nil '(lambda (x) (declare (fixnum x))
2221 (logand most-positive-fixnum (* x most-positive-fixnum))))
2222
2223 ;;; bug 256.b
2224 (assert (let (warned-p)
2225 (handler-bind ((warning (lambda (w) (setf warned-p t))))
2226 (compile nil
2227 '(lambda (x)
2228 (list (let ((y (the real x)))
2229 (unless (floatp y) (error ""))
2230 y)
2231 (integer-length x)))))
2232 warned-p))
2233
2234 ;; Dead / in safe code
2235 (with-test (:name :safe-dead-/)
2236 (assert (eq :error
2237 (handler-case
2238 (funcall (compile nil
2239 '(lambda (x y)
2240 (declare (optimize (safety 3)))
2241 (/ x y)
2242 (+ x y)))
2243 1
2244 0)
2245 (division-by-zero ()
2246 :error)))))
2247
2248 ;;; Dead unbound variable (bug 412)
2249 (with-test (:name :dead-unbound)
2250 (assert (eq :error
2251 (handler-case
2252 (funcall (compile nil
2253 '(lambda ()
2254 #:unbound
2255 42)))
2256 (unbound-variable ()
2257 :error)))))
2258
2259 ;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR.
2260 (handler-bind ((sb-ext:compiler-note 'error))
2261 (assert
2262 (equalp #(2 3)
2263 (funcall (compile nil `(lambda (s p e)
2264 (declare (optimize speed)
2265 (simple-vector s))
2266 (subseq s p e)))
2267 (vector 1 2 3 4)
2268 1
2269 3))))
2270
2271 ;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR.
2272 (handler-bind ((sb-ext:compiler-note 'error))
2273 (assert
2274 (equalp #(1 2 3 4)
2275 (funcall (compile nil `(lambda (s)
2276 (declare (optimize speed)
2277 (simple-vector s))
2278 (copy-seq s)))
2279 (vector 1 2 3 4)))))
2280
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)))))
2283
2284 ;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too
2285 ;;; large bignums to floats
2286 (dolist (op '(* / + -))
2287 (let ((fun (compile
2288 nil
2289 `(lambda (x)
2290 (declare (type (integer 0 #.(* 2 (truncate most-positive-double-float))) x))
2291 (,op 0.0d0 x)))))
2292 (loop repeat 10
2293 do (let ((arg (random (truncate most-positive-double-float))))
2294 (assert (eql (funcall fun arg)
2295 (funcall op 0.0d0 arg)))))))
2296
2297 (with-test (:name :high-debug-known-function-inlining)
2298 (let ((fun (compile nil
2299 '(lambda ()
2300 (declare (optimize (debug 3)) (inline append))
2301 (let ((fun (lambda (body)
2302 (append
2303 (first body)
2304 nil))))
2305 (funcall fun
2306 '((foo (bar)))))))))
2307 (funcall fun)))
2308
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))
2312 (if (block nil
2313 (some-unknown-function
2314 (lambda ()
2315 (return (member x y))))
2316 t)
2317 t
2318 (error "~a" y)))))
2319
2320 ;;; Compiling W-P-O when the pinned objects are known to be fixnums
2321 ;;; or characters.
2322 (compile nil '(lambda (x y)
2323 (declare (fixnum y) (character x))
2324 (sb-sys:with-pinned-objects (x y)
2325 (some-random-function))))
2326
2327 ;;; *CHECK-CONSISTENCY* and TRULY-THE
2328
2329 (with-test (:name :bug-423)
2330 (let ((sb-c::*check-consistency* t))
2331 (handler-bind ((warning #'error))
2332 (flet ((make-lambda (type)
2333 `(lambda (x)
2334 ((lambda (z)
2335 (if (listp z)
2336 (let ((q (truly-the list z)))
2337 (length q))
2338 (if (arrayp z)
2339 (let ((q (truly-the vector z)))
2340 (length q))
2341 (error "oops"))))
2342 (the ,type x)))))
2343 (compile nil (make-lambda 'list))
2344 (compile nil (make-lambda 'vector))))))
tcr's SBCL random hacking branch.