?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
1.0.37.57: better DEFMETHOD pretty-printing
[sbcl/pkhuong.git] / tests / compiler.pure.lisp
blob5ef755f79d4550a0fd3d1d378e326610c0f84879
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 (load "compiler-test-util.lisp")
17
18 ;; The tests in this file assume that EVAL will use the compiler
19 (when (eq sb-ext:*evaluator-mode* :interpret)
20 (invoke-restart 'run-tests::skip-file))
21
22 ;;; Exercise a compiler bug (by crashing the compiler).
23 ;;;
24 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
25 ;;; (2000-09-06 on cmucl-imp).
26 ;;;
27 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
28 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
29 (funcall (compile nil
30 '(lambda ()
31 (labels ((fun1 ()
32 (fun2))
33 (fun2 ()
34 (when nil
35 (tagbody
36 tag
37 (fun2)
38 (go tag)))
39 (when nil
40 (tagbody
41 tag
42 (fun1)
43 (go tag)))))
44
45 (fun1)
46 nil))))
47
48 ;;; Exercise a compiler bug (by crashing the compiler).
49 ;;;
50 ;;; Tim Moore gave a patch for this bug in CMU CL 2000-05-24 on
51 ;;; cmucl-imp, and Martin Atzmueller applied it to SBCL.
52 (funcall (compile nil
53 '(lambda (x)
54 (or (integerp x)
55 (block used-by-some-y?
56 (flet ((frob (stk)
57 (dolist (y stk)
58 (unless (rejected? y)
59 (return-from used-by-some-y? t)))))
60 (declare (inline frob))
61 (frob (rstk x))
62 (frob (mrstk x)))
63 nil))))
64 13)
65
66 ;;; bug 112, reported by Martin Atzmueller 2001-06-25 (originally
67 ;;; from Bruno Haible in CMU CL bugs collection), fixed by
68 ;;; Alexey Dejneka 2002-01-27
69 (assert (= 1 ; (used to give 0 under bug 112)
70 (let ((x 0))
71 (declare (special x))
72 (let ((x 1))
73 (let ((y x))
74 (declare (special x)) y)))))
75 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
76 (let ((x 0))
77 (declare (special x))
78 (let ((x 1))
79 (let ((y x) (x 5))
80 (declare (special x)) y)))))
81
82 ;;; another LET-related bug fixed by Alexey Dejneka at the same
83 ;;; time as bug 112
84 (multiple-value-bind (fun warnings-p failure-p)
85 ;; should complain about duplicate variable names in LET binding
86 (compile nil
87 '(lambda ()
88 (let (x
89 (x 1))
90 (list x))))
91 (declare (ignore warnings-p))
92 (assert (functionp fun))
93 (assert failure-p))
94
95 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
96 ;;; Lichteblau 2002-05-21)
97 (progn
98 (multiple-value-bind (fun warnings-p failure-p)
99 (compile nil
100 ;; Compiling this code should cause a STYLE-WARNING
101 ;; about *X* looking like a special variable but not
102 ;; being one.
103 '(lambda (n)
104 (let ((*x* n))
105 (funcall (symbol-function 'x-getter))
106 (print *x*))))
107 (assert (functionp fun))
108 (assert warnings-p)
109 (assert (not failure-p)))
110 (multiple-value-bind (fun warnings-p failure-p)
111 (compile nil
112 ;; Compiling this code should not cause a warning
113 ;; (because the DECLARE turns *X* into a special
114 ;; variable as its name suggests it should be).
115 '(lambda (n)
116 (let ((*x* n))
117 (declare (special *x*))
118 (funcall (symbol-function 'x-getter))
119 (print *x*))))
120 (assert (functionp fun))
121 (assert (not warnings-p))
122 (assert (not failure-p))))
123
124 ;;; a bug in 0.7.4.11
125 (dolist (i '(a b 1 2 "x" "y"))
126 ;; In sbcl-0.7.4.11, the compiler tried to source-transform the
127 ;; TYPEP here but got confused and died, doing
128 ;; (ASSOC '(AND INTEGERP (SATISFIES PLUSP)))
129 ;; *BACKEND-TYPE-PREDICATES*
130 ;; :TEST #'TYPE=)
131 ;; and blowing up because TYPE= tried to call PLUSP on the
132 ;; characters of the MEMBER-TYPE representing STANDARD-CHAR.
133 (when (typep i '(and integer (satisfies oddp)))
134 (print i)))
135 (dotimes (i 14)
136 (when (typep i '(and integer (satisfies oddp)))
137 (print i)))
138
139 ;;; bug 156 (reported by APD sbcl-devel 2002-04-12, fixed by CSR patch
140 ;;; sbcl-devel 2002-07-02): FUNCTION-LAMBDA-EXPRESSION of
141 ;;; interactively-compiled functions was broken by sleaziness and
142 ;;; confusion in the assault on 0.7.0, so this expression used to
143 ;;; signal TYPE-ERROR when it found NIL instead of a DEBUG-SOURCE.
144 (eval '(function-lambda-expression #'(lambda (x) x)))
145
146 ;;; bug caught and fixed by Raymond Toy cmucl-imp 2002-07-10: &REST
147 ;;; variable is not optional.
148 (assert (null (ignore-errors (eval '(funcall (lambda (&rest) 12))))))
149
150 ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
151 ;;; a while; fixed by CSR 2002-07-18
152 (multiple-value-bind (value error)
153 (ignore-errors (some-undefined-function))
154 (assert (null value))
155 (assert (eq (cell-error-name error) 'some-undefined-function)))
156
157 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
158 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
159 (assert (null (ignore-errors (eval '(lambda ("foo") 12)))))
160 (assert (ignore-errors (eval '(lambda (foo) 12))))
161 (assert (null (ignore-errors (eval '(lambda (&optional 12) "foo")))))
162 (assert (ignore-errors (eval '(lambda (&optional twelve) "foo"))))
163 (assert (null (ignore-errors (eval '(lambda (&optional (12 12)) "foo")))))
164 (assert (ignore-errors (eval '(lambda (&optional (twelve 12)) "foo"))))
165 (assert (null (ignore-errors (eval '(lambda (&key #\c) "foo")))))
166 (assert (ignore-errors (eval '(lambda (&key c) "foo"))))
167 (assert (null (ignore-errors (eval '(lambda (&key (#\c #\c)) "foo")))))
168 (assert (ignore-errors (eval '(lambda (&key (c #\c)) "foo"))))
169 (assert (null (ignore-errors (eval '(lambda (&key ((#\c #\c) #\c)) "foo")))))
170 (assert (ignore-errors (eval '(lambda (&key ((:c cbyanyothername) #\c)) "foo"))))
171
172 ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel
173 ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER
174 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
175 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14)
176 17))
177
178 ;;; bug 181: bad type specifier dropped compiler into debugger
179 (assert (list (compile nil '(lambda (x)
180 (declare (type (0) x))
181 x))))
182
183 (let ((f (compile nil '(lambda (x)
184 (make-array 1 :element-type '(0))))))
185 (assert (null (ignore-errors (funcall f)))))
186
187 ;;; the following functions must not be flushable
188 (dolist (form '((make-sequence 'fixnum 10)
189 (concatenate 'fixnum nil)
190 (map 'fixnum #'identity nil)
191 (merge 'fixnum nil nil #'<)))
192 (assert (not (eval `(locally (declare (optimize (safety 0)))
193 (ignore-errors (progn ,form t)))))))
194
195 (dolist (form '((values-list (car (list '(1 . 2))))
196 (fboundp '(set bet))
197 (atan #c(1 1) (car (list #c(2 2))))
198 (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5))
199 (nthcdr (car (list 5)) '(1 2 . 3))))
200 (assert (not (eval `(locally (declare (optimize (safety 3)))
201 (ignore-errors (progn ,form t)))))))
202
203 ;;; feature: we shall complain if functions which are only useful for
204 ;;; their result are called and their result ignored.
205 (loop for (form expected-des) in
206 '(((progn (nreverse (list 1 2)) t)
207 "The return value of NREVERSE should not be discarded.")
208 ((progn (nreconc (list 1 2) (list 3 4)) t)
209 "The return value of NRECONC should not be discarded.")
210 ((locally
211 (declare (inline sort))
212 (sort (list 1 2) #'<) t)
213 ;; FIXME: it would be nice if this warned on non-inlined sort
214 ;; but the current simple boolean function attribute
215 ;; can't express the condition that would be required.
216 "The return value of STABLE-SORT-LIST should not be discarded.")
217 ((progn (sort (vector 1 2) #'<) t)
218 ;; Apparently, SBCL (but not CL) guarantees in-place vector
219 ;; sort, so no warning.
220 nil)
221 ((progn (delete 2 (list 1 2)) t)
222 "The return value of DELETE should not be discarded.")
223 ((progn (delete-if #'evenp (list 1 2)) t)
224 ("The return value of DELETE-IF should not be discarded."))
225 ((progn (delete-if #'evenp (vector 1 2)) t)
226 ("The return value of DELETE-IF should not be discarded."))
227 ((progn (delete-if-not #'evenp (list 1 2)) t)
228 "The return value of DELETE-IF-NOT should not be discarded.")
229 ((progn (delete-duplicates (list 1 2)) t)
230 "The return value of DELETE-DUPLICATES should not be discarded.")
231 ((progn (merge 'list (list 1 3) (list 2 4) #'<) t)
232 "The return value of MERGE should not be discarded.")
233 ((progn (nreconc (list 1 3) (list 2 4)) t)
234 "The return value of NRECONC should not be discarded.")
235 ((progn (nunion (list 1 3) (list 2 4)) t)
236 "The return value of NUNION should not be discarded.")
237 ((progn (nintersection (list 1 3) (list 2 4)) t)
238 "The return value of NINTERSECTION should not be discarded.")
239 ((progn (nset-difference (list 1 3) (list 2 4)) t)
240 "The return value of NSET-DIFFERENCE should not be discarded.")
241 ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t)
242 "The return value of NSET-EXCLUSIVE-OR should not be discarded."))
243 for expected = (if (listp expected-des)
244 expected-des
245 (list expected-des))
246 do
247 (multiple-value-bind (fun warnings-p failure-p)
248 (handler-bind ((style-warning (lambda (c)
249 (if expected
250 (let ((expect-one (pop expected)))
251 (assert (search expect-one
252 (with-standard-io-syntax
253 (let ((*print-right-margin* nil))
254 (princ-to-string c))))
255 ()
256 "~S should have warned ~S, but instead warned: ~A"
257 form expect-one c))
258 (error "~S shouldn't give a(nother) warning, but did: ~A" form c)))))
259 (compile nil `(lambda () ,form)))
260 (declare (ignore warnings-p))
261 (assert (functionp fun))
262 (assert (null expected)
263 ()
264 "~S should have warned ~S, but didn't."
265 form expected)
266 (assert (not failure-p))))
267
268 ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers
269 ;;; to cause errors in the compiler. Fixed by CSR in 0.7.8.10
270 (assert (list (compile nil '(lambda (x) (map 'simple-array 'identity x)))))
271
272 ;;; bug 129: insufficient syntax checking in MACROLET
273 (multiple-value-bind (result error)
274 (ignore-errors (eval '(macrolet ((foo x `',x)) (foo 1 2 3))))
275 (assert (null result))
276 (assert (typep error 'error)))
277
278 ;;; bug 124: environment of MACROLET-introduced macro expanders
279 (assert (equal
280 (macrolet ((mext (x) `(cons :mext ,x)))
281 (macrolet ((mint (y) `'(:mint ,(mext y))))
282 (list (mext '(1 2))
283 (mint (1 2)))))
284 '((:MEXT 1 2) (:MINT (:MEXT 1 2)))))
285
286 ;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced
287 ;;; symbol is declared to be SPECIAL
288 (multiple-value-bind (result error)
289 (ignore-errors (funcall (lambda ()
290 (symbol-macrolet ((s '(1 2)))
291 (declare (special s))
292 s))))
293 (assert (null result))
294 (assert (typep error 'program-error)))
295
296 ;;; ECASE should treat a bare T as a literal key
297 (multiple-value-bind (result error)
298 (ignore-errors (ecase 1 (t 0)))
299 (assert (null result))
300 (assert (typep error 'type-error)))
301
302 (multiple-value-bind (result error)
303 (ignore-errors (ecase 1 (t 0) (1 2)))
304 (assert (eql result 2))
305 (assert (null error)))
306
307 ;;; FTYPE should accept any functional type specifier
308 (compile nil '(lambda (x) (declare (ftype function f)) (f x)))
309
310 ;;; FUNCALL of special operators and macros should signal an
311 ;;; UNDEFINED-FUNCTION error
312 (multiple-value-bind (result error)
313 (ignore-errors (funcall 'quote 1))
314 (assert (null result))
315 (assert (typep error 'undefined-function))
316 (assert (eq (cell-error-name error) 'quote)))
317 (multiple-value-bind (result error)
318 (ignore-errors (funcall 'and 1))
319 (assert (null result))
320 (assert (typep error 'undefined-function))
321 (assert (eq (cell-error-name error) 'and)))
322
323 ;;; PSETQ should behave when given complex symbol-macro arguments
324 (multiple-value-bind (sequence index)
325 (symbol-macrolet ((x (aref a (incf i)))
326 (y (aref a (incf i))))
327 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
328 (i 0))
329 (psetq x (aref a (incf i))
330 y (aref a (incf i)))
331 (values a i)))
332 (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9)))
333 (assert (= index 4)))
334
335 (multiple-value-bind (result error)
336 (ignore-errors
337 (let ((x (list 1 2)))
338 (psetq (car x) 3)
339 x))
340 (assert (null result))
341 (assert (typep error 'program-error)))
342
343 ;;; COPY-SEQ should work on known-complex vectors:
344 (assert (equalp #(1)
345 (let ((v (make-array 0 :fill-pointer 0)))
346 (vector-push-extend 1 v)
347 (copy-seq v))))
348
349 ;;; to support INLINE functions inside MACROLET, it is necessary for
350 ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in
351 ;;; certain circumstances, one of which is when compile is called from
352 ;;; top-level.
353 (assert (equal
354 (function-lambda-expression
355 (compile nil '(lambda (x) (block nil (print x)))))
356 '(lambda (x) (block nil (print x)))))
357
358 ;;; bug 62: too cautious type inference in a loop
359 (assert (nth-value
360 2
361 (compile nil
362 '(lambda (a)
363 (declare (optimize speed (safety 0)))
364 (typecase a
365 (array (loop (print (car a)))))))))
366
367 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
368 ;;; failure
369 (compile nil
370 '(lambda (key tree collect-path-p)
371 (let ((lessp (key-lessp tree))
372 (equalp (key-equalp tree)))
373 (declare (type (function (t t) boolean) lessp equalp))
374 (let ((path '(nil)))
375 (loop for node = (root-node tree)
376 then (if (funcall lessp key (node-key node))
377 (left-child node)
378 (right-child node))
379 when (null node)
380 do (return (values nil nil nil))
381 do (when collect-path-p
382 (push node path))
383 (when (funcall equalp key (node-key node))
384 (return (values node path t))))))))
385
386 ;;; CONSTANTLY should return a side-effect-free function (bug caught
387 ;;; by Paul Dietz' test suite)
388 (let ((i 0))
389 (let ((fn (constantly (progn (incf i) 1))))
390 (assert (= i 1))
391 (assert (= (funcall fn) 1))
392 (assert (= i 1))
393 (assert (= (funcall fn) 1))
394 (assert (= i 1))))
395
396 ;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version)
397 (loop for (fun warns-p) in
398 '(((lambda (&optional *x*) *x*) t)
399 ((lambda (&optional *x* &rest y) (values *x* y)) t)
400 ((lambda (&optional *print-length*) (values *print-length*)) nil)
401 ((lambda (&optional *print-length* &rest y) (values *print-length* y)) nil)
402 ((lambda (&optional *x*) (declare (special *x*)) (values *x*)) nil)
403 ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil))
404 for real-warns-p = (nth-value 1 (compile nil fun))
405 do (assert (eq warns-p real-warns-p)))
406
407 ;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26
408 (assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y)))
409 '(1 2))
410 '((2) 1)))
411
412 ;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd
413 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
414 (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))
415
416 (assert
417 (raises-error? (multiple-value-bind (a b c)
418 (eval '(truncate 3 4))
419 (declare (integer c))
420 (list a b c))
421 type-error))
422
423 (assert (equal (multiple-value-list (the (values &rest integer)
424 (eval '(values 3))))
425 '(3)))
426
427 ;;; Bug relating to confused representation for the wild function
428 ;;; type:
429 (assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
430
431 ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz'
432 ;;; test suite)
433 (assert (eql (macrolet ((foo () 1))
434 (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env)
435 x))
436 (%f)))
437 1))
438
439 ;;; MACROLET should check for duplicated names
440 (dolist (ll '((x (z x))
441 (x y &optional z x w)
442 (x y &optional z z)
443 (x &rest x)
444 (x &rest (y x))
445 (x &optional (y nil x))
446 (x &optional (y nil y))
447 (x &key x)
448 (x &key (y nil x))
449 (&key (y nil z) (z nil w))
450 (&whole x &optional x)
451 (&environment x &whole x)))
452 (assert (nth-value 2
453 (handler-case
454 (compile nil
455 `(lambda ()
456 (macrolet ((foo ,ll nil)
457 (bar (&environment env)
458 `',(macro-function 'foo env)))
459 (bar))))
460 (error (c)
461 (values nil t t))))))
462
463 (assert (typep (eval `(the arithmetic-error
464 ',(make-condition 'arithmetic-error)))
465 'arithmetic-error))
466
467 (assert (not (nth-value
468 2 (compile nil '(lambda ()
469 (make-array nil :initial-element 11))))))
470
471 (assert (raises-error? (funcall (eval #'open) "assertoid.lisp"
472 :external-format '#:nonsense)))
473 (assert (raises-error? (funcall (eval #'load) "assertoid.lisp"
474 :external-format '#:nonsense)))
475
476 (assert (= (the (values integer symbol) (values 1 'foo 13)) 1))
477
478 (let ((f (compile nil
479 '(lambda (v)
480 (declare (optimize (safety 3)))
481 (list (the fixnum (the (real 0) (eval v))))))))
482 (assert (raises-error? (funcall f 0.1) type-error))
483 (assert (raises-error? (funcall f -1) type-error)))
484
485 ;;; the implicit block does not enclose lambda list
486 (let ((forms '((defmacro #1=#:foo (&optional (x (return-from #1#))))
487 #+nil(macrolet ((#2=#:foo (&optional (x (return-from #2#))))))
488 (define-compiler-macro #3=#:foo (&optional (x (return-from #3#))))
489 (deftype #4=#:foo (&optional (x (return-from #4#))))
490 (define-setf-expander #5=#:foo (&optional (x (return-from #5#))))
491 (defsetf #6=#:foo (&optional (x (return-from #6#))) ()))))
492 (dolist (form forms)
493 (assert (nth-value 2 (compile nil `(lambda () ,form))))))
494
495 (assert (nth-value 2 (compile nil
496 '(lambda ()
497 (svref (make-array '(8 9) :adjustable t) 1)))))
498
499 ;;; CHAR= did not check types of its arguments (reported by Adam Warner)
500 (raises-error? (funcall (compile nil '(lambda (x y z) (char= x y z)))
501 #\a #\b nil)
502 type-error)
503 (raises-error? (funcall (compile nil
504 '(lambda (x y z)
505 (declare (optimize (speed 3) (safety 3)))
506 (char/= x y z)))
507 nil #\a #\a)
508 type-error)
509
510 ;;; Compiler lost return type of MAPCAR and friends
511 (dolist (fun '(mapcar mapc maplist mapl))
512 (assert (nth-value 2 (compile nil
513 `(lambda (x)
514 (1+ (,fun #'print x)))))))
515
516 (assert (nth-value 2 (compile nil
517 '(lambda ()
518 (declare (notinline mapcar))
519 (1+ (mapcar #'print '(1 2 3)))))))
520
521 ;;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant
522 ;;; index was effectless
523 (let ((f (compile nil '(lambda (a v)
524 (declare (type simple-bit-vector a) (type bit v))
525 (declare (optimize (speed 3) (safety 0)))
526 (setf (aref a 0) v)
527 a))))
528 (let ((y (make-array 2 :element-type 'bit :initial-element 0)))
529 (assert (equal y #*00))
530 (funcall f y 1)
531 (assert (equal y #*10))))
532
533 ;;; use of declared array types
534 (handler-bind ((sb-ext:compiler-note #'error))
535 (compile nil '(lambda (x)
536 (declare (type (simple-array (simple-string 3) (5)) x)
537 (optimize speed))
538 (aref (aref x 0) 0))))
539
540 (handler-bind ((sb-ext:compiler-note #'error))
541 (compile nil '(lambda (x)
542 (declare (type (simple-array (simple-array bit (10)) (10)) x)
543 (optimize speed))
544 (1+ (aref (aref x 0) 0)))))
545
546 ;;; compiler failure
547 (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0)))))))
548 (assert (funcall f 1d0)))
549
550 (compile nil '(lambda (x)
551 (declare (double-float x))
552 (let ((y (* x pi)))
553 (atan y y))))
554
555 ;;; bogus optimization of BIT-NOT
556 (multiple-value-bind (result x)
557 (eval '(let ((x (eval #*1001)))
558 (declare (optimize (speed 2) (space 3))
559 (type (bit-vector) x))
560 (values (bit-not x nil) x)))
561 (assert (equal x #*1001))
562 (assert (equal result #*0110)))
563
564 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
565 (handler-bind ((sb-ext:compiler-note #'error))
566 (assert (equalp (funcall
567 (compile
568 nil
569 '(lambda ()
570 (let ((x (make-sequence 'vector 10 :initial-element 'a)))
571 (setf (aref x 4) 'b)
572 x))))
573 #(a a a a b a a a a a))))
574
575 ;;; this is not a check for a bug, but rather a test of compiler
576 ;;; quality
577 (dolist (type '((integer 0 *) ; upper bound
578 (real (-1) *)
579 float ; class
580 (real * (-10)) ; lower bound
581 ))
582 (assert (nth-value
583 1 (compile nil
584 `(lambda (n)
585 (declare (optimize (speed 3) (compilation-speed 0)))
586 (loop for i from 1 to (the (integer -17 10) n) by 2
587 collect (when (> (random 10) 5)
588 (the ,type (- i 11)))))))))
589
590 ;;; bug 278b
591 ;;;
592 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
593 ;;; compiler has an optimized VOP for +; so this code should cause an
594 ;;; efficiency note.
595 (assert (eq (block nil
596 (handler-case
597 (compile nil '(lambda (i)
598 (declare (optimize speed))
599 (declare (type integer i))
600 (+ i 2)))
601 (sb-ext:compiler-note (c) (return :good))))
602 :good))
603
604 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
605 ;;; symbol macros
606 (assert (not (nth-value 1 (compile nil '(lambda (u v)
607 (symbol-macrolet ((x u)
608 (y v))
609 (declare (ignore x)
610 (ignorable y))
611 (list u v)))))))
612
613 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
614 (loop for (x type) in
615 '((14 integer)
616 (14 rational)
617 (-14/3 (rational -8 11))
618 (3s0 short-float)
619 (4f0 single-float)
620 (5d0 double-float)
621 (6l0 long-float)
622 (14 real)
623 (13/2 real)
624 (2s0 real)
625 (2d0 real)
626 (#c(-3 4) (complex fixnum))
627 (#c(-3 4) (complex rational))
628 (#c(-3/7 4) (complex rational))
629 (#c(2s0 3s0) (complex short-float))
630 (#c(2f0 3f0) (complex single-float))
631 (#c(2d0 3d0) (complex double-float))
632 (#c(2l0 3l0) (complex long-float))
633 (#c(2d0 3s0) (complex float))
634 (#c(2 3f0) (complex real))
635 (#c(2 3d0) (complex real))
636 (#c(-3/7 4) (complex real))
637 (#c(-3/7 4) complex)
638 (#c(2 3l0) complex))
639 do (dolist (zero '(0 0s0 0f0 0d0 0l0))
640 (dolist (real-zero (list zero (- zero)))
641 (let* ((src `(lambda (x) (expt (the ,type x) ,real-zero)))
642 (fun (compile nil src))
643 (result (1+ (funcall (eval #'*) x real-zero))))
644 (assert (eql result (funcall fun x)))))))
645
646 ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
647 ;;; wasn't recognized as a good type specifier.
648 (let ((fun (lambda (x y)
649 (declare (type (integer -1 0) x y) (optimize speed))
650 (logxor x y))))
651 (assert (= (funcall fun 0 0) 0))
652 (assert (= (funcall fun 0 -1) -1))
653 (assert (= (funcall fun -1 -1) 0)))
654
655 ;;; from PFD's torture test, triggering a bug in our effective address
656 ;;; treatment.
657 (compile
658 nil
659 `(lambda (a b)
660 (declare (type (integer 8 22337) b))
661 (logandc2
662 (logandc2
663 (* (logandc1 (max -29303 b) 4) b)
664 (abs (logorc1 (+ (logandc1 -11 b) 2607688420) -31153924)))
665 (logeqv (max a 0) b))))
666
667 ;;; Alpha floating point modes weren't being reset after an exception,
668 ;;; leading to an exception on the second compile, below.
669 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
670 (handler-case (/ 1.0 0.0)
671 ;; provoke an exception
672 (arithmetic-error ()))
673 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
674
675 ;;; bug reported by Paul Dietz: component last block does not have
676 ;;; start ctran
677 (compile nil
678 '(lambda ()
679 (declare (notinline + logand)
680 (optimize (speed 0)))
681 (LOGAND
682 (BLOCK B5
683 (FLET ((%F1 ()
684 (RETURN-FROM B5 -220)))
685 (LET ((V7 (%F1)))
686 (+ 359749 35728422))))
687 -24076)))
688
689 ;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
690 (assert (= (funcall (compile nil `(lambda (b)
691 (declare (optimize (speed 3))
692 (type (integer 2 152044363) b))
693 (rem b (min -16 0))))
694 108251912)
695 8))
696
697 (assert (= (funcall (compile nil `(lambda (c)
698 (declare (optimize (speed 3))
699 (type (integer 23062188 149459656) c))
700 (mod c (min -2 0))))
701 95019853)
702 -1))
703
704 ;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
705 (compile nil
706 '(LAMBDA (A B C)
707 (BLOCK B6
708 (LOGEQV (REM C -6758)
709 (REM B (MAX 44 (RETURN-FROM B6 A)))))))
710
711 (compile nil '(lambda ()
712 (block nil
713 (flet ((foo (x y) (if (> x y) (print x) (print y))))
714 (foo 1 2)
715 (bar)
716 (foo (return 14) 2)))))
717
718 ;;; bug in Alpha backend: not enough sanity checking of arguments to
719 ;;; instructions
720 (assert (= (funcall (compile nil
721 '(lambda (x)
722 (declare (fixnum x))
723 (ash x -257)))
724 1024)
725 0))
726
727 ;;; bug found by WHN and pfdietz: compiler failure while referencing
728 ;;; an entry point inside a deleted lambda
729 (compile nil '(lambda ()
730 (let (r3533)
731 (flet ((bbfn ()
732 (setf r3533
733 (progn
734 (flet ((truly (fn bbd)
735 (let (r3534)
736 (let ((p3537 nil))
737 (unwind-protect
738 (multiple-value-prog1
739 (progn
740 (setf r3534
741 (progn
742 (bubf bbd t)
743 (flet ((c-3536 ()
744 (funcall fn)))
745 (cdec #'c-3536
746 (vector bbd))))))
747 (setf p3537 t))
748 (unless p3537
749 (error "j"))))
750 r3534))
751 (c (pd) (pdc pd)))
752 (let ((a (smock a))
753 (b (smock b))
754 (b (smock c)))))))))
755 (wum #'bbfn "hc3" (list)))
756 r3533)))
757 (compile nil '(lambda () (flet ((%f () (unwind-protect nil))) nil)))
758
759 ;;; the strength reduction of constant multiplication used (before
760 ;;; sbcl-0.8.4.x) to lie to the compiler. This meant that, under
761 ;;; certain circumstances, the compiler would derive that a perfectly
762 ;;; reasonable multiplication never returned, causing chaos. Fixed by
763 ;;; explicitly doing modular arithmetic, and relying on the backends
764 ;;; being smart.
765 (assert (= (funcall
766 (compile nil
767 '(lambda (x)
768 (declare (type (integer 178956970 178956970) x)
769 (optimize speed))
770 (* x 24)))
771 178956970)
772 4294967280))
773
774 ;;; bug in modular arithmetic and type specifiers
775 (assert (= (funcall (compile nil (lambda (x) (logand x x 0)))
776 -1)
777 0))
778
779 ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP
780 ;;; produced wrong result for shift >=32 on X86
781 (assert (= 0 (funcall
782 (compile nil
783 '(lambda (a)
784 (declare (type (integer 4303063 101130078) a))
785 (mask-field (byte 18 2) (ash a 77))))
786 57132532)))
787 ;;; rewrite the test case to get the unsigned-byte 32/64
788 ;;; implementation even after implementing some modular arithmetic
789 ;;; with signed-byte 30:
790 (assert (= 0 (funcall
791 (compile nil
792 '(lambda (a)
793 (declare (type (integer 4303063 101130078) a))
794 (mask-field (byte 30 2) (ash a 77))))
795 57132532)))
796 (assert (= 0 (funcall
797 (compile nil
798 '(lambda (a)
799 (declare (type (integer 4303063 101130078) a))
800 (mask-field (byte 64 2) (ash a 77))))
801 57132532)))
802 ;;; and a similar test case for the signed masking extension (not the
803 ;;; final interface, so change the call when necessary):
804 (assert (= 0 (funcall
805 (compile nil
806 '(lambda (a)
807 (declare (type (integer 4303063 101130078) a))
808 (sb-c::mask-signed-field 30 (ash a 77))))
809 57132532)))
810 (assert (= 0 (funcall
811 (compile nil
812 '(lambda (a)
813 (declare (type (integer 4303063 101130078) a))
814 (sb-c::mask-signed-field 61 (ash a 77))))
815 57132532)))
816
817 ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
818 ;;; type check regeneration
819 (assert (eql (funcall
820 (compile nil '(lambda (a c)
821 (declare (type (integer 185501219873 303014665162) a))
822 (declare (type (integer -160758 255724) c))
823 (declare (optimize (speed 3)))
824 (let ((v8
825 (- -554046873252388011622614991634432
826 (ignore-errors c)
827 (unwind-protect 2791485))))
828 (max (ignore-errors a)
829 (let ((v6 (- v8 (restart-case 980))))
830 (min v8 v6))))))
831 259448422916 173715)
832 259448422916))
833 (assert (eql (funcall
834 (compile nil '(lambda (a b)
835 (min -80
836 (abs
837 (ignore-errors
838 (+
839 (logeqv b
840 (block b6
841 (return-from b6
842 (load-time-value -6876935))))
843 (if (logbitp 1 a) b (setq a -1522022182249))))))))
844 -1802767029877 -12374959963)
845 -80))
846
847 ;;; various MISC.*, related to NODEs/LVARs with derived type NIL
848 (assert (eql (funcall (compile nil '(lambda (c)
849 (declare (type (integer -3924 1001809828) c))
850 (declare (optimize (speed 3)))
851 (min 47 (if (ldb-test (byte 2 14) c)
852 -570344431
853 (ignore-errors -732893970)))))
854 705347625)
855 -570344431))
856 (assert (eql (funcall
857 (compile nil '(lambda (b)
858 (declare (type (integer -1598566306 2941) b))
859 (declare (optimize (speed 3)))
860 (max -148949 (ignore-errors b))))
861 0)
862 0))
863 (assert (eql (funcall
864 (compile nil '(lambda (b c)
865 (declare (type (integer -4 -3) c))
866 (block b7
867 (flet ((%f1 (f1-1 f1-2 f1-3)
868 (if (logbitp 0 (return-from b7
869 (- -815145138 f1-2)))
870 (return-from b7 -2611670)
871 99345)))
872 (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2)))
873 b)))))
874 2950453607 -4)
875 -815145134))
876 (assert (eql (funcall
877 (compile nil
878 '(lambda (b c)
879 (declare (type (integer -29742055786 23602182204) b))
880 (declare (type (integer -7409 -2075) c))
881 (declare (optimize (speed 3)))
882 (floor
883 (labels ((%f2 ()
884 (block b6
885 (ignore-errors (return-from b6
886 (if (= c 8) b 82674))))))
887 (%f2)))))
888 22992834060 -5833)
889 82674))
890 (assert (equal (multiple-value-list
891 (funcall
892 (compile nil '(lambda (a)
893 (declare (type (integer -944 -472) a))
894 (declare (optimize (speed 3)))
895 (round
896 (block b3
897 (return-from b3
898 (if (= 55957 a) -117 (ignore-errors
899 (return-from b3 a))))))))
900 -589))
901 '(-589 0)))
902
903 ;;; MISC.158
904 (assert (zerop (funcall
905 (compile nil
906 '(lambda (a b c)
907 (declare (type (integer 79828 2625480458) a))
908 (declare (type (integer -4363283 8171697) b))
909 (declare (type (integer -301 0) c))
910 (if (equal 6392154 (logxor a b))
911 1706
912 (let ((v5 (abs c)))
913 (logand v5
914 (logior (logandc2 c v5)
915 (common-lisp:handler-case
916 (ash a (min 36 22477)))))))))
917 100000 0 0)))
918
919 ;;; MISC.152, 153: deleted code and iteration var type inference
920 (assert (eql (funcall
921 (compile nil
922 '(lambda (a)
923 (block b5
924 (let ((v1 (let ((v8 (unwind-protect 9365)))
925 8862008)))
926 (*
927 (return-from b5
928 (labels ((%f11 (f11-1) f11-1))
929 (%f11 87246015)))
930 (return-from b5
931 (setq v1
932 (labels ((%f6 (f6-1 f6-2 f6-3) v1))
933 (dpb (unwind-protect a)
934 (byte 18 13)
935 (labels ((%f4 () 27322826))
936 (%f6 -2 -108626545 (%f4))))))))))))
937 -6)
938 87246015))
939
940 (assert (eql (funcall
941 (compile nil
942 '(lambda (a)
943 (if (logbitp 3
944 (case -2
945 ((-96879 -1035 -57680 -106404 -94516 -125088)
946 (unwind-protect 90309179))
947 ((-20811 -86901 -9368 -98520 -71594)
948 (let ((v9 (unwind-protect 136707)))
949 (block b3
950 (setq v9
951 (let ((v4 (return-from b3 v9)))
952 (- (ignore-errors (return-from b3 v4))))))))
953 (t -50)))
954 -20343
955 a)))
956 0)
957 -20343))
958
959 ;;; MISC.165
960 (assert (eql (funcall
961 (compile
962 nil
963 '(lambda (a b c)
964 (block b3
965 (flet ((%f15
966 (f15-1 f15-2 f15-3
967 &optional
968 (f15-4
969 (flet ((%f17
970 (f17-1 f17-2 f17-3
971 &optional (f17-4 185155520) (f17-5 c)
972 (f17-6 37))
973 c))
974 (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817)))
975 (f15-5 a) (f15-6 -40))
976 (return-from b3 -16)))
977 (multiple-value-call #'%f15 (values -519354 a 121 c -1905))))))
978 0 0 -5)
979 -16))
980
981 ;;; MISC.172
982 (assert (eql (funcall
983 (compile
984 nil
985 '(lambda (a b c)
986 (declare (notinline list apply))
987 (declare (optimize (safety 3)))
988 (declare (optimize (speed 0)))
989 (declare (optimize (debug 0)))
990 (labels ((%f12 (f12-1 f12-2)
991 (labels ((%f2 (f2-1 f2-2)
992 (flet ((%f6 ()
993 (flet ((%f18
994 (f18-1
995 &optional (f18-2 a)
996 (f18-3 -207465075)
997 (f18-4 a))
998 (return-from %f12 b)))
999 (%f18 -3489553
1000 -7
1001 (%f18 (%f18 150 -64 f12-1)
1002 (%f18 (%f18 -8531)
1003 11410)
1004 b)
1005 56362666))))
1006 (labels ((%f7
1007 (f7-1 f7-2
1008 &optional (f7-3 (%f6)))
1009 7767415))
1010 f12-1))))
1011 (%f2 b -36582571))))
1012 (apply #'%f12 (list 774 -4413)))))
1013 0 1 2)
1014 774))
1015
1016 ;;; MISC.173
1017 (assert (eql (funcall
1018 (compile
1019 nil
1020 '(lambda (a b c)
1021 (declare (notinline values))
1022 (declare (optimize (safety 3)))
1023 (declare (optimize (speed 0)))
1024 (declare (optimize (debug 0)))
1025 (flet ((%f11
1026 (f11-1 f11-2
1027 &optional (f11-3 c) (f11-4 7947114)
1028 (f11-5
1029 (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529))
1030 8134))
1031 (multiple-value-call #'%f3
1032 (values (%f3 -30637724 b) c)))))
1033 (setq c 555910)))
1034 (if (and nil (%f11 a a))
1035 (if (%f11 a 421778 4030 1)
1036 (labels ((%f7
1037 (f7-1 f7-2
1038 &optional
1039 (f7-3
1040 (%f11 -79192293
1041 (%f11 c a c -4 214720)
1042 b
1043 b
1044 (%f11 b 985)))
1045 (f7-4 a))
1046 b))
1047 (%f11 c b -25644))
1048 54)
1049 -32326608))))
1050 1 2 3)
1051 -32326608))
1052
1053 ;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
1054 ;;; local lambda argument
1055 (assert
1056 (equal
1057 (funcall
1058 (compile nil
1059 '(lambda (a b c)
1060 (declare (type (integer 804561 7640697) a))
1061 (declare (type (integer -1 10441401) b))
1062 (declare (type (integer -864634669 55189745) c))
1063 (declare (ignorable a b c))
1064 (declare (optimize (speed 3)))
1065 (declare (optimize (safety 1)))
1066 (declare (optimize (debug 1)))
1067 (flet ((%f11
1068 (f11-1 f11-2)
1069 (labels ((%f4 () (round 200048 (max 99 c))))
1070 (logand
1071 f11-1
1072 (labels ((%f3 (f3-1) -162967612))
1073 (%f3 (let* ((v8 (%f4)))
1074 (setq f11-1 (%f4)))))))))
1075 (%f11 -120429363 (%f11 62362 b)))))
1076 6714367 9645616 -637681868)
1077 -264223548))
1078
1079 ;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
1080 ;;; transform
1081 (assert (equal (multiple-value-list
1082 (funcall
1083 (compile nil '(lambda ()
1084 (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
1085 (ceiling
1086 (ceiling
1087 (flet ((%f16 () 0)) (%f16))))))))
1088 '(0 0)))
1089
1090 ;;; MISC.184
1091 (assert (zerop
1092 (funcall
1093 (compile
1094 nil
1095 '(lambda (a b c)
1096 (declare (type (integer 867934833 3293695878) a))
1097 (declare (type (integer -82111 1776797) b))
1098 (declare (type (integer -1432413516 54121964) c))
1099 (declare (optimize (speed 3)))
1100 (declare (optimize (safety 1)))
1101 (declare (optimize (debug 1)))
1102 (if nil
1103 (flet ((%f15 (f15-1 &optional (f15-2 c))
1104 (labels ((%f1 (f1-1 f1-2) 0))
1105 (%f1 a 0))))
1106 (flet ((%f4 ()
1107 (multiple-value-call #'%f15
1108 (values (%f15 c 0) (%f15 0)))))
1109 (if nil (%f4)
1110 (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0))
1111 f8-3))
1112 0))))
1113 0)))
1114 3040851270 1664281 -1340106197)))
1115
1116 ;;; MISC.249
1117 (assert (zerop
1118 (funcall
1119 (compile
1120 nil
1121 '(lambda (a b)
1122 (declare (notinline <=))
1123 (declare (optimize (speed 2) (space 3) (safety 0)
1124 (debug 1) (compilation-speed 3)))
1125 (if (if (<= 0) nil nil)
1126 (labels ((%f9 (f9-1 f9-2 f9-3)
1127 (ignore-errors 0)))
1128 (dotimes (iv4 5 a) (%f9 0 0 b)))
1129 0)))
1130 1 2)))
1131
1132 ;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
1133 (assert
1134 (= (funcall
1135 (compile
1136 nil
1137 '(lambda (a)
1138 (declare (type (integer 177547470 226026978) a))
1139 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
1140 (compilation-speed 1)))
1141 (logand a (* a 438810))))
1142 215067723)
1143 13739018))
1144
1145 \f
1146 ;;;; Bugs in stack analysis
1147 ;;; bug 299 (reported by PFD)
1148 (assert
1149 (equal (funcall
1150 (compile
1151 nil
1152 '(lambda ()
1153 (declare (optimize (debug 1)))
1154 (multiple-value-call #'list
1155 (if (eval t) (eval '(values :a :b :c)) nil)
1156 (catch 'foo (throw 'foo (values :x :y)))))))
1157 '(:a :b :c :x :y)))
1158 ;;; bug 298 (= MISC.183)
1159 (assert (zerop (funcall
1160 (compile
1161 nil
1162 '(lambda (a b c)
1163 (declare (type (integer -368154 377964) a))
1164 (declare (type (integer 5044 14959) b))
1165 (declare (type (integer -184859815 -8066427) c))
1166 (declare (ignorable a b c))
1167 (declare (optimize (speed 3)))
1168 (declare (optimize (safety 1)))
1169 (declare (optimize (debug 1)))
1170 (block b7
1171 (flet ((%f3 (f3-1 f3-2 f3-3) 0))
1172 (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil)))))
1173 0 6000 -9000000)))
1174 (assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))))
1175 '(1 2)))
1176 (let ((f (compile
1177 nil
1178 '(lambda (x)
1179 (block foo
1180 (multiple-value-call #'list
1181 :a
1182 (block bar
1183 (return-from foo
1184 (multiple-value-call #'list
1185 :b
1186 (block quux
1187 (return-from bar
1188 (catch 'baz
1189 (if x
1190 (return-from quux 1)
1191 (throw 'baz 2))))))))))))))
1192 (assert (equal (funcall f t) '(:b 1)))
1193 (assert (equal (funcall f nil) '(:a 2))))
1194
1195 ;;; MISC.185
1196 (assert (equal
1197 (funcall
1198 (compile
1199 nil
1200 '(lambda (a b c)
1201 (declare (type (integer 5 155656586618) a))
1202 (declare (type (integer -15492 196529) b))
1203 (declare (type (integer 7 10) c))
1204 (declare (optimize (speed 3)))
1205 (declare (optimize (safety 1)))
1206 (declare (optimize (debug 1)))
1207 (flet ((%f3
1208 (f3-1 f3-2 f3-3
1209 &optional (f3-4 a) (f3-5 0)
1210 (f3-6
1211 (labels ((%f10 (f10-1 f10-2 f10-3)
1212 0))
1213 (apply #'%f10
1214 0
1215 a
1216 (- (if (equal a b) b (%f10 c a 0))
1217 (catch 'ct2 (throw 'ct2 c)))
1218 nil))))
1219 0))
1220 (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7)
1221 0))
1222 ;;; MISC.186
1223 (assert (eq
1224 (eval
1225 '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1))
1226 (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil)))
1227 (vars '(b c))
1228 (fn1 `(lambda ,vars
1229 (declare (type (integer -2 19) b)
1230 (type (integer -1520 218978) c)
1231 (optimize (speed 3) (safety 1) (debug 1)))
1232 ,form))
1233 (fn2 `(lambda ,vars
1234 (declare (notinline logeqv apply)
1235 (optimize (safety 3) (speed 0) (debug 0)))
1236 ,form))
1237 (cf1 (compile nil fn1))
1238 (cf2 (compile nil fn2))
1239 (result1 (multiple-value-list (funcall cf1 2 18886)))
1240 (result2 (multiple-value-list (funcall cf2 2 18886))))
1241 (if (equal result1 result2)
1242 :good
1243 (values result1 result2))))
1244 :good))
1245
1246 ;;; MISC.290
1247 (assert (zerop
1248 (funcall
1249 (compile
1250 nil
1251 '(lambda ()
1252 (declare
1253 (optimize (speed 3) (space 3) (safety 1)
1254 (debug 2) (compilation-speed 0)))
1255 (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil))))))
1256
1257 ;;; MISC.292
1258 (assert (zerop (funcall
1259 (compile
1260 nil
1261 '(lambda (a b)
1262 (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
1263 (compilation-speed 2)))
1264 (apply (constantly 0)
1265 a
1266 0
1267 (catch 'ct6
1268 (apply (constantly 0)
1269 0
1270 0
1271 (let* ((v1
1272 (let ((*s7* 0))
1273 b)))
1274 0)
1275 0
1276 nil))
1277 0
1278 nil)))
1279 1 2)))
1280
1281 ;;; misc.295
1282 (assert (eql
1283 (funcall
1284 (compile
1285 nil
1286 '(lambda ()
1287 (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
1288 (multiple-value-prog1
1289 (the integer (catch 'ct8 (catch 'ct7 15867134)))
1290 (catch 'ct1 (throw 'ct1 0))))))
1291 15867134))
1292
1293 ;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
1294 ;;; could transform known-values LVAR to UVL
1295 (assert (zerop (funcall
1296 (compile
1297 nil
1298 '(lambda (a b c)
1299 (declare (notinline boole values denominator list))
1300 (declare
1301 (optimize (speed 2)
1302 (space 0)
1303 (safety 1)
1304 (debug 0)
1305 (compilation-speed 2)))
1306 (catch 'ct6
1307 (progv
1308 '(*s8*)
1309 (list 0)
1310 (let ((v9 (ignore-errors (throw 'ct6 0))))
1311 (denominator
1312 (progv nil nil (values (boole boole-and 0 v9)))))))))
1313 1 2 3)))
1314
1315 ;;; non-continuous dead UVL blocks
1316 (defun non-continuous-stack-test (x)
1317 (multiple-value-call #'list
1318 (eval '(values 11 12))
1319 (eval '(values 13 14))
1320 (block ext
1321 (return-from non-continuous-stack-test
1322 (multiple-value-call #'list
1323 (eval '(values :b1 :b2))
1324 (eval '(values :b3 :b4))
1325 (block int
1326 (return-from ext
1327 (multiple-value-call (eval #'values)
1328 (eval '(values 1 2))
1329 (eval '(values 3 4))
1330 (block ext
1331 (return-from int
1332 (multiple-value-call (eval #'values)
1333 (eval '(values :a1 :a2))
1334 (eval '(values :a3 :a4))
1335 (block int
1336 (return-from ext
1337 (multiple-value-call (eval #'values)
1338 (eval '(values 5 6))
1339 (eval '(values 7 8))
1340 (if x
1341 :ext
1342 (return-from int :int))))))))))))))))
1343 (assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
1344 (assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
1345
1346 ;;; MISC.362: environment of UNWIND-PROTECTor is different from that
1347 ;;; if ENTRY.
1348 (assert (equal (multiple-value-list (funcall
1349 (compile
1350 nil
1351 '(lambda (b g h)
1352 (declare (optimize (speed 3) (space 3) (safety 2)
1353 (debug 2) (compilation-speed 3)))
1354 (catch 'ct5
1355 (unwind-protect
1356 (labels ((%f15 (f15-1 f15-2 f15-3)
1357 (rational (throw 'ct5 0))))
1358 (%f15 0
1359 (apply #'%f15
1360 0
1361 h
1362 (progn
1363 (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
1364 0)
1365 nil)
1366 0))
1367 (common-lisp:handler-case 0)))))
1368 1 2 3))
1369 '(0)))
1370
1371 \f
1372 ;;; MISC.275
1373 (assert
1374 (zerop
1375 (funcall
1376 (compile
1377 nil
1378 '(lambda (b)
1379 (declare (notinline funcall min coerce))
1380 (declare
1381 (optimize (speed 1)
1382 (space 2)
1383 (safety 2)
1384 (debug 1)
1385 (compilation-speed 1)))
1386 (flet ((%f12 (f12-1)
1387 (coerce
1388 (min
1389 (if f12-1 (multiple-value-prog1
1390 b (return-from %f12 0))
1391 0))
1392 'integer)))
1393 (funcall #'%f12 0))))
1394 -33)))
1395
1396 ;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
1397 ;;; potential problem: optimizers and type derivers for MAX and MIN
1398 ;;; were not consistent in treating EQUALP, but not EQL, arguments.
1399 (dolist (f '(min max))
1400 (loop for complex-arg-args in '((1d0 2d0) (0d0 1d0))
1401 for complex-arg = `(if x ,@complex-arg-args)
1402 do
1403 (loop for args in `((1 ,complex-arg)
1404 (,complex-arg 1))
1405 for form = `(,f ,@args)
1406 for f1 = (compile nil `(lambda (x) ,form))
1407 and f2 = (compile nil `(lambda (x) (declare (notinline min max))
1408 ,form))
1409 do
1410 (dolist (x '(nil t))
1411 (assert (eql (funcall f1 x) (funcall f2 x)))))))
1412
1413 ;;;
1414 (handler-case (compile nil '(lambda (x)
1415 (declare (optimize (speed 3) (safety 0)))
1416 (the double-float (sqrt (the double-float x)))))
1417 (sb-ext:compiler-note (c)
1418 ;; Ignore the note for the float -> pointer conversion of the
1419 ;; return value.
1420 (unless (string= (car (last (sb-c::simple-condition-format-arguments c)))
1421 "<return value>")
1422 (error "Compiler does not trust result type assertion."))))
1423
1424 (let ((f (compile nil '(lambda (x)
1425 (declare (optimize speed (safety 0)))
1426 (block nil
1427 (the double-float
1428 (multiple-value-prog1
1429 (sqrt (the double-float x))
1430 (when (< x 0)
1431 (return :minus)))))))))
1432 (assert (eql (funcall f -1d0) :minus))
1433 (assert (eql (funcall f 4d0) 2d0)))
1434
1435 ;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
1436 (handler-case
1437 (compile nil '(lambda (a i)
1438 (locally
1439 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
1440 (inhibit-warnings 0)))
1441 (declare (type (alien (* (unsigned 8))) a)
1442 (type (unsigned-byte 32) i))
1443 (deref a i))))
1444 (compiler-note () (error "The code is not optimized.")))
1445
1446 (handler-case
1447 (compile nil '(lambda (x)
1448 (declare (type (integer -100 100) x))
1449 (declare (optimize speed))
1450 (declare (notinline identity))
1451 (1+ (identity x))))
1452 (compiler-note () (error "IDENTITY derive-type not applied.")))
1453
1454 (assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
1455
1456 ;;; MISC.293 = easy variant of bug 303: repeated write to the same
1457 ;;; LVAR; here the first write may be cleared before the second is
1458 ;;; made.
1459 (assert
1460 (zerop
1461 (funcall
1462 (compile
1463 nil
1464 '(lambda ()
1465 (declare (notinline complex))
1466 (declare (optimize (speed 1) (space 0) (safety 1)
1467 (debug 3) (compilation-speed 3)))
1468 (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
1469 (complex (%f) 0)))))))
1470
1471 ;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
1472 (assert (zerop (funcall
1473 (compile
1474 nil
1475 '(lambda (a c)
1476 (declare (type (integer -1294746569 1640996137) a))
1477 (declare (type (integer -807801310 3) c))
1478 (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
1479 (catch 'ct7
1480 (if
1481 (logbitp 0
1482 (if (/= 0 a)
1483 c
1484 (ignore-errors
1485 (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
1486 0 0))))
1487 391833530 -32785211)))
1488
1489 ;;; efficiency notes for ordinary code
1490 (macrolet ((frob (arglist &body body)
1491 `(progn
1492 (handler-case
1493 (compile nil '(lambda ,arglist ,@body))
1494 (sb-ext:compiler-note (e)
1495 (error "bad compiler note for ~S:~% ~A" ',body e)))
1496 (catch :got-note
1497 (handler-case
1498 (compile nil '(lambda ,arglist (declare (optimize speed))
1499 ,@body))
1500 (sb-ext:compiler-note (e) (throw :got-note nil)))
1501 (error "missing compiler note for ~S" ',body)))))
1502 (frob (x) (funcall x))
1503 (frob (x y) (find x y))
1504 (frob (x y) (find-if x y))
1505 (frob (x y) (find-if-not x y))
1506 (frob (x y) (position x y))
1507 (frob (x y) (position-if x y))
1508 (frob (x y) (position-if-not x y))
1509 (frob (x) (aref x 0)))
1510
1511 (macrolet ((frob (style-warn-p form)
1512 (if style-warn-p
1513 `(catch :got-style-warning
1514 (handler-case
1515 (eval ',form)
1516 (style-warning (e) (throw :got-style-warning nil)))
1517 (error "missing style-warning for ~S" ',form))
1518 `(handler-case
1519 (eval ',form)
1520 (style-warning (e)
1521 (error "bad style-warning for ~S: ~A" ',form e))))))
1522 (frob t (lambda (x &optional y &key z) (list x y z)))
1523 (frob nil (lambda (x &optional y z) (list x y z)))
1524 (frob nil (lambda (x &key y z) (list x y z)))
1525 (frob t (defgeneric #:foo (x &optional y &key z)))
1526 (frob nil (defgeneric #:foo (x &optional y z)))
1527 (frob nil (defgeneric #:foo (x &key y z)))
1528 (frob t (defun #:foo (x) (flet ((foo (x &optional y &key z) (list x y z))) (foo x x :z x)))))
1529
1530 ;;; this was a bug in the LOGXOR type deriver. The top form gave a
1531 ;;; note, because the system failed to derive the fact that the return
1532 ;;; from LOGXOR was small and negative, though the bottom one worked.
1533 (handler-bind ((sb-ext:compiler-note #'error))
1534 (compile nil '(lambda ()
1535 (declare (optimize speed (safety 0)))
1536 (lambda (x y)
1537 (declare (type (integer 3 6) x)
1538 (type (integer -6 -3) y))
1539 (+ (logxor x y) most-positive-fixnum)))))
1540 (handler-bind ((sb-ext:compiler-note #'error))
1541 (compile nil '(lambda ()
1542 (declare (optimize speed (safety 0)))
1543 (lambda (x y)
1544 (declare (type (integer 3 6) y)
1545 (type (integer -6 -3) x))
1546 (+ (logxor x y) most-positive-fixnum)))))
1547
1548 ;;; check that modular ash gives the right answer, to protect against
1549 ;;; possible misunderstandings about the hardware shift instruction.
1550 (assert (zerop (funcall
1551 (compile nil '(lambda (x y)
1552 (declare (optimize speed)
1553 (type (unsigned-byte 32) x y))
1554 (logand #xffffffff (ash x y))))
1555 1 257)))
1556
1557 ;;; code instrumenting problems
1558 (compile nil
1559 '(lambda ()
1560 (declare (optimize (debug 3)))
1561 (list (the integer (if nil 14 t)))))
1562
1563 (compile nil
1564 '(LAMBDA (A B C D)
1565 (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD))
1566 (DECLARE
1567 (OPTIMIZE (SPEED 1)
1568 (SPACE 1)
1569 (SAFETY 1)
1570 (DEBUG 3)
1571 (COMPILATION-SPEED 0)))
1572 (MASK-FIELD (BYTE 7 26)
1573 (PROGN
1574 (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
1575 B))))
1576
1577 (compile nil
1578 '(lambda (buffer i end)
1579 (declare (optimize (debug 3)))
1580 (loop (when (not (eql 0 end)) (return)))
1581 (let ((s (make-string end)))
1582 (setf (schar s i) (schar buffer i))
1583 s)))
1584
1585 ;;; check that constant string prefix and suffix don't cause the
1586 ;;; compiler to emit code deletion notes.
1587 (handler-bind ((sb-ext:code-deletion-note #'error))
1588 (compile nil '(lambda (s x)
1589 (pprint-logical-block (s x :prefix "(")
1590 (print x s))))
1591 (compile nil '(lambda (s x)
1592 (pprint-logical-block (s x :per-line-prefix ";")
1593 (print x s))))
1594 (compile nil '(lambda (s x)
1595 (pprint-logical-block (s x :suffix ">")
1596 (print x s)))))
1597
1598 ;;; MISC.427: loop analysis requires complete DFO structure
1599 (assert (eql 17 (funcall
1600 (compile
1601 nil
1602 '(lambda (a)
1603 (declare (notinline list reduce logior))
1604 (declare (optimize (safety 2) (compilation-speed 1)
1605 (speed 3) (space 2) (debug 2)))
1606 (logior
1607 (let* ((v5 (reduce #'+ (list 0 a))))
1608 (declare (dynamic-extent v5))
1609 v5))))
1610 17)))
1611
1612 ;;; MISC.434
1613 (assert (zerop (funcall
1614 (compile
1615 nil
1616 '(lambda (a b)
1617 (declare (type (integer -8431780939320 1571817471932) a))
1618 (declare (type (integer -4085 0) b))
1619 (declare (ignorable a b))
1620 (declare
1621 (optimize (space 2)
1622 (compilation-speed 0)
1623 #+sbcl (sb-c:insert-step-conditions 0)
1624 (debug 2)
1625 (safety 0)
1626 (speed 3)))
1627 (let ((*s5* 0))
1628 (dotimes (iv1 2 0)
1629 (let ((*s5*
1630 (elt '(1954479092053)
1631 (min 0
1632 (max 0
1633 (if (< iv1 iv1)
1634 (lognand iv1 (ash iv1 (min 53 iv1)))
1635 iv1))))))
1636 0)))))
1637 -7639589303599 -1368)))
1638
1639 (compile
1640 nil
1641 '(lambda (a b)
1642 (declare (type (integer) a))
1643 (declare (type (integer) b))
1644 (declare (ignorable a b))
1645 (declare (optimize (space 2) (compilation-speed 0)
1646 (debug 0) (safety 0) (speed 3)))
1647 (dotimes (iv1 2 0)
1648 (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass
1649 (print (if (< iv1 iv1)
1650 (logand (ash iv1 iv1) 1)
1651 iv1)))))
1652
1653 ;;; MISC.435: lambda var substitution in a deleted code.
1654 (assert (zerop (funcall
1655 (compile
1656 nil
1657 '(lambda (a b c d)
1658 (declare (notinline aref logandc2 gcd make-array))
1659 (declare
1660 (optimize (space 0) (safety 0) (compilation-speed 3)
1661 (speed 3) (debug 1)))
1662 (progn
1663 (tagbody
1664 (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2)))))
1665 (declare (dynamic-extent v2))
1666 (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2))))
1667 tag2)
1668 0)))
1669 3021871717588 -866608 -2 -17194)))
1670
1671 ;;; MISC.436, 438: lost reoptimization
1672 (assert (zerop (funcall
1673 (compile
1674 nil
1675 '(lambda (a b)
1676 (declare (type (integer -2917822 2783884) a))
1677 (declare (type (integer 0 160159) b))
1678 (declare (ignorable a b))
1679 (declare
1680 (optimize (compilation-speed 1)
1681 (speed 3)
1682 (safety 3)
1683 (space 0)
1684 ; #+sbcl (sb-c:insert-step-conditions 0)
1685 (debug 0)))
1686 (if
1687 (oddp
1688 (loop for
1689 lv1
1690 below
1691 2
1692 count
1693 (logbitp 0
1694 (1-
1695 (ash b
1696 (min 8
1697 (count 0
1698 '(-10197561 486 430631291
1699 9674068))))))))
1700 b
1701 0)))
1702 1265797 110757)))
1703
1704 (assert (zerop (funcall
1705 (compile
1706 nil
1707 ' (lambda (a)
1708 (declare (type (integer 0 1696) a))
1709 ; (declare (ignorable a))
1710 (declare (optimize (space 2) (debug 0) (safety 1)
1711 (compilation-speed 0) (speed 1)))
1712 (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0)))
1713 805)))
1714
1715 ;;; bug #302
1716 (assert (compile
1717 nil
1718 '(lambda (s ei x y)
1719 (declare (type (simple-array function (2)) s) (type ei ei))
1720 (funcall (aref s ei) x y))))
1721
1722 ;;; MISC.320: ir1-transform can create an intercomponent reference to
1723 ;;; a DEFINED-FUN.
1724 (assert (eql 102 (funcall
1725 (compile
1726 nil
1727 '(lambda ()
1728 (declare (optimize (speed 3) (space 0) (safety 2)
1729 (debug 2) (compilation-speed 0)))
1730 (catch 'ct2
1731 (elt '(102)
1732 (flet ((%f12 () (rem 0 -43)))
1733 (multiple-value-call #'%f12 (values))))))))))
1734
1735 ;;; MISC.437: lost reoptimization after FLUSH-DEST
1736 (assert (zerop (funcall
1737 (compile
1738 nil
1739 '(lambda (a b c d e)
1740 (declare (notinline values complex eql))
1741 (declare
1742 (optimize (compilation-speed 3)
1743 (speed 3)
1744 (debug 1)
1745 (safety 1)
1746 (space 0)))
1747 (flet ((%f10
1748 (f10-1 f10-2 f10-3
1749 &optional (f10-4 (ignore-errors 0)) (f10-5 0)
1750 &key &allow-other-keys)
1751 (if (or (eql 0 0) t) 0 (if f10-1 0 0))))
1752 (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0))))
1753 80043 74953652306 33658947 -63099937105 -27842393)))
1754
1755 ;;; bug #351 -- program-error for malformed LET and LET*, including those
1756 ;;; resulting from SETF of LET.
1757 (dolist (fun (list (compile nil '(lambda () (let :bogus-let :oops)))
1758 (compile nil '(lambda () (let* :bogus-let* :oops)))
1759 (compile nil '(lambda (x) (push x (let ((y 0)) y))))))
1760 (assert (functionp fun))
1761 (multiple-value-bind (res err) (ignore-errors (funcall fun))
1762 (assert (not res))
1763 (assert (typep err 'program-error))))
1764
1765 (let ((fun (compile nil '(lambda (x) (random (if x 10 20))))))
1766 (dotimes (i 100 (error "bad RANDOM distribution"))
1767 (when (> (funcall fun nil) 9)
1768 (return t)))
1769 (dotimes (i 100)
1770 (when (> (funcall fun t) 9)
1771 (error "bad RANDOM event"))))
1772
1773 ;;; 0.8.17.28-sma.1 lost derived type information.
1774 (with-test (:name "0.8.17.28-sma.1" :fails-on :sparc)
1775 (handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c))))
1776 (compile nil
1777 '(lambda (x y v)
1778 (declare (optimize (speed 3) (safety 0)))
1779 (declare (type (integer 0 80) x)
1780 (type (integer 0 11) y)
1781 (type (simple-array (unsigned-byte 32) (*)) v))
1782 (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y))
1783 nil))))
1784
1785 ;;; Bug reported by Robert J. Macomber: instrumenting of more-entry
1786 ;;; prevented open coding of %LISTIFY-REST-ARGS.
1787 (let ((f (compile nil '(lambda ()
1788 (declare (optimize (debug 3)))
1789 (with-simple-restart (blah "blah") (error "blah"))))))
1790 (handler-bind ((error (lambda (c) (invoke-restart 'blah))))
1791 (assert (equal (multiple-value-list (funcall f)) '(nil t)))))
1792
1793 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
1794 ;;; constant index and value.
1795 (loop for n-bits = 1 then (* n-bits 2)
1796 for type = `(unsigned-byte ,n-bits)
1797 and v-max = (1- (ash 1 n-bits))
1798 while (<= n-bits sb-vm:n-word-bits)
1799 do
1800 (let* ((n (* 2 (1+ (- sb-vm::n-word-bits n-bits))))
1801 (array1 (make-array n :element-type type))
1802 (array2 (make-array n :element-type type)))
1803 (dotimes (i n)
1804 (dolist (v (list 0 v-max))
1805 (let ((f (compile nil `(lambda (a)
1806 (declare (type (simple-array ,type (,n)) a))
1807 (setf (aref a ,i) ,v)))))
1808 (fill array1 (- v-max v))
1809 (fill array2 (- v-max v))
1810 (funcall f array1)
1811 (setf (aref array2 i) v)
1812 (assert (every #'= array1 array2)))))))
1813
1814 (let ((fn (compile nil '(lambda (x)
1815 (declare (type bit x))
1816 (declare (optimize speed))
1817 (let ((b (make-array 64 :element-type 'bit
1818 :initial-element 0)))
1819 (count x b))))))
1820 (assert (= (funcall fn 0) 64))
1821 (assert (= (funcall fn 1) 0)))
1822
1823 (let ((fn (compile nil '(lambda (x y)
1824 (declare (type simple-bit-vector x y))
1825 (declare (optimize speed))
1826 (equal x y)))))
1827 (assert (funcall
1828 fn
1829 (make-array 64 :element-type 'bit :initial-element 0)
1830 (make-array 64 :element-type 'bit :initial-element 0)))
1831 (assert (not
1832 (funcall
1833 fn
1834 (make-array 64 :element-type 'bit :initial-element 0)
1835 (let ((b (make-array 64 :element-type 'bit :initial-element 0)))
1836 (setf (sbit b 63) 1)
1837 b)))))
1838
1839 ;;; MISC.535: compiler failure
1840 (let ((c0 #c(4196.088977268509d0 -15943.3603515625d0)))
1841 (assert (not (funcall
1842 (compile
1843 nil
1844 `(lambda (p1 p2)
1845 (declare (optimize speed (safety 1))
1846 (type (eql ,c0) p1)
1847 (type number p2))
1848 (eql (the (complex double-float) p1) p2)))
1849 c0 #c(12 612/979)))))
1850
1851 ;;; reported by Lutz Euler: we shouldn't signal a compiler note for
1852 ;;; simple-bit-vector functions.
1853 (handler-bind ((sb-ext:compiler-note #'error))
1854 (compile nil '(lambda (x)
1855 (declare (type simple-bit-vector x))
1856 (count 1 x))))
1857 (handler-bind ((sb-ext:compiler-note #'error))
1858 (compile nil '(lambda (x y)
1859 (declare (type simple-bit-vector x y))
1860 (equal x y))))
1861
1862 ;;; MISC.550: CAST merging in IR1 finalization caused unexpected
1863 ;;; code transformations.
1864 (assert (eql (funcall
1865 (compile
1866 nil
1867 '(lambda (p1 p2)
1868 (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
1869 (type atom p1)
1870 (type symbol p2))
1871 (or p1 (the (eql t) p2))))
1872 nil t)
1873 t))
1874
1875 ;;; MISC.548: type check weakening converts required type into
1876 ;;; optional
1877 (assert (eql t
1878 (funcall
1879 (compile
1880 nil
1881 '(lambda (p1)
1882 (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
1883 (atom (the (member f assoc-if write-line t w) p1))))
1884 t)))
1885
1886 ;;; Free special bindings only apply to the body of the binding form, not
1887 ;;; the initialization forms.
1888 (assert (eq :good
1889 (funcall (compile 'nil
1890 (lambda ()
1891 (let ((x :bad))
1892 (declare (special x))
1893 (let ((x :good))
1894 ((lambda (&optional (y x))
1895 (declare (special x)) y)))))))))
1896
1897 ;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
1898 ;;; a rational was zero, but didn't do the substitution, leading to a
1899 ;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
1900 ;;; machine's ASH instruction's immediate field) that the compiler
1901 ;;; thought was legitimate.
1902 ;;;
1903 ;;; FIXME: this has been recorded as bug 383. The attempted fix (sbcl
1904 ;;; 0.9.2.6) led to lots of spurious optimization notes. So the bug stil
1905 ;;; exist and this test case serves as a reminder of the problem.
1906 ;;; --njf, 2005-07-05
1907 #+nil
1908 (compile 'nil
1909 (LAMBDA (B)
1910 (DECLARE (TYPE (INTEGER -2 14) B))
1911 (DECLARE (IGNORABLE B))
1912 (ASH (IMAGPART B) 57)))
1913
1914 ;;; bug reported by Eduardo Mu\~noz
1915 (multiple-value-bind (fun warnings failure)
1916 (compile nil '(lambda (struct first)
1917 (declare (optimize speed))
1918 (let* ((nodes (nodes struct))
1919 (bars (bars struct))
1920 (length (length nodes))
1921 (new (make-array length :fill-pointer 0)))
1922 (vector-push first new)
1923 (loop with i fixnum = 0
1924 for newl fixnum = (length new)
1925 while (< newl length) do
1926 (let ((oldl (length new)))
1927 (loop for j fixnum from i below newl do
1928 (dolist (n (node-neighbours (aref new j) bars))
1929 (unless (find n new)
1930 (vector-push n new))))
1931 (setq i oldl)))
1932 new)))
1933 (declare (ignore fun warnings failure))
1934 (assert (not failure)))
1935
1936 ;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe
1937 ;;; sbcl-devel)
1938 (compile nil '(lambda (x y a b c)
1939 (- y (* (signum x) (sqrt (abs (- (* b x) c)))))))
1940
1941 ;;; Type inference from CHECK-TYPE
1942 (let ((count0 0) (count1 0))
1943 (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count0))))
1944 (compile nil '(lambda (x)
1945 (declare (optimize (speed 3)))
1946 (1+ x))))
1947 ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note
1948 (assert (> count0 1))
1949 (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1))))
1950 (compile nil '(lambda (x)
1951 (declare (optimize (speed 3)))
1952 (check-type x fixnum)
1953 (1+ x))))
1954 ;; Only the posssible word -> bignum conversion note
1955 (assert (= count1 1)))
1956
1957 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
1958 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
1959 (with-test (:name :sap-ref-float)
1960 (compile nil '(lambda (sap)
1961 (let ((x (setf (sb-vm::sap-ref-double sap 0) 1d0)))
1962 (1+ x))))
1963 (compile nil '(lambda (sap)
1964 (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0)))
1965 (1+ x)))))
1966
1967 ;;; bug #399
1968 (with-test (:name :string-union-types)
1969 (compile nil '(lambda (x)
1970 (declare (type (or (simple-array character (6))
1971 (simple-array character (5))) x))
1972 (aref x 0))))
1973
1974 ;;; MISC.623: missing functions for constant-folding
1975 (assert (eql 0
1976 (funcall
1977 (compile
1978 nil
1979 '(lambda ()
1980 (declare (optimize (space 2) (speed 0) (debug 2)
1981 (compilation-speed 3) (safety 0)))
1982 (loop for lv3 below 1
1983 count (minusp
1984 (loop for lv2 below 2
1985 count (logbitp 0
1986 (bit #*1001101001001
1987 (min 12 (max 0 lv3))))))))))))
1988
1989 ;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs
1990 (assert (eql 0
1991 (funcall
1992 (compile
1993 nil
1994 '(lambda (a)
1995 (declare (type (integer 21 28) a))
1996 (declare (optimize (compilation-speed 1) (safety 2)
1997 (speed 0) (debug 0) (space 1)))
1998 (let* ((v7 (flet ((%f3 (f3-1 f3-2)
1999 (loop for lv2 below 1
2000 count
2001 (logbitp 29
2002 (sbit #*10101111
2003 (min 7 (max 0 (eval '0))))))))
2004 (%f3 0 a))))
2005 0)))
2006 22)))
2007
2008 ;;; MISC.626: bandaged AVER was still wrong
2009 (assert (eql -829253
2010 (funcall
2011 (compile
2012 nil
2013 '(lambda (a)
2014 (declare (type (integer -902970 2) a))
2015 (declare (optimize (space 2) (debug 0) (compilation-speed 1)
2016 (speed 0) (safety 3)))
2017 (prog2 (if (logbitp 30 a) 0 (block b3 0)) a)))
2018 -829253)))
2019
2020 ;; MISC.628: constant-folding %LOGBITP was buggy
2021 (assert (eql t
2022 (funcall
2023 (compile
2024 nil
2025 '(lambda ()
2026 (declare (optimize (safety 3) (space 3) (compilation-speed 3)
2027 (speed 0) (debug 1)))
2028 (not (not (logbitp 0 (floor 2147483651 (min -23 0))))))))))
2029
2030 ;; mistyping found by random-tester
2031 (assert (zerop
2032 (funcall
2033 (compile
2034 nil
2035 '(lambda ()
2036 (declare (optimize (speed 1) (debug 0)
2037 (space 2) (safety 0) (compilation-speed 0)))
2038 (unwind-protect 0
2039 (* (/ (multiple-value-prog1 -29457482 -5602513511) 1))))))))
2040
2041 ;; aggressive constant folding (bug #400)
2042 (assert
2043 (eq t (funcall (compile nil '(lambda () (or t (the integer (/ 1 0))))))))
2044
2045 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-1))
2046 (assert
2047 (handler-case
2048 (compile nil '(lambda (x y)
2049 (when (eql x (length y))
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 :var-eql-to-non-var-2))
2056 (assert
2057 (handler-case
2058 (compile nil '(lambda (x y)
2059 (when (eql (length y) x)
2060 (locally
2061 (declare (optimize (speed 3)))
2062 (1+ x)))))
2063 (compiler-note () (error "The code is not optimized.")))))
2064
2065 (with-test (:name (:compiler :constraint-propagation :float-bounds-1))
2066 (handler-case
2067 (compile nil '(lambda (x)
2068 (declare (type (single-float * (3.0)) x))
2069 (when (<= x 2.0)
2070 (when (<= 2.0 x)
2071 x))))
2072 (compiler-note () (error "Deleted reachable code."))))
2073
2074 (with-test (:name (:compiler :constraint-propagation :float-bounds-2))
2075 (catch :note
2076 (handler-case
2077 (compile nil '(lambda (x)
2078 (declare (type single-float x))
2079 (when (< 1.0 x)
2080 (when (<= x 1.0)
2081 (error "This is unreachable.")))))
2082 (compiler-note () (throw :note nil)))
2083 (error "Unreachable code undetected.")))
2084
2085 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
2086 (catch :note
2087 (handler-case
2088 (compile nil '(lambda (x y)
2089 (when (typep y 'fixnum)
2090 (when (eql x y)
2091 (unless (typep x 'fixnum)
2092 (error "This is unreachable"))
2093 (setq y nil)))))
2094 (compiler-note () (throw :note nil)))
2095 (error "Unreachable code undetected.")))
2096
2097 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-2))
2098 (catch :note
2099 (handler-case
2100 (compile nil '(lambda (x y)
2101 (when (typep y 'fixnum)
2102 (when (eql y x)
2103 (unless (typep x 'fixnum)
2104 (error "This is unreachable"))
2105 (setq y nil)))))
2106 (compiler-note () (throw :note nil)))
2107 (error "Unreachable code undetected.")))
2108
2109 ;; Reported by John Wiseman, sbcl-devel
2110 ;; Subject: [Sbcl-devel] float type derivation bug?
2111 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700
2112 (with-test (:name (:type-derivation :float-bounds))
2113 (compile nil '(lambda (bits)
2114 (let* ((s (if (= (ash bits -31) 0) 1 -1))
2115 (e (logand (ash bits -23) #xff))
2116 (m (if (= e 0)
2117 (ash (logand bits #x7fffff) 1)
2118 (logior (logand bits #x7fffff) #x800000))))
2119 (float (* s m (expt 2 (- e 150))))))))
2120
2121 ;; Reported by James Knight
2122 ;; Subject: [Sbcl-devel] AVER: "(EQ (SB-NAME (SC-SB (TN-SC TN))) 'REGISTERS)"
2123 ;; Date: Fri, 24 Mar 2006 19:30:00 -0500
2124 (with-test (:name :logbitp-vop)
2125 (compile nil
2126 '(lambda (days shift)
2127 (declare (type fixnum shift days))
2128 (let* ((result 0)
2129 (canonicalized-shift (+ shift 1))
2130 (first-wrapping-day (- 1 canonicalized-shift)))
2131 (declare (type fixnum result))
2132 (dotimes (source-day 7)
2133 (declare (type (integer 0 6) source-day))
2134 (when (logbitp source-day days)
2135 (setf result
2136 (logior result
2137 (the fixnum
2138 (if (< source-day first-wrapping-day)
2139 (+ source-day canonicalized-shift)
2140 (- (+ source-day
2141 canonicalized-shift) 7)))))))
2142 result))))
2143
2144 ;;; MISC.637: incorrect delaying of conversion of optional entries
2145 ;;; with hairy constant defaults
2146 (let ((f '(lambda ()
2147 (labels ((%f11 (f11-2 &key key1)
2148 (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0)))
2149 :bad1))
2150 (%f8 (%f8 0)))
2151 :bad2))
2152 :good))))
2153 (assert (eq (funcall (compile nil f)) :good)))
2154
2155 ;;; MISC.555: new reference to an already-optimized local function
2156 (let* ((l '(lambda (p1)
2157 (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1))
2158 (keywordp p1)))
2159 (f (compile nil l)))
2160 (assert (funcall f :good))
2161 (assert (nth-value 1 (ignore-errors (funcall f 42)))))
2162
2163 ;;; Check that the compiler doesn't munge *RANDOM-STATE*.
2164 (let* ((state (make-random-state))
2165 (*random-state* (make-random-state state))
2166 (a (random most-positive-fixnum)))
2167 (setf *random-state* state)
2168 (compile nil `(lambda (x a)
2169 (declare (single-float x)
2170 (type (simple-array double-float) a))
2171 (+ (loop for i across a
2172 summing i)
2173 x)))
2174 (assert (= a (random most-positive-fixnum))))
2175
2176 ;;; MISC.641: LET-conversion after physical environment analysis lost NLX-INFOs
2177 (let ((form '(lambda ()
2178 (declare (optimize (speed 1) (space 0) (debug 2)
2179 (compilation-speed 0) (safety 1)))
2180 (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #())))
2181 0))
2182 (apply #'%f3 0 nil)))))
2183 (assert (zerop (funcall (compile nil form)))))
2184
2185 ;;; 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
2186 (compile nil '(lambda ()
2187 (let ((x (make-array '(1) :element-type '(signed-byte 32))))
2188 (setf (aref x 0) 1))))
2189
2190 ;;; step instrumentation confusing the compiler, reported by Faré
2191 (handler-bind ((warning #'error))
2192 (compile nil '(lambda ()
2193 (declare (optimize (debug 2))) ; not debug 3!
2194 (let ((val "foobar"))
2195 (map-into (make-array (list (length val))
2196 :element-type '(unsigned-byte 8))
2197 #'char-code val)))))
2198
2199 ;;; overconfident primitive type computation leading to bogus type
2200 ;;; checking.
2201 (let* ((form1 '(lambda (x)
2202 (declare (type (and condition function) x))
2203 x))
2204 (fun1 (compile nil form1))
2205 (form2 '(lambda (x)
2206 (declare (type (and standard-object function) x))
2207 x))
2208 (fun2 (compile nil form2)))
2209 (assert (raises-error? (funcall fun1 (make-condition 'error))))
2210 (assert (raises-error? (funcall fun1 fun1)))
2211 (assert (raises-error? (funcall fun2 fun2)))
2212 (assert (eq (funcall fun2 #'print-object) #'print-object)))
2213
2214 ;;; LET* + VALUES declaration: while the declaration is a non-standard
2215 ;;; and possibly a non-conforming extension, as long as we do support
2216 ;;; it, we might as well get it right.
2217 ;;;
2218 ;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
2219 (compile nil '(lambda () (let* () (declare (values list)))))
2220
2221
2222 ;;; test for some problems with too large immediates in x86-64 modular
2223 ;;; arithmetic vops
2224 (compile nil '(lambda (x) (declare (fixnum x))
2225 (logand most-positive-fixnum (logxor x most-positive-fixnum))))
2226
2227 (compile nil '(lambda (x) (declare (fixnum x))
2228 (logand most-positive-fixnum (+ x most-positive-fixnum))))
2229
2230 (compile nil '(lambda (x) (declare (fixnum x))
2231 (logand most-positive-fixnum (* x most-positive-fixnum))))
2232
2233 ;;; bug 256.b
2234 (assert (let (warned-p)
2235 (handler-bind ((warning (lambda (w) (setf warned-p t))))
2236 (compile nil
2237 '(lambda (x)
2238 (list (let ((y (the real x)))
2239 (unless (floatp y) (error ""))
2240 y)
2241 (integer-length x)))))
2242 warned-p))
2243
2244 ;; Dead / in safe code
2245 (with-test (:name :safe-dead-/)
2246 (assert (eq :error
2247 (handler-case
2248 (funcall (compile nil
2249 '(lambda (x y)
2250 (declare (optimize (safety 3)))
2251 (/ x y)
2252 (+ x y)))
2253 1
2254 0)
2255 (division-by-zero ()
2256 :error)))))
2257
2258 ;;; Dead unbound variable (bug 412)
2259 (with-test (:name :dead-unbound)
2260 (assert (eq :error
2261 (handler-case
2262 (funcall (compile nil
2263 '(lambda ()
2264 #:unbound
2265 42)))
2266 (unbound-variable ()
2267 :error)))))
2268
2269 ;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR.
2270 (handler-bind ((sb-ext:compiler-note 'error))
2271 (assert
2272 (equalp #(2 3)
2273 (funcall (compile nil `(lambda (s p e)
2274 (declare (optimize speed)
2275 (simple-vector s))
2276 (subseq s p e)))
2277 (vector 1 2 3 4)
2278 1
2279 3))))
2280
2281 ;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR.
2282 (handler-bind ((sb-ext:compiler-note 'error))
2283 (assert
2284 (equalp #(1 2 3 4)
2285 (funcall (compile nil `(lambda (s)
2286 (declare (optimize speed)
2287 (simple-vector s))
2288 (copy-seq s)))
2289 (vector 1 2 3 4)))))
2290
2291 ;;; bug in adding DATA-VECTOR-REF-WITH-OFFSET to x86-64
2292 (assert (not (mismatch #(1.0f0 2.0f0) (make-array 2 :element-type 'single-float :initial-contents (list 1.0f0 2.0f0)))))
2293
2294 ;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too
2295 ;;; large bignums to floats
2296 (dolist (op '(* / + -))
2297 (let ((fun (compile
2298 nil
2299 `(lambda (x)
2300 (declare (type (integer 0 #.(* 2 (truncate most-positive-double-float))) x))
2301 (,op 0.0d0 x)))))
2302 (loop repeat 10
2303 do (let ((arg (random (truncate most-positive-double-float))))
2304 (assert (eql (funcall fun arg)
2305 (funcall op 0.0d0 arg)))))))
2306
2307 (with-test (:name :high-debug-known-function-inlining)
2308 (let ((fun (compile nil
2309 '(lambda ()
2310 (declare (optimize (debug 3)) (inline append))
2311 (let ((fun (lambda (body)
2312 (append
2313 (first body)
2314 nil))))
2315 (funcall fun
2316 '((foo (bar)))))))))
2317 (funcall fun)))
2318
2319 (with-test (:name :high-debug-known-function-transform-with-optional-arguments)
2320 (compile nil '(lambda (x y)
2321 (declare (optimize sb-c::preserve-single-use-debug-variables))
2322 (if (block nil
2323 (some-unknown-function
2324 (lambda ()
2325 (return (member x y))))
2326 t)
2327 t
2328 (error "~a" y)))))
2329
2330 ;;; Compiling W-P-O when the pinned objects are known to be fixnums
2331 ;;; or characters.
2332 (compile nil '(lambda (x y)
2333 (declare (fixnum y) (character x))
2334 (sb-sys:with-pinned-objects (x y)
2335 (some-random-function))))
2336
2337 ;;; *CHECK-CONSISTENCY* and TRULY-THE
2338
2339 (with-test (:name :bug-423)
2340 (let ((sb-c::*check-consistency* t))
2341 (handler-bind ((warning #'error))
2342 (flet ((make-lambda (type)
2343 `(lambda (x)
2344 ((lambda (z)
2345 (if (listp z)
2346 (let ((q (truly-the list z)))
2347 (length q))
2348 (if (arrayp z)
2349 (let ((q (truly-the vector z)))
2350 (length q))
2351 (error "oops"))))
2352 (the ,type x)))))
2353 (compile nil (make-lambda 'list))
2354 (compile nil (make-lambda 'vector))))))
2355
2356 ;;; this caused a momentary regression when an ill-adviced fix to
2357 ;;; bug 427 made ANY-REG suitable for primitive-type T:
2358 ;;;
2359 ;;; no :MOVE-ARG VOP defined to move #<SB-C:TN t1> (SC SB-VM::SINGLE-REG) to #<SB-C:TN t2> (SC SB-VM::ANY-REG)
2360 ;;; [Condition of type SIMPLE-ERROR]
2361 (compile nil
2362 '(lambda (frob)
2363 (labels
2364 ((%zig (frob)
2365 (typecase frob
2366 (double-float
2367 (setf (sb-alien:deref (sb-alien:cast (sb-alien:sap-alien (unknown1) (* unsigned-char))
2368 (* double-float))) frob))
2369 (hash-table
2370 (%zig (the (values (single-float (0.0) 1.0) &optional) (unknown2)))
2371 nil))))
2372 (%zig))))
2373
2374 ;;; non-required arguments in HANDLER-BIND
2375 (assert (eq :oops (car (funcall (compile nil
2376 '(lambda (x)
2377 (block nil
2378 (handler-bind ((error (lambda (&rest args) (return (cons :oops args)))))
2379 (/ 2 x)))))
2380 0))))
2381
2382 ;;; NIL is a legal function name
2383 (assert (eq 'a (flet ((nil () 'a)) (nil))))
2384
2385 ;;; misc.528
2386 (assert (null (let* ((x 296.3066f0)
2387 (y 22717067)
2388 (form `(lambda (r p2)
2389 (declare (optimize speed (safety 1))
2390 (type (simple-array single-float nil) r)
2391 (type (integer -9369756340 22717335) p2))
2392 (setf (aref r) (* ,x (the (eql 22717067) p2)))
2393 (values)))
2394 (r (make-array nil :element-type 'single-float))
2395 (expected (* x y)))
2396 (funcall (compile nil form) r y)
2397 (let ((actual (aref r)))
2398 (unless (eql expected actual)
2399 (list expected actual))))))
2400 ;;; misc.529
2401 (assert (null (let* ((x -2367.3296f0)
2402 (y 46790178)
2403 (form `(lambda (r p2)
2404 (declare (optimize speed (safety 1))
2405 (type (simple-array single-float nil) r)
2406 (type (eql 46790178) p2))
2407 (setf (aref r) (+ ,x (the (integer 45893897) p2)))
2408 (values)))
2409 (r (make-array nil :element-type 'single-float))
2410 (expected (+ x y)))
2411 (funcall (compile nil form) r y)
2412 (let ((actual (aref r)))
2413 (unless (eql expected actual)
2414 (list expected actual))))))
2415
2416 ;;; misc.556
2417 (assert (eql -1
2418 (funcall
2419 (compile nil '(lambda (p1 p2)
2420 (declare
2421 (optimize (speed 1) (safety 0)
2422 (debug 0) (space 0))
2423 (type (member 8174.8604) p1)
2424 (type (member -95195347) p2))
2425 (floor p1 p2)))
2426 8174.8604 -95195347)))
2427
2428 ;;; misc.557
2429 (assert (eql -1
2430 (funcall
2431 (compile
2432 nil
2433 '(lambda (p1)
2434 (declare (optimize (speed 3) (safety 0) (debug 3) (space 1))
2435 (type (member -94430.086f0) p1))
2436 (floor (the single-float p1) 19311235)))
2437 -94430.086f0)))
2438
2439 ;;; misc.558
2440 (assert (eql -1.0f0
2441 (funcall
2442 (compile
2443 nil
2444 '(lambda (p1)
2445 (declare (optimize (speed 1) (safety 2)
2446 (debug 2) (space 3))
2447 (type (eql -39466.56f0) p1))
2448 (ffloor p1 305598613)))
2449 -39466.56f0)))
2450
2451 ;;; misc.559
2452 (assert (eql 1
2453 (funcall
2454 (compile
2455 nil
2456 '(lambda (p1)
2457 (declare (optimize (speed 1) (safety 1) (debug 1) (space 2))
2458 (type (eql -83232.09f0) p1))
2459 (ceiling p1 -83381228)))
2460 -83232.09f0)))
2461
2462 ;;; misc.560
2463 (assert (eql 1
2464 (funcall
2465 (compile
2466 nil
2467 '(lambda (p1)
2468 (declare (optimize (speed 1) (safety 1)
2469 (debug 1) (space 0))
2470 (type (member -66414.414f0) p1))
2471 (ceiling p1 -63019173f0)))
2472 -66414.414f0)))
2473
2474 ;;; misc.561
2475 (assert (eql 1.0f0
2476 (funcall
2477 (compile
2478 nil
2479 '(lambda (p1)
2480 (declare (optimize (speed 0) (safety 1)
2481 (debug 0) (space 1))
2482 (type (eql 20851.398f0) p1))
2483 (fceiling p1 80839863)))
2484 20851.398f0)))
2485
2486 ;;; misc.581
2487 (assert (floatp
2488 (funcall
2489 (compile nil '(lambda (x)
2490 (declare (type (eql -5067.2056) x))
2491 (+ 213734822 x)))
2492 -5067.2056)))
2493
2494 ;;; misc.581a
2495 (assert (typep
2496 (funcall
2497 (compile nil '(lambda (x) (declare (type (eql -1.0) x))
2498 (+ #x1000001 x)))
2499 -1.0f0)
2500 'single-float))
2501
2502 ;;; misc.582
2503 (assert (plusp (funcall
2504 (compile
2505 nil
2506 ' (lambda (p1)
2507 (declare (optimize (speed 0) (safety 1) (debug 1) (space 1))
2508 (type (eql -39887.645) p1))
2509 (mod p1 382352925)))
2510 -39887.645)))
2511
2512 ;;; misc.587
2513 (assert (let ((result (funcall
2514 (compile
2515 nil
2516 '(lambda (p2)
2517 (declare (optimize (speed 0) (safety 3) (debug 1) (space 0))
2518 (type (eql 33558541) p2))
2519 (- 92215.266 p2)))
2520 33558541)))
2521 (typep result 'single-float)))
2522
2523 ;;; misc.635
2524 (assert (eql 1
2525 (let* ((form '(lambda (p2)
2526 (declare (optimize (speed 0) (safety 1)
2527 (debug 2) (space 2))
2528 (type (member -19261719) p2))
2529 (ceiling -46022.094 p2))))
2530 (values (funcall (compile nil form) -19261719)))))
2531
2532 ;;; misc.636
2533 (assert (let* ((x 26899.875)
2534 (form `(lambda (p2)
2535 (declare (optimize (speed 3) (safety 1) (debug 3) (space 1))
2536 (type (member ,x #:g5437 char-code #:g5438) p2))
2537 (* 104102267 p2))))
2538 (floatp (funcall (compile nil form) x))))
2539
2540 ;;; misc.622
2541 (assert (eql
2542 (funcall
2543 (compile
2544 nil
2545 '(lambda (p2)
2546 (declare (optimize (speed 3) (safety 2) (debug 3) (space 0))
2547 (type real p2))
2548 (+ 81535869 (the (member 17549.955 #:g35917) p2))))
2549 17549.955)
2550 (+ 81535869 17549.955)))
2551
2552 ;;; misc.654
2553 (assert (eql 2
2554 (let ((form '(lambda (p2)
2555 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2556 (type (member integer eql) p2))
2557 (coerce 2 p2))))
2558 (funcall (compile nil form) 'integer))))
2559
2560 ;;; misc.656
2561 (assert (eql 2
2562 (let ((form '(lambda (p2)
2563 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2564 (type (member integer mod) p2))
2565 (coerce 2 p2))))
2566 (funcall (compile nil form) 'integer))))
2567
2568 ;;; misc.657
2569 (assert (eql 2
2570 (let ((form '(lambda (p2)
2571 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2572 (type (member integer values) p2))
2573 (coerce 2 p2))))
2574 (funcall (compile nil form) 'integer))))
2575
2576 (with-test (:name :string-aref-type)
2577 (assert (eq 'character
2578 (funcall (compile nil
2579 '(lambda (s)
2580 (ctu:compiler-derived-type (aref (the string s) 0))))
2581 "foo"))))
2582
2583 (with-test (:name :base-string-aref-type)
2584 (assert (eq #+sb-unicode 'base-char
2585 #-sb-unicode 'character
2586 (funcall (compile nil
2587 '(lambda (s)
2588 (ctu:compiler-derived-type (aref (the base-string s) 0))))
2589 (coerce "foo" 'base-string)))))
2590
2591 (with-test (:name :dolist-constant-type-derivation)
2592 (assert (equal '(integer 1 3)
2593 (funcall (compile nil
2594 '(lambda (x)
2595 (dolist (y '(1 2 3))
2596 (when x
2597 (return (ctu:compiler-derived-type y))))))
2598 t))))
2599
2600 (with-test (:name :dolist-simple-list-type-derivation)
2601 (assert (equal '(integer 1 3)
2602 (funcall (compile nil
2603 '(lambda (x)
2604 (dolist (y (list 1 2 3))
2605 (when x
2606 (return (ctu:compiler-derived-type y))))))
2607 t))))
2608
2609 (with-test (:name :dolist-dotted-constant-list-type-derivation)
2610 (let* ((warned nil)
2611 (fun (handler-bind ((style-warning (lambda (c) (push c warned))))
2612 (compile nil
2613 '(lambda (x)
2614 (dolist (y '(1 2 3 . 4) :foo)
2615 (when x
2616 (return (ctu:compiler-derived-type y)))))))))
2617 (assert (equal '(integer 1 3) (funcall fun t)))
2618 (assert (= 1 (length warned)))
2619 (multiple-value-bind (res err) (ignore-errors (funcall fun nil))
2620 (assert (not res))
2621 (assert (typep err 'type-error)))))
2622
2623 (with-test (:name :constant-list-destructuring)
2624 (handler-bind ((sb-ext:compiler-note #'error))
2625 (progn
2626 (assert (= 10
2627 (funcall
2628 (compile nil
2629 '(lambda ()
2630 (destructuring-bind (a (b c) d) '(1 (2 3) 4)
2631 (+ a b c d)))))))
2632 (assert (eq :feh
2633 (funcall
2634 (compile nil
2635 '(lambda (x)
2636 (or x
2637 (destructuring-bind (a (b c) d) '(1 "foo" 4)
2638 (+ a b c d)))))
2639 :feh))))))
2640
2641 ;;; Functions with non-required arguments used to end up with
2642 ;;; (&OPTIONAL-DISPATCH ...) as their names.
2643 (with-test (:name :hairy-function-name)
2644 (assert (eq 'read-line (nth-value 2 (function-lambda-expression #'read-line))))
2645 (assert (equal "#<FUNCTION READ-LINE>" (princ-to-string #'read-line))))
2646
2647 ;;; PROGV + RESTRICT-COMPILER-POLICY
2648 (with-test (:name :progv-and-restrict-compiler-policy)
2649 (let ((sb-c::*policy-restrictions* sb-c::*policy-restrictions*))
2650 (restrict-compiler-policy 'debug 3)
2651 (let ((fun (compile nil '(lambda (x)
2652 (let ((i x))
2653 (declare (special i))
2654 (list i
2655 (progv '(i) (list (+ i 1))
2656 i)
2657 i))))))
2658 (assert (equal '(1 2 1) (funcall fun 1))))))
2659
2660 ;;; It used to be possible to confuse the compiler into
2661 ;;; IR2-converting such a call to CONS
2662 (with-test (:name :late-bound-primitive)
2663 (compile nil `(lambda ()
2664 (funcall 'cons 1))))
2665
2666 (with-test (:name :hairy-array-element-type-derivation)
2667 (compile nil '(lambda (x)
2668 (declare (type (and simple-string (satisfies array-has-fill-pointer-p)) x))
2669 (array-element-type x))))
2670
2671 (with-test (:name :rest-list-type-derivation)
2672 (multiple-value-bind (type derivedp)
2673 (funcall (compile nil `(lambda (&rest args)
2674 (ctu:compiler-derived-type args)))
2675 nil)
2676 (assert (eq 'list type))
2677 (assert derivedp)))
2678
2679 (with-test (:name :base-char-typep-elimination)
2680 (assert (eq (funcall (lambda (ch)
2681 (declare (type base-char ch) (optimize (speed 3) (safety 0)))
2682 (typep ch 'base-char))
2683 t)
2684 t)))
2685
2686 (with-test (:name :regression-1.0.24.37)
2687 (compile nil '(lambda (&key (test (constantly t)))
2688 (when (funcall test)
2689 :quux))))
2690
2691 ;;; Attempt to test a decent cross section of conditions
2692 ;;; and values types to move conditionally.
2693 (macrolet
2694 ((test-comparison (comparator type x y)
2695 `(progn
2696 ,@(loop for (result-type a b)
2697 in '((nil t nil)
2698 (nil 0 1)
2699 (nil 0.0 1.0)
2700 (nil 0d0 0d0)
2701 (nil 0.0 0d0)
2702 (nil #c(1.0 1.0) #c(2.0 2.0))
2703
2704 (t t nil)
2705 (fixnum 0 1)
2706 ((unsigned-byte #.sb-vm:n-word-bits)
2707 (1+ most-positive-fixnum)
2708 (+ 2 most-positive-fixnum))
2709 ((signed-byte #.sb-vm:n-word-bits)
2710 -1 (* 2 most-negative-fixnum))
2711 (single-float 0.0 1.0)
2712 (double-float 0d0 1d0))
2713 for lambda = (if result-type
2714 `(lambda (x y a b)
2715 (declare (,type x y)
2716 (,result-type a b))
2717 (if (,comparator x y)
2718 a b))
2719 `(lambda (x y)
2720 (declare (,type x y))
2721 (if (,comparator x y)
2722 ,a ,b)))
2723 for args = `(,x ,y ,@(and result-type
2724 `(,a ,b)))
2725 collect
2726 `(progn
2727 (eql (funcall (compile nil ',lambda)
2728 ,@args)
2729 (eval '(,lambda ,@args))))))))
2730 (sb-vm::with-float-traps-masked
2731 (:divide-by-zero :overflow :inexact :invalid)
2732 (let ((sb-ext:*evaluator-mode* :interpret))
2733 (declare (sb-ext:muffle-conditions style-warning))
2734 (test-comparison eql t t nil)
2735 (test-comparison eql t t t)
2736
2737 (test-comparison = t 1 0)
2738 (test-comparison = t 1 1)
2739 (test-comparison = t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2740 (test-comparison = fixnum 1 0)
2741 (test-comparison = fixnum 0 0)
2742 (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2743 (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2744 (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 0)
2745 (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 1)
2746
2747 (test-comparison = single-float 0.0 1.0)
2748 (test-comparison = single-float 1.0 1.0)
2749 (test-comparison = single-float (/ 1.0 0.0) (/ 1.0 0.0))
2750 (test-comparison = single-float (/ 1.0 0.0) 1.0)
2751 (test-comparison = single-float (/ 0.0 0.0) (/ 0.0 0.0))
2752 (test-comparison = single-float (/ 0.0 0.0) 0.0)
2753
2754 (test-comparison = double-float 0d0 1d0)
2755 (test-comparison = double-float 1d0 1d0)
2756 (test-comparison = double-float (/ 1d0 0d0) (/ 1d0 0d0))
2757 (test-comparison = double-float (/ 1d0 0d0) 1d0)
2758 (test-comparison = double-float (/ 0d0 0d0) (/ 0d0 0d0))
2759 (test-comparison = double-float (/ 0d0 0d0) 0d0)
2760
2761 (test-comparison < t 1 0)
2762 (test-comparison < t 0 1)
2763 (test-comparison < t 1 1)
2764 (test-comparison < t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2765 (test-comparison < t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum))
2766 (test-comparison < fixnum 1 0)
2767 (test-comparison < fixnum 0 1)
2768 (test-comparison < fixnum 0 0)
2769 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2770 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 1)
2771 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2772 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 0)
2773 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 0 1)
2774 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 1)
2775
2776 (test-comparison < single-float 0.0 1.0)
2777 (test-comparison < single-float 1.0 0.0)
2778 (test-comparison < single-float 1.0 1.0)
2779 (test-comparison < single-float (/ 1.0 0.0) (/ 1.0 0.0))
2780 (test-comparison < single-float (/ 1.0 0.0) 1.0)
2781 (test-comparison < single-float 1.0 (/ 1.0 0.0))
2782 (test-comparison < single-float (/ 0.0 0.0) (/ 0.0 0.0))
2783 (test-comparison < single-float (/ 0.0 0.0) 0.0)
2784
2785 (test-comparison < double-float 0d0 1d0)
2786 (test-comparison < double-float 1d0 0d0)
2787 (test-comparison < double-float 1d0 1d0)
2788 (test-comparison < double-float (/ 1d0 0d0) (/ 1d0 0d0))
2789 (test-comparison < double-float (/ 1d0 0d0) 1d0)
2790 (test-comparison < double-float 1d0 (/ 1d0 0d0))
2791 (test-comparison < double-float (/ 0d0 0d0) (/ 0d0 0d0))
2792 (test-comparison < double-float (/ 0d0 0d0) 0d0)
2793 (test-comparison < double-float 0d0 (/ 0d0 0d0))
2794
2795 (test-comparison > t 1 0)
2796 (test-comparison > t 0 1)
2797 (test-comparison > t 1 1)
2798 (test-comparison > t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2799 (test-comparison > t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum))
2800 (test-comparison > fixnum 1 0)
2801 (test-comparison > fixnum 0 1)
2802 (test-comparison > fixnum 0 0)
2803 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2804 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 1)
2805 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2806 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 0)
2807 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 0 1)
2808 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 1)
2809
2810 (test-comparison > single-float 0.0 1.0)
2811 (test-comparison > single-float 1.0 0.0)
2812 (test-comparison > single-float 1.0 1.0)
2813 (test-comparison > single-float (/ 1.0 0.0) (/ 1.0 0.0))
2814 (test-comparison > single-float (/ 1.0 0.0) 1.0)
2815 (test-comparison > single-float 1.0 (/ 1.0 0.0))
2816 (test-comparison > single-float (/ 0.0 0.0) (/ 0.0 0.0))
2817 (test-comparison > single-float (/ 0.0 0.0) 0.0)
2818
2819 (test-comparison > double-float 0d0 1d0)
2820 (test-comparison > double-float 1d0 0d0)
2821 (test-comparison > double-float 1d0 1d0)
2822 (test-comparison > double-float (/ 1d0 0d0) (/ 1d0 0d0))
2823 (test-comparison > double-float (/ 1d0 0d0) 1d0)
2824 (test-comparison > double-float 1d0 (/ 1d0 0d0))
2825 (test-comparison > double-float (/ 0d0 0d0) (/ 0d0 0d0))
2826 (test-comparison > double-float (/ 0d0 0d0) 0d0)
2827 (test-comparison > double-float 0d0 (/ 0d0 0d0)))))
2828
2829 (with-test (:name :car-and-cdr-type-derivation-conservative)
2830 (let ((f1 (compile nil
2831 `(lambda (y)
2832 (declare (optimize speed))
2833 (let ((x (the (cons fixnum fixnum) (cons 1 2))))
2834 (declare (type (cons t fixnum) x))
2835 (rplaca x y)
2836 (+ (car x) (cdr x))))))
2837 (f2 (compile nil
2838 `(lambda (y)
2839 (declare (optimize speed))
2840 (let ((x (the (cons fixnum fixnum) (cons 1 2))))
2841 (setf (cdr x) y)
2842 (+ (car x) (cdr x)))))))
2843 (flet ((test-error (e value)
2844 (assert (typep e 'type-error))
2845 (assert (eq 'number (type-error-expected-type e)))
2846 (assert (eq value (type-error-datum e)))))
2847 (let ((v1 "foo")
2848 (v2 "bar"))
2849 (multiple-value-bind (res err) (ignore-errors (funcall f1 v1))
2850 (assert (not res))
2851 (test-error err v1))
2852 (multiple-value-bind (res err) (ignore-errors (funcall f2 v2))
2853 (assert (not res))
2854 (test-error err v2))))))
2855
2856 (with-test (:name :array-dimension-derivation-conservative)
2857 (let ((f (compile nil
2858 `(lambda (x)
2859 (declare (optimize speed))
2860 (declare (type (array * (4 4)) x))
2861 (let ((y x))
2862 (setq x (make-array '(4 4)))
2863 (adjust-array y '(3 5))
2864 (array-dimension y 0))))))
2865 (assert (= 3 (funcall f (make-array '(4 4) :adjustable t))))))
2866
2867 (with-test (:name :with-timeout-code-deletion-note)
2868 (handler-bind ((sb-ext:code-deletion-note #'error))
2869 (compile nil `(lambda ()
2870 (sb-ext:with-timeout 0
2871 (sleep 1))))))
2872
2873 (with-test (:name :full-warning-for-undefined-type-in-cl)
2874 (assert (eq :full
2875 (handler-case
2876 (compile nil `(lambda (x) (the replace x)))
2877 (style-warning ()
2878 :style)
2879 (warning ()
2880 :full)))))
2881
2882 (with-test (:name :single-warning-for-single-undefined-type)
2883 (let ((n 0))
2884 (handler-bind ((warning (lambda (c)
2885 (declare (ignore c))
2886 (incf n))))
2887 (compile nil `(lambda (x) (the #:no-type x)))
2888 (assert (= 1 n))
2889 (compile nil `(lambda (x) (the 'fixnum x)))
2890 (assert (= 2 n)))))
2891
2892 (with-test (:name :complex-subtype-dumping-in-xc)
2893 (assert
2894 (= sb-vm:complex-single-float-widetag
2895 (sb-kernel:widetag-of
2896 (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex single-float))))))
2897 (assert
2898 (= sb-vm:complex-double-float-widetag
2899 (sb-kernel:widetag-of
2900 (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex double-float)))))))
2901
2902 (with-test (:name :complex-single-float-fill)
2903 (assert (every (lambda (x) (= #c(1.0 2.0) x))
2904 (funcall
2905 (compile nil
2906 `(lambda (n x)
2907 (make-array (list n)
2908 :element-type '(complex single-float)
2909 :initial-element x)))
2910 10
2911 #c(1.0 2.0)))))
2912
2913 (with-test (:name :regression-1.0.28.21)
2914 (let ((fun (compile nil `(lambda (x) (typep x '(simple-array * 1))))))
2915 (assert (funcall fun (vector 1 2 3)))
2916 (assert (funcall fun "abc"))
2917 (assert (not (funcall fun (make-array '(2 2)))))))
2918
2919 (with-test (:name :no-silly-compiler-notes-from-character-function)
2920 (let (current)
2921 (handler-bind ((compiler-note (lambda (e) (error "~S: ~A" current e))))
2922 (dolist (name '(char-code char-int character char-name standard-char-p
2923 graphic-char-p alpha-char-p upper-case-p lower-case-p
2924 both-case-p digit-char-p alphanumericp digit-char-p))
2925 (setf current name)
2926 (compile nil `(lambda (x)
2927 (declare (character x) (optimize speed))
2928 (,name x))))
2929 (dolist (name '(char= char/= char< char> char<= char>= char-equal
2930 char-not-equal char-lessp char-greaterp char-not-greaterp
2931 char-not-lessp))
2932 (setf current name)
2933 (compile nil `(lambda (x y)
2934 (declare (character x y) (optimize speed))
2935 (,name x y)))))))
2936
2937 ;;; optimizing make-array
2938 (with-test (:name (make-array :open-code-initial-contents))
2939 (assert (not (ctu:find-named-callees
2940 (compile nil
2941 `(lambda (x y z)
2942 (make-array '(3) :initial-contents (list x y z)))))))
2943 (assert (not (ctu:find-named-callees
2944 (compile nil
2945 `(lambda (x y z)
2946 (make-array '3 :initial-contents (vector x y z)))))))
2947 (assert (not (ctu:find-named-callees
2948 (compile nil
2949 `(lambda (x y z)
2950 (make-array '3 :initial-contents `(,x ,y ,z))))))))
2951
2952 ;;; optimizing array-in-bounds-p
2953 (with-test (:name :optimize-array-in-bounds-p)
2954 (locally
2955 (macrolet ((find-callees (&body body)
2956 `(ctu:find-named-callees
2957 (compile nil
2958 '(lambda ()
2959 ,@body))
2960 :name 'array-in-bounds-p))
2961 (must-optimize (&body exprs)
2962 `(progn
2963 ,@(loop for expr in exprs
2964 collect `(assert (not (find-callees
2965 ,expr))))))
2966 (must-not-optimize (&body exprs)
2967 `(progn
2968 ,@(loop for expr in exprs
2969 collect `(assert (find-callees
2970 ,expr))))))
2971 (must-optimize
2972 ;; in bounds
2973 (let ((a (make-array '(1))))
2974 (array-in-bounds-p a 0))
2975 ;; exceeds upper bound (constant)
2976 (let ((a (make-array '(1))))
2977 (array-in-bounds-p a 1))
2978 ;; exceeds upper bound (interval)
2979 (let ((a (make-array '(1))))
2980 (array-in-bounds-p a (+ 1 (random 2))))
2981 ;; negative lower bound (constant)
2982 (let ((a (make-array '(1))))
2983 (array-in-bounds-p a -1))
2984 ;; negative lower bound (interval)
2985 (let ((a (make-array 3))
2986 (i (- (random 1) 20)))
2987 (array-in-bounds-p a i))
2988 ;; multiple known dimensions
2989 (let ((a (make-array '(1 1))))
2990 (array-in-bounds-p a 0 0))
2991 ;; union types
2992 (let ((s (the (simple-string 10) (eval "0123456789"))))
2993 (array-in-bounds-p s 9)))
2994 (must-not-optimize
2995 ;; don't trust non-simple array length in safety=1
2996 (let ((a (the (array * (10)) (make-array 10 :adjustable t))))
2997 (eval `(adjust-array ,a 0))
2998 (array-in-bounds-p a 9))
2999 ;; same for a union type
3000 (let ((s (the (string 10) (make-array 10
3001 :element-type 'character
3002 :adjustable t))))
3003 (eval `(adjust-array ,s 0))
3004 (array-in-bounds-p s 9))
3005 ;; single unknown dimension
3006 (let ((a (make-array (random 20))))
3007 (array-in-bounds-p a 10))
3008 ;; multiple unknown dimensions
3009 (let ((a (make-array (list (random 20) (random 5)))))
3010 (array-in-bounds-p a 5 2))
3011 ;; some other known dimensions
3012 (let ((a (make-array (list 1 (random 5)))))
3013 (array-in-bounds-p a 0 2))
3014 ;; subscript might be negative
3015 (let ((a (make-array 5)))
3016 (array-in-bounds-p a (- (random 3) 2)))
3017 ;; subscript might be too large
3018 (let ((a (make-array 5)))
3019 (array-in-bounds-p a (random 6)))
3020 ;; unknown upper bound
3021 (let ((a (make-array 5)))
3022 (array-in-bounds-p a (get-universal-time)))
3023 ;; unknown lower bound
3024 (let ((a (make-array 5)))
3025 (array-in-bounds-p a (- (get-universal-time))))
3026 ;; in theory we should be able to optimize
3027 ;; the following but the current implementation
3028 ;; doesn't cut it because the array type's
3029 ;; dimensions get reported as (* *).
3030 (let ((a (make-array (list (random 20) 1))))
3031 (array-in-bounds-p a 5 2))))))
3032
3033 ;;; optimizing (EXPT -1 INTEGER)
3034 (test-util:with-test (:name (expt minus-one integer))
3035 (dolist (x '(-1 -1.0 -1.0d0))
3036 (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x))))))
3037 (assert (not (ctu:find-named-callees fun)))
3038 (dotimes (i 12)
3039 (if (oddp i)
3040 (assert (eql x (funcall fun i)))
3041 (assert (eql (- x) (funcall fun i))))))))
3042
3043 (with-test (:name (load-time-value :type-derivation))
3044 (flet ((test (type form value-cell-p)
3045 (let ((derived (funcall (compile
3046 nil
3047 `(lambda ()
3048 (ctu:compiler-derived-type
3049 (load-time-value ,form)))))))
3050 (unless (equal type derived)
3051 (error "wanted ~S, got ~S" type derived)))))
3052 (let ((* 10))
3053 (test '(integer 11 11) '(+ * 1) nil))
3054 (let ((* "fooo"))
3055 (test '(integer 4 4) '(length *) t))))
3056
3057 (with-test (:name :float-division-using-exact-reciprocal)
3058 (flet ((test (lambda-form arg res &key (check-insts t))
3059 (let* ((fun (compile nil lambda-form))
3060 (disassembly (with-output-to-string (s)
3061 (disassemble fun :stream s))))
3062 ;; Let's make sure there is no division at runtime: for x86 and
3063 ;; x86-64 that implies an FDIV, DIVSS, or DIVSD instruction, so
3064 ;; look for DIV in the disassembly. It's a terrible KLUDGE, but
3065 ;; it works.
3066 #+(or x86 x86-64)
3067 (when check-insts
3068 (assert (not (search "DIV" disassembly))))
3069 ;; No generic arithmetic!
3070 (assert (not (search "GENERIC" disassembly)))
3071 (assert (eql res (funcall fun arg))))))
3072 (dolist (c '(128 64 32 16 8 4 2 1 1/2 1/4 1/8 1/16 1/32 1/64))
3073 (dolist (type '(single-float double-float))
3074 (let* ((cf (coerce c type))
3075 (arg (- (random (* 2 cf)) cf))
3076 (r1 (eval `(/ ,arg ,cf)))
3077 (r2 (eval `(/ ,arg ,(- cf)))))
3078 (test `(lambda (x) (declare (,type x)) (/ x ,cf)) arg r1)
3079 (test `(lambda (x) (declare (,type x)) (/ x ,(- cf))) arg r2)
3080 ;; rational args should get optimized as well
3081 (test `(lambda (x) (declare (,type x)) (/ x ,c)) arg r1)
3082 (test `(lambda (x) (declare (,type x)) (/ x ,(- c))) arg r2))))
3083 ;; Also check that inexact reciprocals (1) are not used by default (2) are
3084 ;; used with FLOAT-ACCURACY=0.
3085 (dolist (type '(single-float double-float))
3086 (let ((trey (coerce 3 type))
3087 (one (coerce 1 type)))
3088 (test `(lambda (x) (declare (,type x)) (/ x 3)) trey one
3089 :check-insts nil)
3090 (test `(lambda (x)
3091 (declare (,type x)
3092 (optimize (sb-c::float-accuracy 0)))
3093 (/ x 3))
3094 trey (eval `(* ,trey (/ ,trey))))))))
3095
3096 (with-test (:name :float-multiplication-by-one)
3097 (flet ((test (lambda-form arg &optional (result arg))
3098 (let* ((fun1 (compile nil lambda-form))
3099 (fun2 (funcall (compile nil `(lambda ()
3100 (declare (optimize (sb-c::float-accuracy 0)))
3101 ,lambda-form))))
3102 (disassembly1 (with-output-to-string (s)
3103 (disassemble fun1 :stream s)))
3104 (disassembly2 (with-output-to-string (s)
3105 (disassemble fun2 :stream s))))
3106 ;; Multiplication at runtime should be eliminated only with
3107 ;; FLOAT-ACCURACY=0. (To catch SNaNs.)
3108 #+(or x86 x86-64)
3109 (assert (and (search "MUL" disassembly1)
3110 (not (search "MUL" disassembly2))))
3111 ;; Not generic arithmetic, please!
3112 (assert (and (not (search "GENERIC" disassembly1))
3113 (not (search "GENERIC" disassembly2))))
3114 (assert (eql result (funcall fun1 arg)))
3115 (assert (eql result (funcall fun2 arg))))))
3116 (dolist (type '(single-float double-float))
3117 (let* ((one (coerce 1 type))
3118 (arg (random (* 2 one)))
3119 (-r (- arg)))
3120 (test `(lambda (x) (declare (,type x)) (* x 1)) arg)
3121 (test `(lambda (x) (declare (,type x)) (* x -1)) arg -r)
3122 (test `(lambda (x) (declare (,type x)) (* x ,one)) arg)
3123 (test `(lambda (x) (declare (,type x)) (* x ,(- one))) arg -r)))))
3124
3125 (with-test (:name :float-addition-of-zero)
3126 (flet ((test (lambda-form arg &optional (result arg))
3127 (let* ((fun1 (compile nil lambda-form))
3128 (fun2 (funcall (compile nil `(lambda ()
3129 (declare (optimize (sb-c::float-accuracy 0)))
3130 ,lambda-form))))
3131 (disassembly1 (with-output-to-string (s)
3132 (disassemble fun1 :stream s)))
3133 (disassembly2 (with-output-to-string (s)
3134 (disassemble fun2 :stream s))))
3135 ;; Let's make sure there is no addition at runtime: for x86 and
3136 ;; x86-64 that implies an FADD, ADDSS, or ADDSD instruction, so
3137 ;; look for the ADDs in the disassembly. It's a terrible KLUDGE,
3138 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3139 ;; addition in to catch SNaNs.
3140 #+x86
3141 (assert (and (search "FADD" disassembly1)
3142 (not (search "FADD" disassembly2))))
3143 #+x86-64
3144 (let ((inst (if (typep result 'double-float)
3145 "ADDSD" "ADDSS")))
3146 (assert (and (search inst disassembly1)
3147 (not (search inst disassembly2)))))
3148 (assert (eql result (funcall fun1 arg)))
3149 (assert (eql result (funcall fun2 arg))))))
3150 (test `(lambda (x) (declare (single-float x)) (+ x 0)) 123.45)
3151 (test `(lambda (x) (declare (single-float x)) (+ x 0.0)) 543.21)
3152 (test `(lambda (x) (declare (single-float x)) (+ x 0.0d0)) 42.00 42.d0)
3153 (test `(lambda (x) (declare (double-float x)) (+ x 0)) 123.45d0)
3154 (test `(lambda (x) (declare (double-float x)) (+ x 0.0)) 543.21d0)
3155 (test `(lambda (x) (declare (double-float x)) (+ x 0.0d0)) 42.d0)))
3156
3157 (with-test (:name :float-substraction-of-zero)
3158 (flet ((test (lambda-form arg &optional (result arg))
3159 (let* ((fun1 (compile nil lambda-form))
3160 (fun2 (funcall (compile nil `(lambda ()
3161 (declare (optimize (sb-c::float-accuracy 0)))
3162 ,lambda-form))))
3163 (disassembly1 (with-output-to-string (s)
3164 (disassemble fun1 :stream s)))
3165 (disassembly2 (with-output-to-string (s)
3166 (disassemble fun2 :stream s))))
3167 ;; Let's make sure there is no substraction at runtime: for x86
3168 ;; and x86-64 that implies an FSUB, SUBSS, or SUBSD instruction,
3169 ;; so look for SUB in the disassembly. It's a terrible KLUDGE,
3170 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3171 ;; substraction in in to catch SNaNs.
3172 #+x86
3173 (assert (and (search "FSUB" disassembly1)
3174 (not (search "FSUB" disassembly2))))
3175 #+x86-64
3176 (let ((inst (if (typep result 'double-float)
3177 "SUBSD" "SUBSS")))
3178 (assert (and (search inst disassembly1)
3179 (not (search inst disassembly2)))))
3180 (assert (eql result (funcall fun1 arg)))
3181 (assert (eql result (funcall fun2 arg))))))
3182 (test `(lambda (x) (declare (single-float x)) (- x 0)) 123.45)
3183 (test `(lambda (x) (declare (single-float x)) (- x 0.0)) 543.21)
3184 (test `(lambda (x) (declare (single-float x)) (- x 0.0d0)) 42.00 42.d0)
3185 (test `(lambda (x) (declare (double-float x)) (- x 0)) 123.45d0)
3186 (test `(lambda (x) (declare (double-float x)) (- x 0.0)) 543.21d0)
3187 (test `(lambda (x) (declare (double-float x)) (- x 0.0d0)) 42.d0)))
3188
3189 (with-test (:name :float-multiplication-by-two)
3190 (flet ((test (lambda-form arg &optional (result arg))
3191 (let* ((fun1 (compile nil lambda-form))
3192 (fun2 (funcall (compile nil `(lambda ()
3193 (declare (optimize (sb-c::float-accuracy 0)))
3194 ,lambda-form))))
3195 (disassembly1 (with-output-to-string (s)
3196 (disassemble fun1 :stream s)))
3197 (disassembly2 (with-output-to-string (s)
3198 (disassemble fun2 :stream s))))
3199 ;; Let's make sure there is no multiplication at runtime: for x86
3200 ;; and x86-64 that implies an FMUL, MULSS, or MULSD instruction,
3201 ;; so look for MUL in the disassembly. It's a terrible KLUDGE,
3202 ;; but it works.
3203 #+(or x86 x86-64)
3204 (assert (and (not (search "MUL" disassembly1))
3205 (not (search "MUL" disassembly2))))
3206 (assert (eql result (funcall fun1 arg)))
3207 (assert (eql result (funcall fun2 arg))))))
3208 (test `(lambda (x) (declare (single-float x)) (* x 2)) 123.45 246.9)
3209 (test `(lambda (x) (declare (single-float x)) (* x 2.0)) 543.21 1086.42)
3210 (test `(lambda (x) (declare (single-float x)) (* x 2.0d0)) 42.00 84.d0)
3211 (test `(lambda (x) (declare (double-float x)) (* x 2)) 123.45d0 246.9d0)
3212 (test `(lambda (x) (declare (double-float x)) (* x 2.0)) 543.21d0 1086.42d0)
3213 (test `(lambda (x) (declare (double-float x)) (* x 2.0d0)) 42.0d0 84.0d0)))
3214
3215 (with-test (:name :bug-392203)
3216 ;; Used to hit an AVER in COMVERT-MV-CALL.
3217 (assert (zerop
3218 (funcall
3219 (compile nil
3220 `(lambda ()
3221 (flet ((k (&rest x) (declare (ignore x)) 0))
3222 (multiple-value-call #'k #'k))))))))
3223
3224 (with-test (:name :allocate-closures-failing-aver)
3225 (let ((f (compile nil `(lambda ()
3226 (labels ((k (&optional x) #'k)))))))
3227 (assert (null (funcall f)))))
3228
3229 (with-test (:name :flush-vector-creation)
3230 (let ((f (compile nil `(lambda ()
3231 (dotimes (i 1024)
3232 (vector i i i))
3233 t))))
3234 (ctu:assert-no-consing (funcall f))))
3235
3236 (with-test (:name :array-type-predicates)
3237 (dolist (et sb-kernel::*specialized-array-element-types*)
3238 (when et
3239 (let* ((v (make-array 3 :element-type et))
3240 (fun (compile nil `(lambda ()
3241 (list
3242 (if (typep ,v '(simple-array ,et (*)))
3243 :good
3244 :bad)
3245 (if (typep (elt ,v 0) '(simple-array ,et (*)))
3246 :bad
3247 :good))))))
3248 (assert (equal '(:good :good) (funcall fun)))))))
3249
3250 (with-test (:name :truncate-float)
3251 (let ((s (compile nil `(lambda (x)
3252 (declare (single-float x))
3253 (truncate x))))
3254 (d (compile nil `(lambda (x)
3255 (declare (double-float x))
3256 (truncate x))))
3257 (s-inlined (compile nil '(lambda (x)
3258 (declare (type (single-float 0.0s0 1.0s0) x))
3259 (truncate x))))
3260 (d-inlined (compile nil '(lambda (x)
3261 (declare (type (double-float 0.0d0 1.0d0) x))
3262 (truncate x)))))
3263 ;; Check that there is no generic arithmetic
3264 (assert (not (search "GENERIC"
3265 (with-output-to-string (out)
3266 (disassemble s :stream out)))))
3267 (assert (not (search "GENERIC"
3268 (with-output-to-string (out)
3269 (disassemble d :stream out)))))
3270 ;; Check that we actually inlined the call when we were supposed to.
3271 (assert (not (search "UNARY-TRUNCATE"
3272 (with-output-to-string (out)
3273 (disassemble s-inlined :stream out)))))
3274 (assert (not (search "UNARY-TRUNCATE"
3275 (with-output-to-string (out)
3276 (disassemble d-inlined :stream out)))))))
3277
3278 (with-test (:name :make-array-unnamed-dimension-leaf)
3279 (let ((fun (compile nil `(lambda (stuff)
3280 (make-array (map 'list 'length stuff))))))
3281 (assert (equalp #2A((0 0 0) (0 0 0))
3282 (funcall fun '((1 2) (1 2 3)))))))
3283
3284 (with-test (:name :fp-decoding-funs-not-flushable-in-safe-code)
3285 (dolist (name '(float-sign float-radix float-digits float-precision decode-float
3286 integer-decode-float))
3287 (let ((fun (compile nil `(lambda (x)
3288 (declare (optimize safety))
3289 (,name x)
3290 nil))))
3291 (flet ((test (arg)
3292 (unless (eq :error
3293 (handler-case
3294 (funcall fun arg)
3295 (error () :error)))
3296 (error "(~S ~S) did not error"
3297 name arg))))
3298 ;; No error
3299 (funcall fun 1.0)
3300 ;; Error
3301 (test 'not-a-float)
3302 (when (member name '(decode-float integer-decode-float))
3303 (test sb-ext:single-float-positive-infinity))))))
3304
3305 (with-test (:name :sap-ref-16)
3306 (let* ((fun (compile nil `(lambda (x y)
3307 (declare (type sb-sys:system-area-pointer x)
3308 (type (integer 0 100) y))
3309 (sb-sys:sap-ref-16 x (+ 4 y)))))
3310 (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
3311 '(simple-array (unsigned-byte 8) (*))))
3312 (sap (sb-sys:vector-sap vector))
3313 (ret (funcall fun sap 0)))
3314 ;; test for either endianness
3315 (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))
3316
3317 (with-test (:name :coerce-type-warning)
3318 (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
3319 (signed-byte 8) (signed-byte 16) (signed-byte 32)))
3320 (multiple-value-bind (fun warningsp failurep)
3321 (compile nil `(lambda (x)
3322 (declare (type simple-vector x))
3323 (coerce x '(vector ,type))))
3324 (assert (null warningsp))
3325 (assert (null failurep))
3326 (assert (typep (funcall fun #(1)) `(simple-array ,type (*)))))))
3327
3328 (with-test (:name :truncate-double-float)
3329 (let ((fun (compile nil `(lambda (x)
3330 (multiple-value-bind (q r)
3331 (truncate (coerce x 'double-float))
3332 (declare (type unsigned-byte q)
3333 (type double-float r))
3334 (list q r))))))
3335 (assert (equal (funcall fun 1.0d0) '(1 0.0d0)))))
3336
3337 (with-test (:name :set-slot-value-no-warning)
3338 (let ((notes 0))
3339 (handler-bind ((warning #'error)
3340 (sb-ext:compiler-note (lambda (c)
3341 (declare (ignore c))
3342 (incf notes))))
3343 (compile nil `(lambda (x y)
3344 (declare (optimize speed safety))
3345 (setf (slot-value x 'bar) y))))
3346 (assert (= 1 notes))))
3347
3348 (with-test (:name :concatenate-string-opt)
3349 (flet ((test (type grep)
3350 (let* ((fun (compile nil `(lambda (a b c d e)
3351 (concatenate ',type a b c d e))))
3352 (args '("foo" #(#\.) "bar" (#\-) "quux"))
3353 (res (apply fun args)))
3354 (assert (search grep (with-output-to-string (out)
3355 (disassemble fun :stream out))))
3356 (assert (equal (apply #'concatenate type args)
3357 res))
3358 (assert (typep res type)))))
3359 (test 'string "%CONCATENATE-TO-STRING")
3360 (test 'simple-string "%CONCATENATE-TO-STRING")
3361 (test 'base-string "%CONCATENATE-TO-BASE-STRING")
3362 (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING")))
3363
3364 (with-test (:name :satisfies-no-local-fun)
3365 (let ((fun (compile nil `(lambda (arg)
3366 (labels ((local-not-global-bug (x)
3367 t)
3368 (bar (x)
3369 (typep x '(satisfies local-not-global-bug))))
3370 (bar arg))))))
3371 (assert (eq 'local-not-global-bug
3372 (handler-case
3373 (funcall fun 42)
3374 (undefined-function (c)
3375 (cell-error-name c)))))))
3376
3377 ;;; Prior to 1.0.32.x, dumping a fasl with a function with a default
3378 ;;; argument that is a complex structure (needing make-load-form
3379 ;;; processing) failed an AVER. The first attempt at a fix caused
3380 ;;; doing the same in-core to break.
3381 (with-test (:name :bug-310132)
3382 (compile nil '(lambda (&optional (foo #p"foo/bar")))))
3383
3384 (with-test (:name :bug-309129)
3385 (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v))))
3386 (warningp nil)
3387 (fun (handler-bind ((warning (lambda (c)
3388 (setf warningp t) (muffle-warning c))))
3389 (compile nil src))))
3390 (assert warningp)
3391 (handler-case (funcall fun #(1))
3392 (type-error (c)
3393 ;; we used to put simply VECTOR into EXPECTED-TYPE, rather
3394 ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY))
3395 (assert (not (typep (type-error-datum c) (type-error-expected-type c)))))
3396 (:no-error (&rest values)
3397 (declare (ignore values))
3398 (error "no error")))))
3399
3400 (with-test (:name :unary-round-type-derivation)
3401 (let* ((src '(lambda (zone)
3402 (multiple-value-bind (h m) (truncate (abs zone) 1.0)
3403 (declare (ignore h))
3404 (round (* 60.0 m)))))
3405 (fun (compile nil src)))
3406 (assert (= (funcall fun 0.5) 30))))
3407
3408 (with-test (:name :bug-525949)
3409 (let* ((src '(lambda ()
3410 (labels ((always-one () 1)
3411 (f (z)
3412 (let ((n (funcall z)))
3413 (declare (fixnum n))
3414 (the double-float (expt n 1.0d0)))))
3415 (f #'always-one))))
3416 (warningp nil)
3417 (fun (handler-bind ((warning (lambda (c)
3418 (setf warningp t) (muffle-warning c))))
3419 (compile nil src))))
3420 (assert (not warningp))
3421 (assert (= 1.0d0 (funcall fun)))))
3422
3423 (with-test (:name :%array-data-vector-type-derivation)
3424 (let* ((f (compile nil
3425 `(lambda (ary)
3426 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3427 (setf (aref ary 0 0) 0))))
3428 (text (with-output-to-string (s)
3429 (disassemble f :stream s))))
3430 (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text)))))
3431
3432 (with-test (:name :array-storage-vector-type-derivation)
3433 (let ((f (compile nil
3434 `(lambda (ary)
3435 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3436 (ctu:compiler-derived-type (array-storage-vector ary))))))
3437 (assert (equal '(simple-array (unsigned-byte 32) (9))
3438 (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32)))))))
3439
3440 (with-test (:name :bug-523612)
3441 (let ((fun
3442 (compile nil
3443 `(lambda (&key toff)
3444 (make-array 3 :element-type 'double-float
3445 :initial-contents
3446 (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0)))))))
3447 (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil)))
3448 (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0)))))
3449
3450 (with-test (:name :bug-309788)
3451 (let ((fun
3452 (compile nil
3453 `(lambda (x)
3454 (declare (optimize speed))
3455 (let ((env nil))
3456 (typep x 'fixnum env))))))
3457 (assert (not (ctu:find-named-callees fun)))))
3458
3459 (with-test (:name :bug-309124)
3460 (let ((fun
3461 (compile nil
3462 `(lambda (x)
3463 (declare (integer x))
3464 (declare (optimize speed))
3465 (cond ((typep x 'fixnum)
3466 "hala")
3467 ((typep x 'fixnum)
3468 "buba")
3469 ((typep x 'bignum)
3470 "hip")
3471 (t
3472 "zuz"))))))
3473 (assert (equal (list "hala" "hip")
3474 (sort (ctu:find-code-constants fun :type 'string)
3475 #'string<)))))
3476
3477 (with-test (:name :bug-316078)
3478 (let ((fun
3479 (compile nil
3480 `(lambda (x)
3481 (declare (type (and simple-bit-vector (satisfies bar)) x)
3482 (optimize speed))
3483 (elt x 5)))))
3484 (assert (not (ctu:find-named-callees fun)))
3485 (assert (= 1 (funcall fun #*000001)))
3486 (assert (= 0 (funcall fun #*000010)))))
3487
3488 (with-test (:name :mult-by-one-in-float-acc-zero)
3489 (assert (eql 1.0 (funcall (compile nil `(lambda (x)
3490 (declare (optimize (sb-c::float-accuracy 0)))
3491 (* x 1.0)))
3492 1)))
3493 (assert (eql -1.0 (funcall (compile nil `(lambda (x)
3494 (declare (optimize (sb-c::float-accuracy 0)))
3495 (* x -1.0)))
3496 1)))
3497 (assert (eql 1.0d0 (funcall (compile nil `(lambda (x)
3498 (declare (optimize (sb-c::float-accuracy 0)))
3499 (* x 1.0d0)))
3500 1)))
3501 (assert (eql -1.0d0 (funcall (compile nil `(lambda (x)
3502 (declare (optimize (sb-c::float-accuracy 0)))
3503 (* x -1.0d0)))
3504 1))))
pkhuong's fork