?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Minor improvements in code/timer.lisp
[sbcl.git] / tests / compiler.pure.lisp
blob5df31b0954081dd84b3592739f83b1826764052e
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 (with-test (:name :undefined-function-error)
153 (multiple-value-bind (value error)
154 (ignore-errors (some-undefined-function))
155 (assert (null value))
156 (assert (eq (cell-error-name error) 'some-undefined-function))))
157
158 (with-test (:name :unbound-variable-error)
159 (let ((foo (gensym)))
160 (assert (eq (handler-case (symbol-value foo)
161 (unbound-variable (c) (cell-error-name c)))
162 foo))
163 ;; on x86-64 the code for a literal symbol uses a slightly different path,
164 ;; so test that too
165 (assert (eq (handler-case xyzzy*%state
166 (unbound-variable (c) (cell-error-name c)))
167 'xyzzy*%state))
168 ;; And finally, also on x86-64, there was massive confusion about
169 ;; variable names that looked like names of thread slots.
170 (assert (eq (handler-case *state*
171 (unbound-variable (c) (cell-error-name c)))
172 '*state*))))
173
174 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
175 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
176 (assert (null (ignore-errors (eval '(lambda ("foo") 12)))))
177 (assert (ignore-errors (eval '(lambda (foo) 12))))
178 (assert (null (ignore-errors (eval '(lambda (&optional 12) "foo")))))
179 (assert (ignore-errors (eval '(lambda (&optional twelve) "foo"))))
180 (assert (null (ignore-errors (eval '(lambda (&optional (12 12)) "foo")))))
181 (assert (ignore-errors (eval '(lambda (&optional (twelve 12)) "foo"))))
182 (assert (null (ignore-errors (eval '(lambda (&key #\c) "foo")))))
183 (assert (ignore-errors (eval '(lambda (&key c) "foo"))))
184 (assert (null (ignore-errors (eval '(lambda (&key (#\c #\c)) "foo")))))
185 (assert (ignore-errors (eval '(lambda (&key (c #\c)) "foo"))))
186 (assert (null (ignore-errors (eval '(lambda (&key ((#\c #\c) #\c)) "foo")))))
187 (assert (ignore-errors (eval '(lambda (&key ((:c cbyanyothername) #\c)) "foo"))))
188
189 ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel
190 ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER
191 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
192 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y 3)) x))) 14)
193 17))
194
195 ;;; bug 181: bad type specifier dropped compiler into debugger
196 (assert (list (compile nil '(lambda (x)
197 (declare (type (0) x))
198 x))))
199
200 (let ((f (compile nil '(lambda (x)
201 (make-array 1 :element-type '(0))))))
202 (assert (null (ignore-errors (funcall f)))))
203
204 ;;; the following functions must not be flushable
205 (dolist (form '((make-sequence 'fixnum 10)
206 (concatenate 'fixnum nil)
207 (map 'fixnum #'identity nil)
208 (merge 'fixnum nil nil #'<)))
209 (assert (not (eval `(locally (declare (optimize (safety 0)))
210 (ignore-errors (progn ,form t)))))))
211
212 (dolist (form '((values-list (car (list '(1 . 2))))
213 (fboundp '(set bet))
214 (atan #c(1 1) (car (list #c(2 2))))
215 (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5))
216 (nthcdr (car (list 5)) '(1 2 . 3))))
217 (assert (not (eval `(locally (declare (optimize (safety 3)))
218 (ignore-errors (progn ,form t)))))))
219
220 ;;; feature: we shall complain if functions which are only useful for
221 ;;; their result are called and their result ignored.
222 (with-test (:name :discarded-result)
223 (loop for (form expected-des) in
224 '(((progn (nreverse (list 1 2)) t)
225 "The return value of NREVERSE should not be discarded.")
226 ((progn (nreconc (list 1 2) (list 3 4)) t)
227 "The return value of NRECONC should not be discarded.")
228 ((locally
229 (declare (inline sort))
230 (sort (list 1 2) #'<) t)
231 ;; FIXME: it would be nice if this warned on non-inlined sort
232 ;; but the current simple boolean function attribute
233 ;; can't express the condition that would be required.
234 "The return value of STABLE-SORT-LIST should not be discarded.")
235 ((progn (sort (vector 1 2) #'<) t)
236 ;; Apparently, SBCL (but not CL) guarantees in-place vector
237 ;; sort, so no warning.
238 nil)
239 ((progn (delete 2 (list 1 2)) t)
240 "The return value of DELETE should not be discarded.")
241 ((progn (delete-if #'evenp (list 1 2)) t)
242 ("The return value of DELETE-IF should not be discarded."))
243 ((progn (delete-if #'evenp (vector 1 2)) t)
244 ("The return value of DELETE-IF should not be discarded."))
245 ((progn (delete-if-not #'evenp (list 1 2)) t)
246 "The return value of DELETE-IF-NOT should not be discarded.")
247 ((progn (delete-duplicates (list 1 2)) t)
248 "The return value of DELETE-DUPLICATES should not be discarded.")
249 ((progn (merge 'list (list 1 3) (list 2 4) #'<) t)
250 "The return value of MERGE should not be discarded.")
251 ((progn (nreconc (list 1 3) (list 2 4)) t)
252 "The return value of NRECONC should not be discarded.")
253 ((progn (nunion (list 1 3) (list 2 4)) t)
254 "The return value of NUNION should not be discarded.")
255 ((progn (nintersection (list 1 3) (list 2 4)) t)
256 "The return value of NINTERSECTION should not be discarded.")
257 ((progn (nset-difference (list 1 3) (list 2 4)) t)
258 "The return value of NSET-DIFFERENCE should not be discarded.")
259 ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t)
260 "The return value of NSET-EXCLUSIVE-OR should not be discarded."))
261 for expected = (sb-int:ensure-list expected-des)
262 do
263 (multiple-value-bind (fun warnings-p failure-p)
264 (handler-bind ((style-warning (lambda (c)
265 (if expected
266 (let ((expect-one (pop expected)))
267 (assert (search expect-one
268 (with-standard-io-syntax
269 (let ((*print-right-margin* nil))
270 (princ-to-string c))))
271 ()
272 "~S should have warned ~S, but instead warned: ~A"
273 form expect-one c))
274 (error "~S shouldn't give a(nother) warning, but did: ~A" form c)))))
275 (compile nil `(lambda () ,form)))
276 (declare (ignore warnings-p))
277 (assert (functionp fun))
278 (assert (null expected)
279 ()
280 "~S should have warned ~S, but didn't."
281 form expected)
282 (assert (not failure-p)))))
283
284 ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers
285 ;;; to cause errors in the compiler. Fixed by CSR in 0.7.8.10
286 (assert (list (compile nil '(lambda (x) (map 'simple-array 'identity x)))))
287
288 ;;; bug 129: insufficient syntax checking in MACROLET
289 (multiple-value-bind (result error)
290 (ignore-errors (eval '(macrolet ((foo x `',x)) (foo 1 2 3))))
291 (assert (null result))
292 (assert (typep error 'error)))
293
294 ;;; bug 124: environment of MACROLET-introduced macro expanders
295 (assert (equal
296 (macrolet ((mext (x) `(cons :mext ,x)))
297 (macrolet ((mint (y) `'(:mint ,(mext y))))
298 (list (mext '(1 2))
299 (mint (1 2)))))
300 '((:MEXT 1 2) (:MINT (:MEXT 1 2)))))
301
302 ;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced
303 ;;; symbol is declared to be SPECIAL
304 (multiple-value-bind (result error)
305 (ignore-errors (funcall (lambda ()
306 (symbol-macrolet ((s '(1 2)))
307 (declare (special s))
308 s))))
309 (assert (null result))
310 (assert (typep error 'program-error)))
311
312 ;;; ECASE should treat a bare T as a literal key
313 (multiple-value-bind (result error)
314 (ignore-errors (ecase 1 (t 0)))
315 (assert (null result))
316 (assert (typep error 'type-error)))
317
318 (multiple-value-bind (result error)
319 (ignore-errors (ecase 1 (t 0) (1 2)))
320 (assert (eql result 2))
321 (assert (null error)))
322
323 ;;; FTYPE should accept any functional type specifier
324 (compile nil '(lambda (x) (declare (ftype function f)) (f x)))
325
326 ;;; FUNCALL of special operators and macros should signal an
327 ;;; UNDEFINED-FUNCTION error
328 (multiple-value-bind (result error)
329 (ignore-errors (funcall 'quote 1))
330 (assert (null result))
331 (assert (typep error 'undefined-function))
332 (assert (eq (cell-error-name error) 'quote)))
333 (multiple-value-bind (result error)
334 (ignore-errors (funcall 'and 1))
335 (assert (null result))
336 (assert (typep error 'undefined-function))
337 (assert (eq (cell-error-name error) 'and)))
338
339 ;;; PSETQ should behave when given complex symbol-macro arguments
340 (multiple-value-bind (sequence index)
341 (symbol-macrolet ((x (aref a (incf i)))
342 (y (aref a (incf i))))
343 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
344 (i 0))
345 (psetq x (aref a (incf i))
346 y (aref a (incf i)))
347 (values a i)))
348 (assert (equalp sequence #(0 2 2 4 4 5 6 7 8 9)))
349 (assert (= index 4)))
350
351 (multiple-value-bind (result error)
352 (ignore-errors
353 (let ((x (list 1 2)))
354 (psetq (car x) 3)
355 x))
356 (assert (null result))
357 (assert (typep error 'program-error)))
358
359 ;;; COPY-SEQ should work on known-complex vectors:
360 (assert (equalp #(1)
361 (let ((v (make-array 0 :fill-pointer 0)))
362 (vector-push-extend 1 v)
363 (copy-seq v))))
364
365 ;;; to support INLINE functions inside MACROLET, it is necessary for
366 ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in
367 ;;; certain circumstances, one of which is when compile is called from
368 ;;; top-level.
369 (assert (equal
370 (function-lambda-expression
371 (compile nil '(lambda (x) (block nil (print x)))))
372 '(lambda (x) (block nil (print x)))))
373
374 ;;; bug 62: too cautious type inference in a loop
375 (assert (nth-value
376 2
377 (compile nil
378 '(lambda (a)
379 (declare (optimize speed (safety 0)))
380 (typecase a
381 (array (loop (print (car a)))))))))
382
383 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
384 ;;; failure
385 (compile nil
386 '(lambda (key tree collect-path-p)
387 (let ((lessp (key-lessp tree))
388 (equalp (key-equalp tree)))
389 (declare (type (function (t t) boolean) lessp equalp))
390 (let ((path '(nil)))
391 (loop for node = (root-node tree)
392 then (if (funcall lessp key (node-key node))
393 (left-child node)
394 (right-child node))
395 when (null node)
396 do (return (values nil nil nil))
397 do (when collect-path-p
398 (push node path))
399 (when (funcall equalp key (node-key node))
400 (return (values node path t))))))))
401
402 ;;; CONSTANTLY should return a side-effect-free function (bug caught
403 ;;; by Paul Dietz' test suite)
404 (let ((i 0))
405 (let ((fn (constantly (progn (incf i) 1))))
406 (assert (= i 1))
407 (assert (= (funcall fn) 1))
408 (assert (= i 1))
409 (assert (= (funcall fn) 1))
410 (assert (= i 1))))
411
412 ;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version)
413 (loop for (fun warns-p) in
414 '(((lambda (&optional *x*) *x*) t)
415 ((lambda (&optional *x* &rest y) (values *x* y)) t)
416 ((lambda (&optional *print-length*) (values *print-length*)) nil)
417 ((lambda (&optional *print-length* &rest y) (values *print-length* y)) nil)
418 ((lambda (&optional *x*) (declare (special *x*)) (values *x*)) nil)
419 ((lambda (&optional *x* &rest y) (declare (special *x*)) (values *x* y)) nil))
420 for real-warns-p = (nth-value 1 (compile nil fun))
421 do (assert (eq warns-p real-warns-p)))
422
423 ;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26
424 (assert (equal (funcall (eval '(lambda (x &optional (y (pop x))) (list x y)))
425 '(1 2))
426 '((2) 1)))
427
428 ;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd
429 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
430 (assert (eq (eval '((lambda (&key) 'u) :allow-other-keys nil)) 'u))
431
432 (assert-error (multiple-value-bind (a b c)
433 (eval '(truncate 3 4))
434 (declare (integer c))
435 (list a b c))
436 type-error)
437
438 (assert (equal (multiple-value-list (the (values &rest integer)
439 (eval '(values 3))))
440 '(3)))
441
442 ;;; Bug relating to confused representation for the wild function
443 ;;; type:
444 (assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
445
446 ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz'
447 ;;; test suite)
448 (assert (eql (macrolet ((foo () 1))
449 (macrolet ((%f (&optional (x (macroexpand '(foo) env)) &environment env)
450 x))
451 (%f)))
452 1))
453
454 ;;; MACROLET should check for duplicated names
455 (dolist (ll '((x (z x))
456 (x y &optional z x w)
457 (x y &optional z z)
458 (x &rest x)
459 (x &rest (y x))
460 (x &optional (y nil x))
461 (x &optional (y nil y))
462 (x &key x)
463 (x &key (y nil x))
464 (&key (y nil z) (z nil w))
465 (&whole x &optional x)
466 ;; Uh, this test is semi-bogus - it's trying to test that
467 ;; you can't repeat, but it's now actually testing that
468 ;; &WHOLE has to appear first, per the formal spec.
469 (&environment x &whole x)))
470 (assert (nth-value 2
471 (handler-case
472 (compile nil
473 `(lambda ()
474 (macrolet ((foo ,ll nil)
475 (bar (&environment env)
476 `',(macro-function 'foo env)))
477 (bar))))
478 ((or warning error) (c)
479 (declare (ignore c))
480 (values nil t t))))))
481
482 (assert (typep (eval `(the arithmetic-error
483 ',(make-condition 'arithmetic-error)))
484 'arithmetic-error))
485
486 (assert (not (nth-value
487 2 (compile nil '(lambda ()
488 (make-array nil :initial-element 11))))))
489
490 (assert-error (funcall (eval #'open) "assertoid.lisp"
491 :external-format '#:nonsense))
492 (assert-error (funcall (eval #'load) "assertoid.lisp"
493 :external-format '#:nonsense))
494
495 (assert (= (the (values integer symbol) (values 1 'foo 13)) 1))
496
497 (let ((f (compile nil
498 '(lambda (v)
499 (declare (optimize (safety 3)))
500 (list (the fixnum (the (real 0) (eval v))))))))
501 (assert-error (funcall f 0.1) type-error)
502 (assert-error (funcall f -1) type-error))
503
504 ;;; the implicit block does not enclose lambda list
505 (let ((forms '((defmacro #1=#:foo (&optional (x (return-from #1#))))
506 #+nil(macrolet ((#2=#:foo (&optional (x (return-from #2#))))))
507 (define-compiler-macro #3=#:foo (&optional (x (return-from #3#))))
508 (deftype #4=#:foo (&optional (x (return-from #4#))))
509 (define-setf-expander #5=#:foo (&optional (x (return-from #5#))))
510 (defsetf #6=#:foo (&optional (x (return-from #6#))) ()))))
511 (dolist (form forms)
512 (assert (nth-value 2 (compile nil `(lambda () ,form))))))
513
514 (assert (nth-value 2 (compile nil
515 '(lambda ()
516 (svref (make-array '(8 9) :adjustable t) 1)))))
517
518 ;;; CHAR= did not check types of its arguments (reported by Adam Warner)
519 (assert-error (funcall (compile nil '(lambda (x y z) (char= x y z)))
520 #\a #\b nil)
521 type-error)
522 (assert-error (funcall (compile nil
523 '(lambda (x y z)
524 (declare (optimize (speed 3) (safety 3)))
525 (char/= x y z)))
526 nil #\a #\a)
527 type-error)
528
529 ;;; Compiler lost return type of MAPCAR and friends
530 (dolist (fun '(mapcar mapc maplist mapl))
531 (assert (nth-value 2 (compile nil
532 `(lambda (x)
533 (1+ (,fun #'print x)))))))
534
535 (assert (nth-value 2 (compile nil
536 '(lambda ()
537 (declare (notinline mapcar))
538 (1+ (mapcar #'print '(1 2 3)))))))
539
540 ;;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant
541 ;;; index was effectless
542 (let ((f (compile nil '(lambda (a v)
543 (declare (type simple-bit-vector a) (type bit v))
544 (declare (optimize (speed 3) (safety 0)))
545 (setf (aref a 0) v)
546 a))))
547 (let ((y (make-array 2 :element-type 'bit :initial-element 0)))
548 (assert (equal y #*00))
549 (funcall f y 1)
550 (assert (equal y #*10))))
551
552 ;;; use of declared array types
553 (handler-bind ((sb-ext:compiler-note #'error))
554 (compile nil '(lambda (x)
555 (declare (type (simple-array (simple-string 3) (5)) x)
556 (optimize speed))
557 (aref (aref x 0) 0))))
558
559 (handler-bind ((sb-ext:compiler-note #'error))
560 (compile nil '(lambda (x)
561 (declare (type (simple-array (simple-array bit (10)) (10)) x)
562 (optimize speed))
563 (1+ (aref (aref x 0) 0)))))
564
565 ;;; compiler failure
566 (let ((f (compile nil '(lambda (x) (typep x '(not (member 0d0)))))))
567 (assert (funcall f 1d0)))
568
569 (compile nil '(lambda (x)
570 (declare (double-float x))
571 (let ((y (* x pi)))
572 (atan y y))))
573
574 ;;; bogus optimization of BIT-NOT
575 (multiple-value-bind (result x)
576 (eval '(let ((x (eval #*1001)))
577 (declare (optimize (speed 2) (space 3))
578 (type (bit-vector) x))
579 (values (bit-not x nil) x)))
580 (assert (equal x #*1001))
581 (assert (equal result #*0110)))
582
583 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
584 (handler-bind ((sb-ext:compiler-note #'error))
585 (assert (equalp (funcall
586 (compile
587 nil
588 '(lambda ()
589 (let ((x (make-sequence 'vector 10 :initial-element 'a)))
590 (setf (aref x 4) 'b)
591 x))))
592 #(a a a a b a a a a a))))
593
594 ;;; this is not a check for a bug, but rather a test of compiler
595 ;;; quality
596 (dolist (type '((integer 0 *) ; upper bound
597 (real (-1) *)
598 float ; class
599 (real * (-10)) ; lower bound
600 ))
601 (assert (nth-value
602 1 (compile nil
603 `(lambda (n)
604 (declare (optimize (speed 3) (compilation-speed 0)))
605 (loop for i from 1 to (the (integer -17 10) n) by 2
606 collect (when (> (random 10) 5)
607 (the ,type (- i 11)))))))))
608
609 ;;; bug 278b
610 ;;;
611 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
612 ;;; compiler has an optimized VOP for +; so this code should cause an
613 ;;; efficiency note.
614 (assert (eq (block nil
615 (handler-case
616 (compile nil '(lambda (i)
617 (declare (optimize speed))
618 (declare (type integer i))
619 (+ i 2)))
620 (sb-ext:compiler-note (c) (return :good))))
621 :good))
622
623 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
624 ;;; symbol macros
625 (assert (not (nth-value 1 (compile nil '(lambda (u v)
626 (symbol-macrolet ((x u)
627 (y v))
628 (declare (ignore x)
629 (ignorable y))
630 (list u v)))))))
631
632 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
633 (loop for (x type) in
634 '((14 integer)
635 (14 rational)
636 (-14/3 (rational -8 11))
637 (3s0 short-float)
638 (4f0 single-float)
639 (5d0 double-float)
640 (6l0 long-float)
641 (14 real)
642 (13/2 real)
643 (2s0 real)
644 (2d0 real)
645 (#c(-3 4) (complex fixnum))
646 (#c(-3 4) (complex rational))
647 (#c(-3/7 4) (complex rational))
648 (#c(2s0 3s0) (complex short-float))
649 (#c(2f0 3f0) (complex single-float))
650 (#c(2d0 3d0) (complex double-float))
651 (#c(2l0 3l0) (complex long-float))
652 (#c(2d0 3s0) (complex float))
653 (#c(2 3f0) (complex real))
654 (#c(2 3d0) (complex real))
655 (#c(-3/7 4) (complex real))
656 (#c(-3/7 4) complex)
657 (#c(2 3l0) complex))
658 do (dolist (zero '(0 0s0 0f0 0d0 0l0))
659 (dolist (real-zero (list zero (- zero)))
660 (let* ((src `(lambda (x) (expt (the ,type x) ,real-zero)))
661 (fun (compile nil src))
662 (result (1+ (funcall (eval #'*) x real-zero))))
663 (assert (eql result (funcall fun x)))))))
664
665 ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
666 ;;; wasn't recognized as a good type specifier.
667 (let ((fun (lambda (x y)
668 (declare (type (integer -1 0) x y) (optimize speed))
669 (logxor x y))))
670 (assert (= (funcall fun 0 0) 0))
671 (assert (= (funcall fun 0 -1) -1))
672 (assert (= (funcall fun -1 -1) 0)))
673
674 ;;; from PFD's torture test, triggering a bug in our effective address
675 ;;; treatment.
676 (compile
677 nil
678 `(lambda (a b)
679 (declare (type (integer 8 22337) b))
680 (logandc2
681 (logandc2
682 (* (logandc1 (max -29303 b) 4) b)
683 (abs (logorc1 (+ (logandc1 -11 b) 2607688420) -31153924)))
684 (logeqv (max a 0) b))))
685
686 ;;; Alpha floating point modes weren't being reset after an exception,
687 ;;; leading to an exception on the second compile, below.
688 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
689 (handler-case (/ 1.0 0.0)
690 ;; provoke an exception
691 (arithmetic-error ()))
692 (compile nil '(lambda (x y) (declare (type (double-float 0.0d0) x y)) (/ x y)))
693
694 ;;; bug reported by Paul Dietz: component last block does not have
695 ;;; start ctran
696 (compile nil
697 '(lambda ()
698 (declare (notinline + logand)
699 (optimize (speed 0)))
700 (LOGAND
701 (BLOCK B5
702 (FLET ((%F1 ()
703 (RETURN-FROM B5 -220)))
704 (LET ((V7 (%F1)))
705 (+ 359749 35728422))))
706 -24076)))
707
708 (with-test (:name :ansi-misc.293a)
709 (assert (= (funcall
710 (compile
711 nil
712 '(lambda (a b c)
713 (declare (optimize (speed 2) (space 3) (safety 1)
714 (debug 2) (compilation-speed 2)))
715 (block b6
716 (multiple-value-prog1
717 0 b 0
718 (catch 'ct7
719 (return-from b6
720 (catch 'ct2
721 (complex (cl::handler-bind nil -254932942) 0))))))))
722 1 2 3)
723 -254932942)))
724
725 (with-test (:name :ansi-misc.293d)
726 (assert (= (funcall
727 (compile
728 nil
729 '(lambda ()
730 (declare (optimize (debug 3) (safety 0) (space 2)
731 (compilation-speed 2) (speed 2)))
732 (block b4
733 (multiple-value-prog1
734 0
735 (catch 'ct8
736 (return-from b4 (catch 'ct2 (progn (tagbody) 0)))))))))
737 0)))
738
739 (with-test (:name :ansi-misc.618)
740 (assert (= (funcall
741 (compile
742 nil
743 '(lambda (c)
744 (declare (optimize (space 0) (compilation-speed 2) (debug 0)
745 (speed 3) (safety 0)))
746 (block b1
747 (ignore-errors
748 (multiple-value-prog1 0
749 (apply (constantly 0)
750 c
751 (catch 'ct2 (return-from b1 0))
752 nil))))))
753 -4951)
754 0)))
755
756 ;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
757 (assert (= (funcall (compile nil `(lambda (b)
758 (declare (optimize (speed 3))
759 (type (integer 2 152044363) b))
760 (rem b (min -16 0))))
761 108251912)
762 8))
763
764 (assert (= (funcall (compile nil `(lambda (c)
765 (declare (optimize (speed 3))
766 (type (integer 23062188 149459656) c))
767 (mod c (min -2 0))))
768 95019853)
769 -1))
770
771 ;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
772 (compile nil
773 '(LAMBDA (A B C)
774 (BLOCK B6
775 (LOGEQV (REM C -6758)
776 (REM B (MAX 44 (RETURN-FROM B6 A)))))))
777
778 (compile nil '(lambda ()
779 (block nil
780 (flet ((foo (x y) (if (> x y) (print x) (print y))))
781 (foo 1 2)
782 (bar)
783 (foo (return 14) 2)))))
784
785 ;;; bug in Alpha backend: not enough sanity checking of arguments to
786 ;;; instructions
787 (assert (= (funcall (compile nil
788 '(lambda (x)
789 (declare (fixnum x))
790 (ash x -257)))
791 1024)
792 0))
793
794 ;;; bug found by WHN and pfdietz: compiler failure while referencing
795 ;;; an entry point inside a deleted lambda
796 (compile nil '(lambda ()
797 (let (r3533)
798 (flet ((bbfn ()
799 (setf r3533
800 (progn
801 (flet ((truly (fn bbd)
802 (let (r3534)
803 (let ((p3537 nil))
804 (unwind-protect
805 (multiple-value-prog1
806 (progn
807 (setf r3534
808 (progn
809 (bubf bbd t)
810 (flet ((c-3536 ()
811 (funcall fn)))
812 (cdec #'c-3536
813 (vector bbd))))))
814 (setf p3537 t))
815 (unless p3537
816 (error "j"))))
817 r3534))
818 (c (pd) (pdc pd)))
819 (let ((a (smock a))
820 (b (smock b))
821 (b (smock c)))))))))
822 (wum #'bbfn "hc3" (list)))
823 r3533)))
824 (compile nil '(lambda () (flet ((%f () (unwind-protect nil))) nil)))
825
826 ;;; the strength reduction of constant multiplication used (before
827 ;;; sbcl-0.8.4.x) to lie to the compiler. This meant that, under
828 ;;; certain circumstances, the compiler would derive that a perfectly
829 ;;; reasonable multiplication never returned, causing chaos. Fixed by
830 ;;; explicitly doing modular arithmetic, and relying on the backends
831 ;;; being smart.
832 (assert (= (funcall
833 (compile nil
834 '(lambda (x)
835 (declare (type (integer 178956970 178956970) x)
836 (optimize speed))
837 (* x 24)))
838 178956970)
839 4294967280))
840
841 ;;; bug in modular arithmetic and type specifiers
842 (assert (= (funcall (compile nil '(lambda (x) (logand x x 0)))
843 -1)
844 0))
845
846 ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP
847 ;;; produced wrong result for shift >=32 on X86
848 (assert (= 0 (funcall
849 (compile nil
850 '(lambda (a)
851 (declare (type (integer 4303063 101130078) a))
852 (mask-field (byte 18 2) (ash a 77))))
853 57132532)))
854 ;;; rewrite the test case to get the unsigned-byte 32/64
855 ;;; implementation even after implementing some modular arithmetic
856 ;;; with signed-byte 30:
857 (assert (= 0 (funcall
858 (compile nil
859 '(lambda (a)
860 (declare (type (integer 4303063 101130078) a))
861 (mask-field (byte 30 2) (ash a 77))))
862 57132532)))
863 (assert (= 0 (funcall
864 (compile nil
865 '(lambda (a)
866 (declare (type (integer 4303063 101130078) a))
867 (mask-field (byte 64 2) (ash a 77))))
868 57132532)))
869 ;;; and a similar test case for the signed masking extension (not the
870 ;;; final interface, so change the call when necessary):
871 (assert (= 0 (funcall
872 (compile nil
873 '(lambda (a)
874 (declare (type (integer 4303063 101130078) a))
875 (sb-c::mask-signed-field 30 (ash a 77))))
876 57132532)))
877 (assert (= 0 (funcall
878 (compile nil
879 '(lambda (a)
880 (declare (type (integer 4303063 101130078) a))
881 (sb-c::mask-signed-field 61 (ash a 77))))
882 57132532)))
883
884 ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
885 ;;; type check regeneration
886 (assert (eql (funcall
887 (compile nil '(lambda (a c)
888 (declare (type (integer 185501219873 303014665162) a))
889 (declare (type (integer -160758 255724) c))
890 (declare (optimize (speed 3)))
891 (let ((v8
892 (- -554046873252388011622614991634432
893 (ignore-errors c)
894 (unwind-protect 2791485))))
895 (max (ignore-errors a)
896 (let ((v6 (- v8 (restart-case 980))))
897 (min v8 v6))))))
898 259448422916 173715)
899 259448422916))
900 (assert (eql (funcall
901 (compile nil '(lambda (a b)
902 (min -80
903 (abs
904 (ignore-errors
905 (+
906 (logeqv b
907 (block b6
908 (return-from b6
909 (load-time-value -6876935))))
910 (if (logbitp 1 a) b (setq a -1522022182249))))))))
911 -1802767029877 -12374959963)
912 -80))
913
914 ;;; various MISC.*, related to NODEs/LVARs with derived type NIL
915 (assert (eql (funcall (compile nil '(lambda (c)
916 (declare (type (integer -3924 1001809828) c))
917 (declare (optimize (speed 3)))
918 (min 47 (if (ldb-test (byte 2 14) c)
919 -570344431
920 (ignore-errors -732893970)))))
921 705347625)
922 -570344431))
923 (assert (eql (funcall
924 (compile nil '(lambda (b)
925 (declare (type (integer -1598566306 2941) b))
926 (declare (optimize (speed 3)))
927 (max -148949 (ignore-errors b))))
928 0)
929 0))
930 (assert (eql (funcall
931 (compile nil '(lambda (b c)
932 (declare (type (integer -4 -3) c))
933 (block b7
934 (flet ((%f1 (f1-1 f1-2 f1-3)
935 (if (logbitp 0 (return-from b7
936 (- -815145138 f1-2)))
937 (return-from b7 -2611670)
938 99345)))
939 (let ((v2 (%f1 -2464 (%f1 -1146 c c) -2)))
940 b)))))
941 2950453607 -4)
942 -815145134))
943 (assert (eql (funcall
944 (compile nil
945 '(lambda (b c)
946 (declare (type (integer -29742055786 23602182204) b))
947 (declare (type (integer -7409 -2075) c))
948 (declare (optimize (speed 3)))
949 (floor
950 (labels ((%f2 ()
951 (block b6
952 (ignore-errors (return-from b6
953 (if (= c 8) b 82674))))))
954 (%f2)))))
955 22992834060 -5833)
956 82674))
957 (assert (equal (multiple-value-list
958 (funcall
959 (compile nil '(lambda (a)
960 (declare (type (integer -944 -472) a))
961 (declare (optimize (speed 3)))
962 (round
963 (block b3
964 (return-from b3
965 (if (= 55957 a) -117 (ignore-errors
966 (return-from b3 a))))))))
967 -589))
968 '(-589 0)))
969
970 ;;; MISC.158
971 (assert (zerop (funcall
972 (compile nil
973 '(lambda (a b c)
974 (declare (type (integer 79828 2625480458) a))
975 (declare (type (integer -4363283 8171697) b))
976 (declare (type (integer -301 0) c))
977 (if (equal 6392154 (logxor a b))
978 1706
979 (let ((v5 (abs c)))
980 (logand v5
981 (logior (logandc2 c v5)
982 (common-lisp:handler-case
983 (ash a (min 36 22477)))))))))
984 100000 0 0)))
985
986 ;;; MISC.152, 153: deleted code and iteration var type inference
987 (assert (eql (funcall
988 (compile nil
989 '(lambda (a)
990 (block b5
991 (let ((v1 (let ((v8 (unwind-protect 9365)))
992 8862008)))
993 (*
994 (return-from b5
995 (labels ((%f11 (f11-1) f11-1))
996 (%f11 87246015)))
997 (return-from b5
998 (setq v1
999 (labels ((%f6 (f6-1 f6-2 f6-3) v1))
1000 (dpb (unwind-protect a)
1001 (byte 18 13)
1002 (labels ((%f4 () 27322826))
1003 (%f6 -2 -108626545 (%f4))))))))))))
1004 -6)
1005 87246015))
1006
1007 (assert (eql (funcall
1008 (compile nil
1009 '(lambda (a)
1010 (if (logbitp 3
1011 (case -2
1012 ((-96879 -1035 -57680 -106404 -94516 -125088)
1013 (unwind-protect 90309179))
1014 ((-20811 -86901 -9368 -98520 -71594)
1015 (let ((v9 (unwind-protect 136707)))
1016 (block b3
1017 (setq v9
1018 (let ((v4 (return-from b3 v9)))
1019 (- (ignore-errors (return-from b3 v4))))))))
1020 (t -50)))
1021 -20343
1022 a)))
1023 0)
1024 -20343))
1025
1026 ;;; MISC.165
1027 (assert (eql (funcall
1028 (compile
1029 nil
1030 '(lambda (a b c)
1031 (block b3
1032 (flet ((%f15
1033 (f15-1 f15-2 f15-3
1034 &optional
1035 (f15-4
1036 (flet ((%f17
1037 (f17-1 f17-2 f17-3
1038 &optional (f17-4 185155520) (f17-5 c)
1039 (f17-6 37))
1040 c))
1041 (%f17 -1046 a 1115306 (%f17 b -146330 422) -337817)))
1042 (f15-5 a) (f15-6 -40))
1043 (return-from b3 -16)))
1044 (multiple-value-call #'%f15 (values -519354 a 121 c -1905))))))
1045 0 0 -5)
1046 -16))
1047
1048 ;;; MISC.172
1049 (assert (eql (funcall
1050 (compile
1051 nil
1052 '(lambda (a b c)
1053 (declare (notinline list apply))
1054 (declare (optimize (safety 3)))
1055 (declare (optimize (speed 0)))
1056 (declare (optimize (debug 0)))
1057 (labels ((%f12 (f12-1 f12-2)
1058 (labels ((%f2 (f2-1 f2-2)
1059 (flet ((%f6 ()
1060 (flet ((%f18
1061 (f18-1
1062 &optional (f18-2 a)
1063 (f18-3 -207465075)
1064 (f18-4 a))
1065 (return-from %f12 b)))
1066 (%f18 -3489553
1067 -7
1068 (%f18 (%f18 150 -64 f12-1)
1069 (%f18 (%f18 -8531)
1070 11410)
1071 b)
1072 56362666))))
1073 (labels ((%f7
1074 (f7-1 f7-2
1075 &optional (f7-3 (%f6)))
1076 7767415))
1077 f12-1))))
1078 (%f2 b -36582571))))
1079 (apply #'%f12 (list 774 -4413)))))
1080 0 1 2)
1081 774))
1082
1083 ;;; MISC.173
1084 (assert (eql (funcall
1085 (compile
1086 nil
1087 '(lambda (a b c)
1088 (declare (notinline values))
1089 (declare (optimize (safety 3)))
1090 (declare (optimize (speed 0)))
1091 (declare (optimize (debug 0)))
1092 (flet ((%f11
1093 (f11-1 f11-2
1094 &optional (f11-3 c) (f11-4 7947114)
1095 (f11-5
1096 (flet ((%f3 (f3-1 &optional (f3-2 b) (f3-3 5529))
1097 8134))
1098 (multiple-value-call #'%f3
1099 (values (%f3 -30637724 b) c)))))
1100 (setq c 555910)))
1101 (if (and nil (%f11 a a))
1102 (if (%f11 a 421778 4030 1)
1103 (labels ((%f7
1104 (f7-1 f7-2
1105 &optional
1106 (f7-3
1107 (%f11 -79192293
1108 (%f11 c a c -4 214720)
1109 b
1110 b
1111 (%f11 b 985)))
1112 (f7-4 a))
1113 b))
1114 (%f11 c b -25644))
1115 54)
1116 -32326608))))
1117 1 2 3)
1118 -32326608))
1119
1120 ;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
1121 ;;; local lambda argument
1122 (assert
1123 (equal
1124 (funcall
1125 (compile nil
1126 '(lambda (a b c)
1127 (declare (type (integer 804561 7640697) a))
1128 (declare (type (integer -1 10441401) b))
1129 (declare (type (integer -864634669 55189745) c))
1130 (declare (ignorable a b c))
1131 (declare (optimize (speed 3)))
1132 (declare (optimize (safety 1)))
1133 (declare (optimize (debug 1)))
1134 (flet ((%f11
1135 (f11-1 f11-2)
1136 (labels ((%f4 () (round 200048 (max 99 c))))
1137 (logand
1138 f11-1
1139 (labels ((%f3 (f3-1) -162967612))
1140 (%f3 (let* ((v8 (%f4)))
1141 (setq f11-1 (%f4)))))))))
1142 (%f11 -120429363 (%f11 62362 b)))))
1143 6714367 9645616 -637681868)
1144 -264223548))
1145
1146 ;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
1147 ;;; transform
1148 (assert (equal (multiple-value-list
1149 (funcall
1150 (compile nil '(lambda ()
1151 (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
1152 (ceiling
1153 (ceiling
1154 (flet ((%f16 () 0)) (%f16))))))))
1155 '(0 0)))
1156
1157 ;;; MISC.184
1158 (assert (zerop
1159 (funcall
1160 (compile
1161 nil
1162 '(lambda (a b c)
1163 (declare (type (integer 867934833 3293695878) a))
1164 (declare (type (integer -82111 1776797) b))
1165 (declare (type (integer -1432413516 54121964) c))
1166 (declare (optimize (speed 3)))
1167 (declare (optimize (safety 1)))
1168 (declare (optimize (debug 1)))
1169 (if nil
1170 (flet ((%f15 (f15-1 &optional (f15-2 c))
1171 (labels ((%f1 (f1-1 f1-2) 0))
1172 (%f1 a 0))))
1173 (flet ((%f4 ()
1174 (multiple-value-call #'%f15
1175 (values (%f15 c 0) (%f15 0)))))
1176 (if nil (%f4)
1177 (flet ((%f8 (f8-1 &optional (f8-2 (%f4)) (f8-3 0))
1178 f8-3))
1179 0))))
1180 0)))
1181 3040851270 1664281 -1340106197)))
1182
1183 ;;; MISC.249
1184 (assert (zerop
1185 (funcall
1186 (compile
1187 nil
1188 '(lambda (a b)
1189 (declare (notinline <=))
1190 (declare (optimize (speed 2) (space 3) (safety 0)
1191 (debug 1) (compilation-speed 3)))
1192 (if (if (<= 0) nil nil)
1193 (labels ((%f9 (f9-1 f9-2 f9-3)
1194 (ignore-errors 0)))
1195 (dotimes (iv4 5 a) (%f9 0 0 b)))
1196 0)))
1197 1 2)))
1198
1199 ;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
1200 (assert
1201 (= (funcall
1202 (compile
1203 nil
1204 '(lambda (a)
1205 (declare (type (integer 177547470 226026978) a))
1206 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
1207 (compilation-speed 1)))
1208 (logand a (* a 438810))))
1209 215067723)
1210 13739018))
1211
1212 \f
1213 ;;;; Bugs in stack analysis
1214 ;;; bug 299 (reported by PFD)
1215 (assert
1216 (equal (funcall
1217 (compile
1218 nil
1219 '(lambda ()
1220 (declare (optimize (debug 1)))
1221 (multiple-value-call #'list
1222 (if (eval t) (eval '(values :a :b :c)) nil)
1223 (catch 'foo (throw 'foo (values :x :y)))))))
1224 '(:a :b :c :x :y)))
1225 ;;; bug 298 (= MISC.183)
1226 (assert (zerop (funcall
1227 (compile
1228 nil
1229 '(lambda (a b c)
1230 (declare (type (integer -368154 377964) a))
1231 (declare (type (integer 5044 14959) b))
1232 (declare (type (integer -184859815 -8066427) c))
1233 (declare (ignorable a b c))
1234 (declare (optimize (speed 3)))
1235 (declare (optimize (safety 1)))
1236 (declare (optimize (debug 1)))
1237 (block b7
1238 (flet ((%f3 (f3-1 f3-2 f3-3) 0))
1239 (apply #'%f3 0 (catch 'foo (return-from b7 (%f3 0 b c))) c nil)))))
1240 0 6000 -9000000)))
1241 (assert (equal (eval '(let () (apply #'list 1 (list (catch 'a (throw 'a (block b 2)))))))
1242 '(1 2)))
1243 (let ((f (compile
1244 nil
1245 '(lambda (x)
1246 (block foo
1247 (multiple-value-call #'list
1248 :a
1249 (block bar
1250 (return-from foo
1251 (multiple-value-call #'list
1252 :b
1253 (block quux
1254 (return-from bar
1255 (catch 'baz
1256 (if x
1257 (return-from quux 1)
1258 (throw 'baz 2))))))))))))))
1259 (assert (equal (funcall f t) '(:b 1)))
1260 (assert (equal (funcall f nil) '(:a 2))))
1261
1262 ;;; MISC.185
1263 (assert (equal
1264 (funcall
1265 (compile
1266 nil
1267 '(lambda (a b c)
1268 (declare (type (integer 5 155656586618) a))
1269 (declare (type (integer -15492 196529) b))
1270 (declare (type (integer 7 10) c))
1271 (declare (optimize (speed 3)))
1272 (declare (optimize (safety 1)))
1273 (declare (optimize (debug 1)))
1274 (flet ((%f3
1275 (f3-1 f3-2 f3-3
1276 &optional (f3-4 a) (f3-5 0)
1277 (f3-6
1278 (labels ((%f10 (f10-1 f10-2 f10-3)
1279 0))
1280 (apply #'%f10
1281 0
1282 a
1283 (- (if (equal a b) b (%f10 c a 0))
1284 (catch 'ct2 (throw 'ct2 c)))
1285 nil))))
1286 0))
1287 (%f3 (%f3 (%f3 b 0 0 0) a 0) a b b b c)))) 5 0 7)
1288 0))
1289 ;;; MISC.186
1290 (assert (eq
1291 (eval
1292 '(let* ((form '(labels ((%f3 (f3-1 f3-2) f3-1))
1293 (apply #'%f3 b (catch 'ct8 (throw 'ct8 (logeqv (%f3 c 0)))) nil)))
1294 (vars '(b c))
1295 (fn1 `(lambda ,vars
1296 (declare (type (integer -2 19) b)
1297 (type (integer -1520 218978) c)
1298 (optimize (speed 3) (safety 1) (debug 1)))
1299 ,form))
1300 (fn2 `(lambda ,vars
1301 (declare (notinline logeqv apply)
1302 (optimize (safety 3) (speed 0) (debug 0)))
1303 ,form))
1304 (cf1 (compile nil fn1))
1305 (cf2 (compile nil fn2))
1306 (result1 (multiple-value-list (funcall cf1 2 18886)))
1307 (result2 (multiple-value-list (funcall cf2 2 18886))))
1308 (if (equal result1 result2)
1309 :good
1310 (values result1 result2))))
1311 :good))
1312
1313 ;;; MISC.290
1314 (assert (zerop
1315 (funcall
1316 (compile
1317 nil
1318 '(lambda ()
1319 (declare
1320 (optimize (speed 3) (space 3) (safety 1)
1321 (debug 2) (compilation-speed 0)))
1322 (apply (constantly 0) (catch 'ct2 0) 0 (catch 'ct2 0) nil))))))
1323
1324 ;;; MISC.292
1325 (assert (zerop (funcall
1326 (compile
1327 nil
1328 '(lambda (a b)
1329 (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
1330 (compilation-speed 2)))
1331 (apply (constantly 0)
1332 a
1333 0
1334 (catch 'ct6
1335 (apply (constantly 0)
1336 0
1337 0
1338 (let* ((v1
1339 (let ((*s7* 0))
1340 b)))
1341 0)
1342 0
1343 nil))
1344 0
1345 nil)))
1346 1 2)))
1347
1348 ;;; misc.295
1349 (assert (eql
1350 (funcall
1351 (compile
1352 nil
1353 '(lambda ()
1354 (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
1355 (multiple-value-prog1
1356 (the integer (catch 'ct8 (catch 'ct7 15867134)))
1357 (catch 'ct1 (throw 'ct1 0))))))
1358 15867134))
1359
1360 ;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
1361 ;;; could transform known-values LVAR to UVL
1362 (assert (zerop (funcall
1363 (compile
1364 nil
1365 '(lambda (a b c)
1366 (declare (notinline boole values denominator list))
1367 (declare
1368 (optimize (speed 2)
1369 (space 0)
1370 (safety 1)
1371 (debug 0)
1372 (compilation-speed 2)))
1373 (catch 'ct6
1374 (progv
1375 '(*s8*)
1376 (list 0)
1377 (let ((v9 (ignore-errors (throw 'ct6 0))))
1378 (denominator
1379 (progv nil nil (values (boole boole-and 0 v9)))))))))
1380 1 2 3)))
1381
1382 ;;; non-continuous dead UVL blocks
1383 (defun non-continuous-stack-test (x)
1384 (multiple-value-call #'list
1385 (eval '(values 11 12))
1386 (eval '(values 13 14))
1387 (block ext
1388 (return-from non-continuous-stack-test
1389 (multiple-value-call #'list
1390 (eval '(values :b1 :b2))
1391 (eval '(values :b3 :b4))
1392 (block int
1393 (return-from ext
1394 (multiple-value-call (eval #'values)
1395 (eval '(values 1 2))
1396 (eval '(values 3 4))
1397 (block ext
1398 (return-from int
1399 (multiple-value-call (eval #'values)
1400 (eval '(values :a1 :a2))
1401 (eval '(values :a3 :a4))
1402 (block int
1403 (return-from ext
1404 (multiple-value-call (eval #'values)
1405 (eval '(values 5 6))
1406 (eval '(values 7 8))
1407 (if x
1408 :ext
1409 (return-from int :int))))))))))))))))
1410 (assert (equal (non-continuous-stack-test t) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext)))
1411 (assert (equal (non-continuous-stack-test nil) '(:b1 :b2 :b3 :b4 :a1 :a2 :a3 :a4 :int)))
1412
1413 ;;; MISC.362: environment of UNWIND-PROTECTor is different from that
1414 ;;; if ENTRY.
1415 (assert (equal (multiple-value-list (funcall
1416 (compile
1417 nil
1418 '(lambda (b g h)
1419 (declare (optimize (speed 3) (space 3) (safety 2)
1420 (debug 2) (compilation-speed 3)))
1421 (catch 'ct5
1422 (unwind-protect
1423 (labels ((%f15 (f15-1 f15-2 f15-3)
1424 (rational (throw 'ct5 0))))
1425 (%f15 0
1426 (apply #'%f15
1427 0
1428 h
1429 (progn
1430 (progv '(*s2* *s5*) (list 0 (%f15 0 g 0)) b)
1431 0)
1432 nil)
1433 0))
1434 (common-lisp:handler-case 0)))))
1435 1 2 3))
1436 '(0)))
1437
1438 \f
1439 ;;; MISC.275
1440 (assert
1441 (zerop
1442 (funcall
1443 (compile
1444 nil
1445 '(lambda (b)
1446 (declare (notinline funcall min coerce))
1447 (declare
1448 (optimize (speed 1)
1449 (space 2)
1450 (safety 2)
1451 (debug 1)
1452 (compilation-speed 1)))
1453 (flet ((%f12 (f12-1)
1454 (coerce
1455 (min
1456 (if f12-1 (multiple-value-prog1
1457 b (return-from %f12 0))
1458 0))
1459 'integer)))
1460 (funcall #'%f12 0))))
1461 -33)))
1462
1463 ;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
1464 ;;; potential problem: optimizers and type derivers for MAX and MIN
1465 ;;; were not consistent in treating EQUALP, but not EQL, arguments.
1466 (dolist (f '(min max))
1467 (loop for complex-arg-args in '((1d0 2d0) (0d0 1d0))
1468 for complex-arg = `(if x ,@complex-arg-args)
1469 do
1470 (loop for args in `((1 ,complex-arg)
1471 (,complex-arg 1))
1472 for form = `(,f ,@args)
1473 for f1 = (compile nil `(lambda (x) ,form))
1474 and f2 = (compile nil `(lambda (x) (declare (notinline min max))
1475 ,form))
1476 do
1477 (dolist (x '(nil t))
1478 (assert (eql (funcall f1 x) (funcall f2 x)))))))
1479
1480 ;;;
1481 (handler-case (compile nil '(lambda (x)
1482 (declare (optimize (speed 3) (safety 0)))
1483 (the double-float (sqrt (the double-float x)))))
1484 (sb-ext:compiler-note (c)
1485 ;; Ignore the note for the float -> pointer conversion of the
1486 ;; return value.
1487 (unless (string= (car (last (sb-c::simple-condition-format-arguments c)))
1488 "<return value>")
1489 (error "Compiler does not trust result type assertion."))))
1490
1491 (let ((f (compile nil '(lambda (x)
1492 (declare (optimize speed (safety 0)))
1493 (block nil
1494 (the double-float
1495 (multiple-value-prog1
1496 (sqrt (the double-float x))
1497 (when (< x 0)
1498 (return :minus)))))))))
1499 (assert (eql (funcall f -1d0) :minus))
1500 (assert (eql (funcall f 4d0) 2d0)))
1501
1502 ;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
1503 (handler-case
1504 (compile nil '(lambda (a i)
1505 (locally
1506 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
1507 (inhibit-warnings 0)))
1508 (declare (type (alien (* (unsigned 8))) a)
1509 (type (unsigned-byte 32) i))
1510 (deref a i))))
1511 (compiler-note (c)
1512 (unless (search "%ASH/RIGHT" (first (simple-condition-format-arguments c)))
1513 (error "The code is not optimized."))))
1514
1515 (handler-case
1516 (compile nil '(lambda (x)
1517 (declare (type (integer -100 100) x))
1518 (declare (optimize speed))
1519 (declare (notinline identity))
1520 (1+ (identity x))))
1521 (compiler-note () (error "IDENTITY derive-type not applied.")))
1522
1523 (assert (null (funcall (compile nil '(lambda (x) (funcall #'cddr x))) nil)))
1524
1525 ;;; MISC.293 = easy variant of bug 303: repeated write to the same
1526 ;;; LVAR; here the first write may be cleared before the second is
1527 ;;; made.
1528 (assert
1529 (zerop
1530 (funcall
1531 (compile
1532 nil
1533 '(lambda ()
1534 (declare (notinline complex))
1535 (declare (optimize (speed 1) (space 0) (safety 1)
1536 (debug 3) (compilation-speed 3)))
1537 (flet ((%f () (multiple-value-prog1 0 (return-from %f 0))))
1538 (complex (%f) 0)))))))
1539
1540 ;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
1541 (assert (zerop (funcall
1542 (compile
1543 nil
1544 '(lambda (a c)
1545 (declare (type (integer -1294746569 1640996137) a))
1546 (declare (type (integer -807801310 3) c))
1547 (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
1548 (catch 'ct7
1549 (if
1550 (logbitp 0
1551 (if (/= 0 a)
1552 c
1553 (ignore-errors
1554 (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7 0))) 0 0) 0))))
1555 0 0))))
1556 391833530 -32785211)))
1557
1558 ;;; efficiency notes for ordinary code
1559 (macrolet ((frob (arglist &body body)
1560 `(progn
1561 (handler-case
1562 (compile nil '(lambda ,arglist ,@body))
1563 (sb-ext:compiler-note (e)
1564 (error "bad compiler note for ~S:~% ~A" ',body e)))
1565 (let ((gotit nil))
1566 (handler-bind ((compiler-note
1567 (lambda (c)
1568 (setq gotit t) (muffle-warning c))))
1569 (compile nil '(lambda ,arglist (declare (optimize speed))
1570 ,@body)))
1571 (unless gotit
1572 (error "missing compiler note for ~S" ',body))))))
1573 (frob (x) (funcall x))
1574 (frob (x y) (find x y))
1575 (frob (x y) (find-if x y))
1576 (frob (x y) (find-if-not x y))
1577 (frob (x y) (position x y))
1578 (frob (x y) (position-if x y))
1579 (frob (x y) (position-if-not x y))
1580 (frob (x) (aref x 0)))
1581
1582 (macrolet ((frob (style-warn-p form)
1583 (if style-warn-p
1584 `(let ((gotit nil))
1585 (handler-bind ((style-warning
1586 (lambda (c)
1587 (setq gotit t) (muffle-warning c))))
1588 (eval ',form))
1589 (unless gotit
1590 (error "missing style-warning for ~S" ',form)))
1591 `(handler-case
1592 (eval ',form)
1593 (style-warning (e)
1594 (error "bad style-warning for ~S: ~A" ',form e))))))
1595 (frob t (lambda (x &optional y &key z) (list x y z)))
1596 (frob nil (lambda (x &optional y z) (list x y z)))
1597 (frob nil (lambda (x &key y z) (list x y z)))
1598 (frob t (defgeneric #:foo (x &optional y &key z)))
1599 (frob nil (defgeneric #:foo (x &optional y z)))
1600 (frob nil (defgeneric #:foo (x &key y z)))
1601 (frob t (defun #:foo (x) (flet ((foo (x &optional y &key z) (list x y z))) (foo x x :z x)))))
1602
1603 ;;; this was a bug in the LOGXOR type deriver. The top form gave a
1604 ;;; note, because the system failed to derive the fact that the return
1605 ;;; from LOGXOR was small and negative, though the bottom one worked.
1606 (handler-bind ((sb-ext:compiler-note #'error))
1607 (compile nil '(lambda ()
1608 (declare (optimize speed (safety 0)))
1609 (lambda (x y)
1610 (declare (type (integer 3 6) x)
1611 (type (integer -6 -3) y))
1612 (+ (logxor x y) most-positive-fixnum)))))
1613 (handler-bind ((sb-ext:compiler-note #'error))
1614 (compile nil '(lambda ()
1615 (declare (optimize speed (safety 0)))
1616 (lambda (x y)
1617 (declare (type (integer 3 6) y)
1618 (type (integer -6 -3) x))
1619 (+ (logxor x y) most-positive-fixnum)))))
1620
1621 ;;; check that modular ash gives the right answer, to protect against
1622 ;;; possible misunderstandings about the hardware shift instruction.
1623 (assert (zerop (funcall
1624 (compile nil '(lambda (x y)
1625 (declare (optimize speed)
1626 (type (unsigned-byte 32) x y))
1627 (logand #xffffffff (ash x y))))
1628 1 257)))
1629
1630 ;;; code instrumenting problems
1631 (compile nil
1632 '(lambda ()
1633 (declare (optimize (debug 3)))
1634 (list (the integer (if nil 14 t)))))
1635
1636 (compile nil
1637 '(LAMBDA (A B C D)
1638 (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD))
1639 (DECLARE
1640 (OPTIMIZE (SPEED 1)
1641 (SPACE 1)
1642 (SAFETY 1)
1643 (DEBUG 3)
1644 (COMPILATION-SPEED 0)))
1645 (MASK-FIELD (BYTE 7 26)
1646 (PROGN
1647 (TAGBODY (THE INTEGER (CATCH 'CT4 (LOGORC1 C -15950))) 1)
1648 B))))
1649
1650 (compile nil
1651 '(lambda (buffer i end)
1652 (declare (optimize (debug 3)))
1653 (loop (when (not (eql 0 end)) (return)))
1654 (let ((s (make-string end)))
1655 (setf (schar s i) (schar buffer i))
1656 s)))
1657
1658 ;;; check that constant string prefix and suffix don't cause the
1659 ;;; compiler to emit code deletion notes.
1660 (handler-bind ((sb-ext:code-deletion-note #'error))
1661 (compile nil '(lambda (s x)
1662 (pprint-logical-block (s x :prefix "(")
1663 (print x s))))
1664 (compile nil '(lambda (s x)
1665 (pprint-logical-block (s x :per-line-prefix ";")
1666 (print x s))))
1667 (compile nil '(lambda (s x)
1668 (pprint-logical-block (s x :suffix ">")
1669 (print x s)))))
1670
1671 ;;; MISC.427: loop analysis requires complete DFO structure
1672 (assert (eql 17 (funcall
1673 (compile
1674 nil
1675 '(lambda (a)
1676 (declare (notinline list reduce logior))
1677 (declare (optimize (safety 2) (compilation-speed 1)
1678 (speed 3) (space 2) (debug 2)))
1679 (logior
1680 (let* ((v5 (reduce #'+ (list 0 a))))
1681 (declare (dynamic-extent v5))
1682 v5))))
1683 17)))
1684
1685 ;;; MISC.434
1686 (assert (zerop (funcall
1687 (compile
1688 nil
1689 '(lambda (a b)
1690 (declare (type (integer -8431780939320 1571817471932) a))
1691 (declare (type (integer -4085 0) b))
1692 (declare (ignorable a b))
1693 (declare
1694 (optimize (space 2)
1695 (compilation-speed 0)
1696 #+sbcl (sb-c:insert-step-conditions 0)
1697 (debug 2)
1698 (safety 0)
1699 (speed 3)))
1700 (let ((*s5* 0))
1701 (dotimes (iv1 2 0)
1702 (let ((*s5*
1703 (elt '(1954479092053)
1704 (min 0
1705 (max 0
1706 (if (< iv1 iv1)
1707 (lognand iv1 (ash iv1 (min 53 iv1)))
1708 iv1))))))
1709 0)))))
1710 -7639589303599 -1368)))
1711
1712 (compile
1713 nil
1714 '(lambda (a b)
1715 (declare (type (integer) a))
1716 (declare (type (integer) b))
1717 (declare (ignorable a b))
1718 (declare (optimize (space 2) (compilation-speed 0)
1719 (debug 0) (safety 0) (speed 3)))
1720 (dotimes (iv1 2 0)
1721 (when (< iv1 2) (print 'x)) ;; request for second constraint propagation pass
1722 (print (if (< iv1 iv1)
1723 (logand (ash iv1 iv1) 1)
1724 iv1)))))
1725
1726 ;;; MISC.435: lambda var substitution in a deleted code.
1727 (assert (zerop (funcall
1728 (compile
1729 nil
1730 '(lambda (a b c d)
1731 (declare (notinline aref logandc2 gcd make-array))
1732 (declare
1733 (optimize (space 0) (safety 0) (compilation-speed 3)
1734 (speed 3) (debug 1)))
1735 (progn
1736 (tagbody
1737 (let* ((v2 (make-array nil :initial-element (catch 'ct1 (go tag2)))))
1738 (declare (dynamic-extent v2))
1739 (gcd (go tag2) (logandc2 (catch 'ct2 c) (aref v2))))
1740 tag2)
1741 0)))
1742 3021871717588 -866608 -2 -17194)))
1743
1744 ;;; MISC.436, 438: lost reoptimization
1745 (assert (zerop (funcall
1746 (compile
1747 nil
1748 '(lambda (a b)
1749 (declare (type (integer -2917822 2783884) a))
1750 (declare (type (integer 0 160159) b))
1751 (declare (ignorable a b))
1752 (declare
1753 (optimize (compilation-speed 1)
1754 (speed 3)
1755 (safety 3)
1756 (space 0)
1757 ; #+sbcl (sb-c:insert-step-conditions 0)
1758 (debug 0)))
1759 (if
1760 (oddp
1761 (loop for
1762 lv1
1763 below
1764 2
1765 count
1766 (logbitp 0
1767 (1-
1768 (ash b
1769 (min 8
1770 (count 0
1771 '(-10197561 486 430631291
1772 9674068))))))))
1773 b
1774 0)))
1775 1265797 110757)))
1776
1777 (assert (zerop (funcall
1778 (compile
1779 nil
1780 ' (lambda (a)
1781 (declare (type (integer 0 1696) a))
1782 ; (declare (ignorable a))
1783 (declare (optimize (space 2) (debug 0) (safety 1)
1784 (compilation-speed 0) (speed 1)))
1785 (if (logbitp 0 (ash (1- a) (min 11 a))) 0 0)))
1786 805)))
1787
1788 ;;; bug #302
1789 (assert (compile
1790 nil
1791 '(lambda (s ei x y)
1792 (declare (type (simple-array function (2)) s) (type ei ei))
1793 (funcall (aref s ei) x y))))
1794
1795 ;;; MISC.320: ir1-transform can create an intercomponent reference to
1796 ;;; a DEFINED-FUN.
1797 (assert (eql 102 (funcall
1798 (compile
1799 nil
1800 '(lambda ()
1801 (declare (optimize (speed 3) (space 0) (safety 2)
1802 (debug 2) (compilation-speed 0)))
1803 (catch 'ct2
1804 (elt '(102)
1805 (flet ((%f12 () (rem 0 -43)))
1806 (multiple-value-call #'%f12 (values))))))))))
1807
1808 ;;; MISC.437: lost reoptimization after FLUSH-DEST
1809 (assert (zerop (funcall
1810 (compile
1811 nil
1812 '(lambda (a b c d e)
1813 (declare (notinline values complex eql))
1814 (declare
1815 (optimize (compilation-speed 3)
1816 (speed 3)
1817 (debug 1)
1818 (safety 1)
1819 (space 0)))
1820 (flet ((%f10
1821 (f10-1 f10-2 f10-3
1822 &optional (f10-4 (ignore-errors 0)) (f10-5 0)
1823 &key &allow-other-keys)
1824 (if (or (eql 0 0) t) 0 (if f10-1 0 0))))
1825 (complex (multiple-value-call #'%f10 (values a c b 0 0)) 0))))
1826 80043 74953652306 33658947 -63099937105 -27842393)))
1827
1828 ;;; bug #351 -- program-error for malformed LET and LET*, including those
1829 ;;; resulting from SETF of LET.
1830 (with-test (:name :bug-351)
1831 (dolist (fun (list (compile nil '(lambda (x) (let :bogus-let :oops)))
1832 (compile nil '(lambda (x) (let* :bogus-let* :oops)))
1833 (compile nil '(lambda (x) (push x (let ((y 0)) y))))))
1834 (assert (functionp fun))
1835 (multiple-value-bind (res err) (ignore-errors (funcall fun t))
1836 (princ err) (terpri)
1837 (assert (not res))
1838 (assert (typep err 'program-error)))))
1839
1840 (let ((fun (compile nil '(lambda (x) (random (if x 10 20))))))
1841 (dotimes (i 100 (error "bad RANDOM distribution"))
1842 (when (> (funcall fun nil) 9)
1843 (return t)))
1844 (dotimes (i 100)
1845 (when (> (funcall fun t) 9)
1846 (error "bad RANDOM event"))))
1847
1848 ;;; 0.8.17.28-sma.1 lost derived type information.
1849 (with-test (:name :0.8.17.28-sma.1 :fails-on :sparc)
1850 (handler-bind ((sb-ext:compiler-note (lambda (c) (error "~A" c))))
1851 (compile nil
1852 '(lambda (x y v)
1853 (declare (optimize (speed 3) (safety 0)))
1854 (declare (type (integer 0 80) x)
1855 (type (integer 0 11) y)
1856 (type (simple-array (unsigned-byte 32) (*)) v))
1857 (setf (aref v 0) (* (* x #.(floor (ash 1 32) (* 11 80))) y))
1858 nil))))
1859
1860 ;;; Bug reported by Robert J. Macomber: instrumenting of more-entry
1861 ;;; prevented open coding of %LISTIFY-REST-ARGS.
1862 (let ((f (compile nil '(lambda ()
1863 (declare (optimize (debug 3)))
1864 (with-simple-restart (blah "blah") (error "blah"))))))
1865 (handler-bind ((error (lambda (c) (invoke-restart 'blah))))
1866 (assert (equal (multiple-value-list (funcall f)) '(nil t)))))
1867
1868 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
1869 ;;; constant index and value.
1870 (loop for n-bits = 1 then (* n-bits 2)
1871 for type = `(unsigned-byte ,n-bits)
1872 and v-max = (1- (ash 1 n-bits))
1873 while (<= n-bits sb-vm:n-word-bits)
1874 do
1875 (let* ((n (* 2 (1+ (- sb-vm::n-word-bits n-bits))))
1876 (array1 (make-array n :element-type type))
1877 (array2 (make-array n :element-type type)))
1878 (dotimes (i n)
1879 (dolist (v (list 0 v-max))
1880 (let ((f (compile nil `(lambda (a)
1881 (declare (type (simple-array ,type (,n)) a))
1882 (setf (aref a ,i) ,v)))))
1883 (fill array1 (- v-max v))
1884 (fill array2 (- v-max v))
1885 (funcall f array1)
1886 (setf (aref array2 i) v)
1887 (assert (every #'= array1 array2)))))))
1888
1889 (let ((fn (compile nil '(lambda (x)
1890 (declare (type bit x))
1891 (declare (optimize speed))
1892 (let ((b (make-array 64 :element-type 'bit
1893 :initial-element 0)))
1894 (count x b))))))
1895 (assert (= (funcall fn 0) 64))
1896 (assert (= (funcall fn 1) 0)))
1897
1898 (let ((fn (compile nil '(lambda (x y)
1899 (declare (type simple-bit-vector x y))
1900 (declare (optimize speed))
1901 (equal x y)))))
1902 (assert (funcall
1903 fn
1904 (make-array 64 :element-type 'bit :initial-element 0)
1905 (make-array 64 :element-type 'bit :initial-element 0)))
1906 (assert (not
1907 (funcall
1908 fn
1909 (make-array 64 :element-type 'bit :initial-element 0)
1910 (let ((b (make-array 64 :element-type 'bit :initial-element 0)))
1911 (setf (sbit b 63) 1)
1912 b)))))
1913
1914 ;;; MISC.535: compiler failure
1915 (let ((c0 #c(4196.088977268509d0 -15943.3603515625d0)))
1916 (assert (not (funcall
1917 (compile
1918 nil
1919 `(lambda (p1 p2)
1920 (declare (optimize speed (safety 1))
1921 (type (eql ,c0) p1)
1922 (type number p2))
1923 (eql (the (complex double-float) p1) p2)))
1924 c0 #c(12 612/979)))))
1925
1926 ;;; reported by Lutz Euler: we shouldn't signal a compiler note for
1927 ;;; simple-bit-vector functions.
1928 (handler-bind ((sb-ext:compiler-note #'error))
1929 (compile nil '(lambda (x)
1930 (declare (type simple-bit-vector x))
1931 (count 1 x))))
1932 (handler-bind ((sb-ext:compiler-note #'error))
1933 (compile nil '(lambda (x y)
1934 (declare (type simple-bit-vector x y))
1935 (equal x y))))
1936
1937 ;;; MISC.550: CAST merging in IR1 finalization caused unexpected
1938 ;;; code transformations.
1939 (assert (eql (funcall
1940 (compile
1941 nil
1942 '(lambda (p1 p2)
1943 (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
1944 (type atom p1)
1945 (type symbol p2))
1946 (or p1 (the (eql t) p2))))
1947 nil t)
1948 t))
1949
1950 ;;; MISC.548: type check weakening converts required type into
1951 ;;; optional
1952 (assert (eql t
1953 (funcall
1954 (compile
1955 nil
1956 '(lambda (p1)
1957 (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
1958 (atom (the (member f assoc-if write-line t w) p1))))
1959 t)))
1960
1961 ;;; Free special bindings only apply to the body of the binding form, not
1962 ;;; the initialization forms.
1963 (assert (eq :good
1964 (funcall (compile 'nil
1965 '(lambda ()
1966 (let ((x :bad))
1967 (declare (special x))
1968 (let ((x :good))
1969 ((lambda (&optional (y x))
1970 (declare (special x)) y)))))))))
1971
1972 ;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
1973 ;;; a rational was zero, but didn't do the substitution, leading to a
1974 ;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
1975 ;;; machine's ASH instruction's immediate field) that the compiler
1976 ;;; thought was legitimate.
1977 (with-test (:name :overlarge-immediate-in-ash-vop)
1978 (compile 'nil
1979 '(LAMBDA (B)
1980 (DECLARE (TYPE (INTEGER -2 14) B))
1981 (DECLARE (IGNORABLE B))
1982 (ASH (IMAGPART B) 57))))
1983
1984 ;;; bug reported by Eduardo Mu\~noz
1985 (multiple-value-bind (fun warnings failure)
1986 (compile nil '(lambda (struct first)
1987 (declare (optimize speed))
1988 (let* ((nodes (nodes struct))
1989 (bars (bars struct))
1990 (length (length nodes))
1991 (new (make-array length :fill-pointer 0)))
1992 (vector-push first new)
1993 (loop with i fixnum = 0
1994 for newl fixnum = (length new)
1995 while (< newl length) do
1996 (let ((oldl (length new)))
1997 (loop for j fixnum from i below newl do
1998 (dolist (n (node-neighbours (aref new j) bars))
1999 (unless (find n new)
2000 (vector-push n new))))
2001 (setq i oldl)))
2002 new)))
2003 (declare (ignore fun warnings failure))
2004 (assert (not failure)))
2005
2006 ;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe
2007 ;;; sbcl-devel)
2008 (compile nil '(lambda (x y a b c)
2009 (- y (* (signum x) (sqrt (abs (- (* b x) c)))))))
2010
2011 ;;; Type inference from CHECK-TYPE
2012 (let ((count0 0) (count1 0))
2013 (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count0))))
2014 (compile nil '(lambda (x)
2015 (declare (optimize (speed 3)))
2016 (1+ x))))
2017 ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note
2018 (assert (> count0 1))
2019 (handler-bind ((sb-ext:compiler-note (lambda (c) (incf count1))))
2020 (compile nil '(lambda (x)
2021 (declare (optimize (speed 3)))
2022 (check-type x fixnum)
2023 (1+ x))))
2024 ;; Only the posssible word -> bignum conversion note
2025 (assert (= count1 1)))
2026
2027 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
2028 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
2029 (with-test (:name :sap-ref-float)
2030 (compile nil '(lambda (sap)
2031 (let ((x (setf (sb-vm::sap-ref-double sap 0) 1d0)))
2032 (1+ x))))
2033 (compile nil '(lambda (sap)
2034 (let ((x (setf (sb-vm::sap-ref-single sap 0) 1d0)))
2035 (1+ x)))))
2036
2037 ;;; bug #399
2038 (with-test (:name :string-union-types)
2039 (compile nil '(lambda (x)
2040 (declare (type (or (simple-array character (6))
2041 (simple-array character (5))) x))
2042 (aref x 0))))
2043
2044 ;;; MISC.623: missing functions for constant-folding
2045 (assert (eql 0
2046 (funcall
2047 (compile
2048 nil
2049 '(lambda ()
2050 (declare (optimize (space 2) (speed 0) (debug 2)
2051 (compilation-speed 3) (safety 0)))
2052 (loop for lv3 below 1
2053 count (minusp
2054 (loop for lv2 below 2
2055 count (logbitp 0
2056 (bit #*1001101001001
2057 (min 12 (max 0 lv3))))))))))))
2058
2059 ;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs
2060 (assert (eql 0
2061 (funcall
2062 (compile
2063 nil
2064 '(lambda (a)
2065 (declare (type (integer 21 28) a))
2066 (declare (optimize (compilation-speed 1) (safety 2)
2067 (speed 0) (debug 0) (space 1)))
2068 (let* ((v7 (flet ((%f3 (f3-1 f3-2)
2069 (loop for lv2 below 1
2070 count
2071 (logbitp 29
2072 (sbit #*10101111
2073 (min 7 (max 0 (eval '0))))))))
2074 (%f3 0 a))))
2075 0)))
2076 22)))
2077
2078 ;;; MISC.626: bandaged AVER was still wrong
2079 (assert (eql -829253
2080 (funcall
2081 (compile
2082 nil
2083 '(lambda (a)
2084 (declare (type (integer -902970 2) a))
2085 (declare (optimize (space 2) (debug 0) (compilation-speed 1)
2086 (speed 0) (safety 3)))
2087 (prog2 (if (logbitp 30 a) 0 (block b3 0)) a)))
2088 -829253)))
2089
2090 ;; MISC.628: constant-folding %LOGBITP was buggy
2091 (assert (eql t
2092 (funcall
2093 (compile
2094 nil
2095 '(lambda ()
2096 (declare (optimize (safety 3) (space 3) (compilation-speed 3)
2097 (speed 0) (debug 1)))
2098 (not (not (logbitp 0 (floor 2147483651 (min -23 0))))))))))
2099
2100 ;; mistyping found by random-tester
2101 (assert (zerop
2102 (funcall
2103 (compile
2104 nil
2105 '(lambda ()
2106 (declare (optimize (speed 1) (debug 0)
2107 (space 2) (safety 0) (compilation-speed 0)))
2108 (unwind-protect 0
2109 (* (/ (multiple-value-prog1 -29457482 -5602513511) 1))))))))
2110
2111 ;; aggressive constant folding (bug #400)
2112 (assert
2113 (eq t (funcall (compile nil '(lambda () (or t (the integer (/ 1 0))))))))
2114
2115 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-1))
2116 (assert
2117 (handler-case
2118 (compile nil '(lambda (x y)
2119 (when (eql x (length y))
2120 (locally
2121 (declare (optimize (speed 3)))
2122 (1+ x)))))
2123 (compiler-note () (error "The code is not optimized.")))))
2124
2125 (with-test (:name (:compiler :constraint-propagation :var-eql-to-non-var-2))
2126 (assert
2127 (handler-case
2128 (compile nil '(lambda (x y)
2129 (when (eql (length y) x)
2130 (locally
2131 (declare (optimize (speed 3)))
2132 (1+ x)))))
2133 (compiler-note () (error "The code is not optimized.")))))
2134
2135 (with-test (:name (:compiler :constraint-propagation :float-bounds-1))
2136 (handler-case
2137 (compile nil '(lambda (x)
2138 (declare (type (single-float * (3.0)) x))
2139 (when (<= x 2.0)
2140 (when (<= 2.0 x)
2141 x))))
2142 (compiler-note () (error "Deleted reachable code."))))
2143
2144 (defun assert-code-deletion-note (lambda &optional (howmany 1))
2145 (let ((n 0))
2146 (handler-bind ((code-deletion-note
2147 (lambda (c)
2148 (incf n)
2149 ;; even though notes are not warnings,
2150 ;; compiler-notify provides the MUFFLE-WARNING restart.
2151 (muffle-warning c))))
2152 (compile nil lambda)
2153 (assert (eql n howmany)))))
2154
2155 (with-test (:name (:compiler :constraint-propagation :float-bounds-2))
2156 (assert-code-deletion-note
2157 '(lambda (x)
2158 (declare (type single-float x))
2159 (when (< 1.0 x)
2160 (when (<= x 1.0)
2161 (error "This is unreachable."))))))
2162
2163 (with-test (:name (:compiler :constraint-propagation :float-bounds-3
2164 :LP-894498))
2165 (assert-code-deletion-note
2166 '(lambda (x)
2167 (declare (type (single-float 0.0) x))
2168 (when (> x 0.0)
2169 (when (zerop x)
2170 (error "This is unreachable."))))))
2171
2172 (with-test (:name (:compiler :constraint-propagation :float-bounds-4
2173 :LP-894498))
2174 (assert-code-deletion-note
2175 '(lambda (x y)
2176 (declare (type (single-float 0.0) x)
2177 (type (single-float (0.0)) y))
2178 (when (> x y)
2179 (when (zerop x)
2180 (error "This is unreachable."))))))
2181
2182 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-1))
2183 (assert-code-deletion-note
2184 '(lambda (x y)
2185 (when (typep y 'fixnum)
2186 (when (eql x y)
2187 (unless (typep x 'fixnum)
2188 (error "This is unreachable"))
2189 (setq y nil))))))
2190
2191 (with-test (:name (:compiler :constraint-propagation :var-eql-to-var-2))
2192 (assert-code-deletion-note
2193 '(lambda (x y)
2194 (when (typep y 'fixnum)
2195 (when (eql y x)
2196 (unless (typep x 'fixnum)
2197 (error "This is unreachable"))
2198 (setq y nil))))))
2199
2200 ;; Reported by John Wiseman, sbcl-devel
2201 ;; Subject: [Sbcl-devel] float type derivation bug?
2202 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700
2203 (with-test (:name (:type-derivation :float-bounds))
2204 (compile nil '(lambda (bits)
2205 (let* ((s (if (= (ash bits -31) 0) 1 -1))
2206 (e (logand (ash bits -23) #xff))
2207 (m (if (= e 0)
2208 (ash (logand bits #x7fffff) 1)
2209 (logior (logand bits #x7fffff) #x800000))))
2210 (float (* s m (expt 2 (- e 150))))))))
2211
2212 ;; Reported by James Knight
2213 ;; Subject: [Sbcl-devel] AVER: "(EQ (SB-NAME (SC-SB (TN-SC TN))) 'REGISTERS)"
2214 ;; Date: Fri, 24 Mar 2006 19:30:00 -0500
2215 (with-test (:name :logbitp-vop)
2216 (compile nil
2217 '(lambda (days shift)
2218 (declare (type fixnum shift days))
2219 (let* ((result 0)
2220 (canonicalized-shift (+ shift 1))
2221 (first-wrapping-day (- 1 canonicalized-shift)))
2222 (declare (type fixnum result))
2223 (dotimes (source-day 7)
2224 (declare (type (integer 0 6) source-day))
2225 (when (logbitp source-day days)
2226 (setf result
2227 (logior result
2228 (the fixnum
2229 (if (< source-day first-wrapping-day)
2230 (+ source-day canonicalized-shift)
2231 (- (+ source-day
2232 canonicalized-shift) 7)))))))
2233 result))))
2234
2235 ;;; MISC.637: incorrect delaying of conversion of optional entries
2236 ;;; with hairy constant defaults
2237 (let ((f '(lambda ()
2238 (labels ((%f11 (f11-2 &key key1)
2239 (labels ((%f8 (f8-2 &optional (f8-5 (if nil (return-from %f11 0) 0)))
2240 :bad1))
2241 (%f8 (%f8 0)))
2242 :bad2))
2243 :good))))
2244 (assert (eq (funcall (compile nil f)) :good)))
2245
2246 ;;; MISC.555: new reference to an already-optimized local function
2247 (let* ((l '(lambda (p1)
2248 (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1))
2249 (keywordp p1)))
2250 (f (compile nil l)))
2251 (assert (funcall f :good))
2252 (assert (nth-value 1 (ignore-errors (funcall f 42)))))
2253
2254 ;;; Check that the compiler doesn't munge *RANDOM-STATE*.
2255 (let* ((state (make-random-state))
2256 (*random-state* (make-random-state state))
2257 (a (random most-positive-fixnum)))
2258 (setf *random-state* state)
2259 (compile nil `(lambda (x a)
2260 (declare (single-float x)
2261 (type (simple-array double-float) a))
2262 (+ (loop for i across a
2263 summing i)
2264 x)))
2265 (assert (= a (random most-positive-fixnum))))
2266
2267 ;;; MISC.641: LET-conversion after physical environment analysis lost NLX-INFOs
2268 (let ((form '(lambda ()
2269 (declare (optimize (speed 1) (space 0) (debug 2)
2270 (compilation-speed 0) (safety 1)))
2271 (flet ((%f3 (f3-1 &key (key1 (count (floor 0 (min -74 0)) #())))
2272 0))
2273 (apply #'%f3 0 nil)))))
2274 (assert (zerop (funcall (compile nil form)))))
2275
2276 ;;; 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
2277 (compile nil '(lambda ()
2278 (let ((x (make-array '(1) :element-type '(signed-byte 32))))
2279 (setf (aref x 0) 1))))
2280
2281 ;;; step instrumentation confusing the compiler, reported by Faré
2282 (handler-bind ((warning #'error))
2283 (compile nil '(lambda ()
2284 (declare (optimize (debug 2))) ; not debug 3!
2285 (let ((val "foobar"))
2286 (map-into (make-array (list (length val))
2287 :element-type '(unsigned-byte 8))
2288 #'char-code val)))))
2289
2290 ;;; overconfident primitive type computation leading to bogus type
2291 ;;; checking.
2292 (let* ((form1 '(lambda (x)
2293 (declare (type (and condition function) x))
2294 x))
2295 (fun1 (compile nil form1))
2296 (form2 '(lambda (x)
2297 (declare (type (and standard-object function) x))
2298 x))
2299 (fun2 (compile nil form2)))
2300 (assert-error (funcall fun1 (make-condition 'error)))
2301 (assert-error (funcall fun1 fun1))
2302 (assert-error (funcall fun2 fun2))
2303 (assert (eq (funcall fun2 #'print-object) #'print-object)))
2304
2305 ;;; LET* + VALUES declaration: while the declaration is a non-standard
2306 ;;; and possibly a non-conforming extension, as long as we do support
2307 ;;; it, we might as well get it right.
2308 ;;;
2309 ;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
2310 (compile nil '(lambda () (let* () (declare (values list)))))
2311
2312
2313 ;;; test for some problems with too large immediates in x86-64 modular
2314 ;;; arithmetic vops
2315 (compile nil '(lambda (x) (declare (fixnum x))
2316 (logand most-positive-fixnum (logxor x most-positive-fixnum))))
2317
2318 (compile nil '(lambda (x) (declare (fixnum x))
2319 (logand most-positive-fixnum (+ x most-positive-fixnum))))
2320
2321 (compile nil '(lambda (x) (declare (fixnum x))
2322 (logand most-positive-fixnum (* x most-positive-fixnum))))
2323
2324 ;;; bug 256.b
2325 (with-test (:name :propagate-type-through-error-and-binding)
2326 (assert (let (warned-p)
2327 (handler-bind ((warning (lambda (w) (setf warned-p t))))
2328 (compile nil
2329 '(lambda (x)
2330 (list (let ((y (the real x)))
2331 (unless (floatp y) (error ""))
2332 y)
2333 (integer-length x)))))
2334 warned-p)))
2335
2336 ;; Dead / in safe code
2337 (with-test (:name :safe-dead-/)
2338 (assert (eq :error
2339 (handler-case
2340 (funcall (compile nil
2341 '(lambda (x y)
2342 (declare (optimize (safety 3)))
2343 (/ x y)
2344 (+ x y)))
2345 1
2346 0)
2347 (division-by-zero ()
2348 :error)))))
2349
2350 ;;; Dead unbound variable (bug 412)
2351 (with-test (:name :dead-unbound)
2352 (assert (eq :error
2353 (handler-case
2354 (funcall (compile nil
2355 '(lambda ()
2356 #:unbound
2357 42)))
2358 (unbound-variable ()
2359 :error)))))
2360
2361 ;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR.
2362 (handler-bind ((sb-ext:compiler-note 'error))
2363 (assert
2364 (equalp #(2 3)
2365 (funcall (compile nil `(lambda (s p e)
2366 (declare (optimize speed)
2367 (simple-vector s))
2368 (subseq s p e)))
2369 (vector 1 2 3 4)
2370 1
2371 3))))
2372
2373 ;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR.
2374 (handler-bind ((sb-ext:compiler-note 'error))
2375 (assert
2376 (equalp #(1 2 3 4)
2377 (funcall (compile nil `(lambda (s)
2378 (declare (optimize speed)
2379 (simple-vector s))
2380 (copy-seq s)))
2381 (vector 1 2 3 4)))))
2382
2383 ;;; bug in adding DATA-VECTOR-REF-WITH-OFFSET to x86-64
2384 (assert (not (mismatch #(1.0f0 2.0f0) (make-array 2 :element-type 'single-float :initial-contents (list 1.0f0 2.0f0)))))
2385
2386 ;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too
2387 ;;; large bignums to floats
2388 (dolist (op '(* / + -))
2389 (let ((fun (compile
2390 nil
2391 `(lambda (x)
2392 (declare (type (integer 0 #.(* 2 (truncate most-positive-double-float))) x))
2393 (,op 0.0d0 x)))))
2394 (loop repeat 10
2395 do (let ((arg (random (truncate most-positive-double-float))))
2396 (assert (eql (funcall fun arg)
2397 (funcall op 0.0d0 arg)))))))
2398
2399 (with-test (:name :high-debug-known-function-inlining)
2400 (let ((fun (compile nil
2401 '(lambda ()
2402 (declare (optimize (debug 3)) (inline append))
2403 (let ((fun (lambda (body)
2404 (append
2405 (first body)
2406 nil))))
2407 (funcall fun
2408 '((foo (bar)))))))))
2409 (funcall fun)))
2410
2411 (with-test (:name :high-debug-known-function-transform-with-optional-arguments)
2412 (compile nil '(lambda (x y)
2413 (declare (optimize sb-c::preserve-single-use-debug-variables))
2414 (if (block nil
2415 (some-unknown-function
2416 (lambda ()
2417 (return (member x y))))
2418 t)
2419 t
2420 (error "~a" y)))))
2421
2422 ;;; Compiling W-P-O when the pinned objects are known to be fixnums
2423 ;;; or characters.
2424 (compile nil '(lambda (x y)
2425 (declare (fixnum y) (character x))
2426 (sb-sys:with-pinned-objects (x y)
2427 (some-random-function))))
2428
2429 ;;; *CHECK-CONSISTENCY* and TRULY-THE
2430
2431 (with-test (:name :bug-423)
2432 (let ((sb-c::*check-consistency* t))
2433 (handler-bind ((warning #'error))
2434 (flet ((make-lambda (type)
2435 `(lambda (x)
2436 ((lambda (z)
2437 (if (listp z)
2438 (let ((q (truly-the list z)))
2439 (length q))
2440 (if (arrayp z)
2441 (let ((q (truly-the vector z)))
2442 (length q))
2443 (error "oops"))))
2444 (the ,type x)))))
2445 (compile nil (make-lambda 'list))
2446 (compile nil (make-lambda 'vector))))))
2447
2448 ;;; this caused a momentary regression when an ill-adviced fix to
2449 ;;; bug 427 made ANY-REG suitable for primitive-type T:
2450 ;;;
2451 ;;; 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)
2452 ;;; [Condition of type SIMPLE-ERROR]
2453 (compile nil
2454 '(lambda (frob)
2455 (labels
2456 ((%zig (frob)
2457 (typecase frob
2458 (double-float
2459 (setf (sb-alien:deref (sb-alien:cast (sb-alien:sap-alien (unknown1) (* unsigned-char))
2460 (* double-float))) frob))
2461 (hash-table
2462 (%zig (the (values (single-float (0.0) 1.0) &optional) (unknown2)))
2463 nil))))
2464 (%zig))))
2465
2466 ;;; non-required arguments in HANDLER-BIND
2467 (assert (eq :oops (car (funcall (compile nil
2468 '(lambda (x)
2469 (block nil
2470 (handler-bind ((error (lambda (&rest args) (return (cons :oops args)))))
2471 (/ 2 x)))))
2472 0))))
2473
2474 ;;; NIL is a legal function name
2475 (assert (eq 'a (flet ((nil () 'a)) (nil))))
2476
2477 ;;; misc.528
2478 (assert (null (let* ((x 296.3066f0)
2479 (y 22717067)
2480 (form `(lambda (r p2)
2481 (declare (optimize speed (safety 1))
2482 (type (simple-array single-float nil) r)
2483 (type (integer -9369756340 22717335) p2))
2484 (setf (aref r) (* ,x (the (eql 22717067) p2)))
2485 (values)))
2486 (r (make-array nil :element-type 'single-float))
2487 (expected (* x y)))
2488 (funcall (compile nil form) r y)
2489 (let ((actual (aref r)))
2490 (unless (eql expected actual)
2491 (list expected actual))))))
2492 ;;; misc.529
2493 (assert (null (let* ((x -2367.3296f0)
2494 (y 46790178)
2495 (form `(lambda (r p2)
2496 (declare (optimize speed (safety 1))
2497 (type (simple-array single-float nil) r)
2498 (type (eql 46790178) p2))
2499 (setf (aref r) (+ ,x (the (integer 45893897) p2)))
2500 (values)))
2501 (r (make-array nil :element-type 'single-float))
2502 (expected (+ x y)))
2503 (funcall (compile nil form) r y)
2504 (let ((actual (aref r)))
2505 (unless (eql expected actual)
2506 (list expected actual))))))
2507
2508 ;;; misc.556
2509 (assert (eql -1
2510 (funcall
2511 (compile nil '(lambda (p1 p2)
2512 (declare
2513 (optimize (speed 1) (safety 0)
2514 (debug 0) (space 0))
2515 (type (member 8174.8604) p1)
2516 (type (member -95195347) p2))
2517 (floor p1 p2)))
2518 8174.8604 -95195347)))
2519
2520 ;;; misc.557
2521 (assert (eql -1
2522 (funcall
2523 (compile
2524 nil
2525 '(lambda (p1)
2526 (declare (optimize (speed 3) (safety 0) (debug 3) (space 1))
2527 (type (member -94430.086f0) p1))
2528 (floor (the single-float p1) 19311235)))
2529 -94430.086f0)))
2530
2531 ;;; misc.558
2532 (assert (eql -1.0f0
2533 (funcall
2534 (compile
2535 nil
2536 '(lambda (p1)
2537 (declare (optimize (speed 1) (safety 2)
2538 (debug 2) (space 3))
2539 (type (eql -39466.56f0) p1))
2540 (ffloor p1 305598613)))
2541 -39466.56f0)))
2542
2543 ;;; misc.559
2544 (assert (eql 1
2545 (funcall
2546 (compile
2547 nil
2548 '(lambda (p1)
2549 (declare (optimize (speed 1) (safety 1) (debug 1) (space 2))
2550 (type (eql -83232.09f0) p1))
2551 (ceiling p1 -83381228)))
2552 -83232.09f0)))
2553
2554 ;;; misc.560
2555 (assert (eql 1
2556 (funcall
2557 (compile
2558 nil
2559 '(lambda (p1)
2560 (declare (optimize (speed 1) (safety 1)
2561 (debug 1) (space 0))
2562 (type (member -66414.414f0) p1))
2563 (ceiling p1 -63019173f0)))
2564 -66414.414f0)))
2565
2566 ;;; misc.561
2567 (assert (eql 1.0f0
2568 (funcall
2569 (compile
2570 nil
2571 '(lambda (p1)
2572 (declare (optimize (speed 0) (safety 1)
2573 (debug 0) (space 1))
2574 (type (eql 20851.398f0) p1))
2575 (fceiling p1 80839863)))
2576 20851.398f0)))
2577
2578 ;;; misc.581
2579 (assert (floatp
2580 (funcall
2581 (compile nil '(lambda (x)
2582 (declare (type (eql -5067.2056) x))
2583 (+ 213734822 x)))
2584 -5067.2056)))
2585
2586 ;;; misc.581a
2587 (assert (typep
2588 (funcall
2589 (compile nil '(lambda (x) (declare (type (eql -1.0) x))
2590 (+ #x1000001 x)))
2591 -1.0f0)
2592 'single-float))
2593
2594 ;;; misc.582
2595 (assert (plusp (funcall
2596 (compile
2597 nil
2598 ' (lambda (p1)
2599 (declare (optimize (speed 0) (safety 1) (debug 1) (space 1))
2600 (type (eql -39887.645) p1))
2601 (mod p1 382352925)))
2602 -39887.645)))
2603
2604 ;;; misc.587
2605 (assert (let ((result (funcall
2606 (compile
2607 nil
2608 '(lambda (p2)
2609 (declare (optimize (speed 0) (safety 3) (debug 1) (space 0))
2610 (type (eql 33558541) p2))
2611 (- 92215.266 p2)))
2612 33558541)))
2613 (typep result 'single-float)))
2614
2615 ;;; misc.635
2616 (assert (eql 1
2617 (let* ((form '(lambda (p2)
2618 (declare (optimize (speed 0) (safety 1)
2619 (debug 2) (space 2))
2620 (type (member -19261719) p2))
2621 (ceiling -46022.094 p2))))
2622 (values (funcall (compile nil form) -19261719)))))
2623
2624 ;;; misc.636
2625 (assert (let* ((x 26899.875)
2626 (form `(lambda (p2)
2627 (declare (optimize (speed 3) (safety 1) (debug 3) (space 1))
2628 (type (member ,x #:g5437 char-code #:g5438) p2))
2629 (* 104102267 p2))))
2630 (floatp (funcall (compile nil form) x))))
2631
2632 ;;; misc.622
2633 (assert (eql
2634 (funcall
2635 (compile
2636 nil
2637 '(lambda (p2)
2638 (declare (optimize (speed 3) (safety 2) (debug 3) (space 0))
2639 (type real p2))
2640 (+ 81535869 (the (member 17549.955 #:g35917) p2))))
2641 17549.955)
2642 (+ 81535869 17549.955)))
2643
2644 ;;; misc.654
2645 (assert (eql 2
2646 (let ((form '(lambda (p2)
2647 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2648 (type (member integer eql) p2))
2649 (coerce 2 p2))))
2650 (funcall (compile nil form) 'integer))))
2651
2652 ;;; misc.656
2653 (assert (eql 2
2654 (let ((form '(lambda (p2)
2655 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2656 (type (member integer mod) p2))
2657 (coerce 2 p2))))
2658 (funcall (compile nil form) 'integer))))
2659
2660 ;;; misc.657
2661 (assert (eql 2
2662 (let ((form '(lambda (p2)
2663 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2664 (type (member integer values) p2))
2665 (coerce 2 p2))))
2666 (funcall (compile nil form) 'integer))))
2667
2668 (with-test (:name :string-aref-type)
2669 (assert (eq 'character
2670 (funcall (compile nil
2671 '(lambda (s)
2672 (ctu:compiler-derived-type (aref (the string s) 0))))
2673 "foo"))))
2674
2675 (with-test (:name :base-string-aref-type)
2676 (assert (eq #+sb-unicode 'base-char
2677 #-sb-unicode 'character
2678 (funcall (compile nil
2679 '(lambda (s)
2680 (ctu:compiler-derived-type (aref (the base-string s) 0))))
2681 (coerce "foo" 'base-string)))))
2682
2683 (with-test (:name :dolist-constant-type-derivation)
2684 (assert (equal '(integer 1 3)
2685 (funcall (compile nil
2686 '(lambda (x)
2687 (dolist (y '(1 2 3))
2688 (when x
2689 (return (ctu:compiler-derived-type y))))))
2690 t))))
2691
2692 (with-test (:name :dolist-simple-list-type-derivation)
2693 (assert (equal '(integer 1 3)
2694 (funcall (compile nil
2695 '(lambda (x)
2696 (dolist (y (list 1 2 3))
2697 (when x
2698 (return (ctu:compiler-derived-type y))))))
2699 t))))
2700
2701 (with-test (:name :dolist-dotted-constant-list-type-derivation)
2702 (let* ((warned nil)
2703 (fun (handler-bind ((style-warning (lambda (c) (push c warned))))
2704 (compile nil
2705 '(lambda (x)
2706 (dolist (y '(1 2 3 . 4) :foo)
2707 (when x
2708 (return (ctu:compiler-derived-type y)))))))))
2709 (assert (equal '(integer 1 3) (funcall fun t)))
2710 (assert (= 1 (length warned)))
2711 (multiple-value-bind (res err) (ignore-errors (funcall fun nil))
2712 (assert (not res))
2713 (assert (typep err 'type-error)))))
2714
2715 (with-test (:name :constant-list-destructuring)
2716 (handler-bind ((sb-ext:compiler-note #'error))
2717 (progn
2718 (assert (= 10
2719 (funcall
2720 (compile nil
2721 '(lambda ()
2722 (destructuring-bind (a (b c) d) '(1 (2 3) 4)
2723 (+ a b c d)))))))
2724 (assert (eq :feh
2725 (funcall
2726 (compile nil
2727 '(lambda (x)
2728 (or x
2729 (destructuring-bind (a (b c) d) '(1 "foo" 4)
2730 (+ a b c d)))))
2731 :feh))))))
2732
2733 ;;; Functions with non-required arguments used to end up with
2734 ;;; (&OPTIONAL-DISPATCH ...) as their names.
2735 (with-test (:name :hairy-function-name)
2736 (assert (eq 'read-line (nth-value 2 (function-lambda-expression #'read-line))))
2737 (assert (equal "#<FUNCTION READ-LINE>" (princ-to-string #'read-line))))
2738
2739 ;;; PROGV + RESTRICT-COMPILER-POLICY
2740 ;; META: there's a test in compiler.impure.lisp that also tests
2741 ;; interaction of PROGV with (debug 3). These tests should be together.
2742 (with-test (:name :progv-and-restrict-compiler-policy)
2743 (let ((sb-c::*policy-restrictions* sb-c::*policy-restrictions*))
2744 (restrict-compiler-policy 'debug 3)
2745 (let ((fun (compile nil '(lambda (x)
2746 (let ((i x))
2747 (declare (special i))
2748 (list i
2749 (progv '(i) (list (+ i 1))
2750 i)
2751 i))))))
2752 (assert (equal '(1 2 1) (funcall fun 1))))))
2753
2754 ;;; It used to be possible to confuse the compiler into
2755 ;;; IR2-converting such a call to CONS
2756 (with-test (:name :late-bound-primitive)
2757 (compile nil `(lambda ()
2758 (funcall 'cons 1))))
2759
2760 (with-test (:name :hairy-array-element-type-derivation)
2761 (compile nil '(lambda (x)
2762 (declare (type (and simple-string (satisfies array-has-fill-pointer-p)) x))
2763 (array-element-type x))))
2764
2765 (with-test (:name :rest-list-type-derivation)
2766 (multiple-value-bind (type derivedp)
2767 (funcall (compile nil `(lambda (&rest args)
2768 (ctu:compiler-derived-type args)))
2769 nil)
2770 (assert (eq 'list type))
2771 (assert derivedp)))
2772
2773 (with-test (:name :rest-list-type-derivation2)
2774 (multiple-value-bind (type derivedp)
2775 (funcall (funcall (compile nil `(lambda ()
2776 (lambda (&rest args)
2777 (ctu:compiler-derived-type args))))))
2778 (assert (eq 'list type))
2779 (assert derivedp)))
2780
2781 (with-test (:name :rest-list-type-derivation3)
2782 (multiple-value-bind (type derivedp)
2783 (funcall (funcall (compile nil `(lambda ()
2784 (lambda (&optional x &rest args)
2785 (unless x (error "oops"))
2786 (ctu:compiler-derived-type args)))))
2787 t)
2788 (assert (eq 'list type))
2789 (assert derivedp)))
2790
2791 (with-test (:name :rest-list-type-derivation4)
2792 (multiple-value-bind (type derivedp)
2793 (funcall (funcall (compile nil `(lambda ()
2794 (lambda (&optional x &rest args)
2795 (declare (type (or null integer) x))
2796 (when x (setf args x))
2797 (ctu:compiler-derived-type args)))))
2798 42)
2799 (assert (equal '(or cons null integer) type))
2800 (assert derivedp)))
2801
2802 (with-test (:name :base-char-typep-elimination)
2803 (assert (eq (funcall (compile nil
2804 `(lambda (ch)
2805 (declare (type base-char ch) (optimize (speed 3) (safety 0)))
2806 (typep ch 'base-char)))
2807 t)
2808 t)))
2809
2810 (with-test (:name :regression-1.0.24.37)
2811 (compile nil '(lambda (&key (test (constantly t)))
2812 (when (funcall test)
2813 :quux))))
2814
2815 ;;; Attempt to test a decent cross section of conditions
2816 ;;; and values types to move conditionally.
2817 (macrolet
2818 ((test-comparison (comparator type x y)
2819 `(progn
2820 ,@(loop for (result-type a b)
2821 in '((nil t nil)
2822 (nil 0 1)
2823 (nil 0.0 1.0)
2824 (nil 0d0 0d0)
2825 (nil 0.0 0d0)
2826 (nil #c(1.0 1.0) #c(2.0 2.0))
2827
2828 (t t nil)
2829 (fixnum 0 1)
2830 ((unsigned-byte #.sb-vm:n-word-bits)
2831 (1+ most-positive-fixnum)
2832 (+ 2 most-positive-fixnum))
2833 ((signed-byte #.sb-vm:n-word-bits)
2834 -1 (* 2 most-negative-fixnum))
2835 (single-float 0.0 1.0)
2836 (double-float 0d0 1d0))
2837 for lambda = (if result-type
2838 `(lambda (x y a b)
2839 (declare (,type x y)
2840 (,result-type a b))
2841 (if (,comparator x y)
2842 a b))
2843 `(lambda (x y)
2844 (declare (,type x y))
2845 (if (,comparator x y)
2846 ,a ,b)))
2847 for args = `(,x ,y ,@(and result-type
2848 `(,a ,b)))
2849 collect
2850 `(progn
2851 (eql (funcall (compile nil ',lambda)
2852 ,@args)
2853 (eval '(,lambda ,@args))))))))
2854 (sb-vm::with-float-traps-masked
2855 (:divide-by-zero :overflow :inexact :invalid)
2856 (let (#+sb-eval (sb-ext:*evaluator-mode* :interpret))
2857 (declare (sb-ext:muffle-conditions style-warning))
2858 (test-comparison eql t t nil)
2859 (test-comparison eql t t t)
2860
2861 (test-comparison = t 1 0)
2862 (test-comparison = t 1 1)
2863 (test-comparison = t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2864 (test-comparison = fixnum 1 0)
2865 (test-comparison = fixnum 0 0)
2866 (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2867 (test-comparison = (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2868 (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 0)
2869 (test-comparison = (signed-byte #.sb-vm:n-word-bits) 1 1)
2870
2871 (test-comparison = single-float 0.0 1.0)
2872 (test-comparison = single-float 1.0 1.0)
2873 (test-comparison = single-float (/ 1.0 0.0) (/ 1.0 0.0))
2874 (test-comparison = single-float (/ 1.0 0.0) 1.0)
2875 (test-comparison = single-float (/ 0.0 0.0) (/ 0.0 0.0))
2876 (test-comparison = single-float (/ 0.0 0.0) 0.0)
2877
2878 (test-comparison = double-float 0d0 1d0)
2879 (test-comparison = double-float 1d0 1d0)
2880 (test-comparison = double-float (/ 1d0 0d0) (/ 1d0 0d0))
2881 (test-comparison = double-float (/ 1d0 0d0) 1d0)
2882 (test-comparison = double-float (/ 0d0 0d0) (/ 0d0 0d0))
2883 (test-comparison = double-float (/ 0d0 0d0) 0d0)
2884
2885 (test-comparison < t 1 0)
2886 (test-comparison < t 0 1)
2887 (test-comparison < t 1 1)
2888 (test-comparison < t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2889 (test-comparison < t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum))
2890 (test-comparison < fixnum 1 0)
2891 (test-comparison < fixnum 0 1)
2892 (test-comparison < fixnum 0 0)
2893 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2894 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 1)
2895 (test-comparison < (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2896 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 0)
2897 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 0 1)
2898 (test-comparison < (signed-byte #.sb-vm:n-word-bits) 1 1)
2899
2900 (test-comparison < single-float 0.0 1.0)
2901 (test-comparison < single-float 1.0 0.0)
2902 (test-comparison < single-float 1.0 1.0)
2903 (test-comparison < single-float (/ 1.0 0.0) (/ 1.0 0.0))
2904 (test-comparison < single-float (/ 1.0 0.0) 1.0)
2905 (test-comparison < single-float 1.0 (/ 1.0 0.0))
2906 (test-comparison < single-float (/ 0.0 0.0) (/ 0.0 0.0))
2907 (test-comparison < single-float (/ 0.0 0.0) 0.0)
2908
2909 (test-comparison < double-float 0d0 1d0)
2910 (test-comparison < double-float 1d0 0d0)
2911 (test-comparison < double-float 1d0 1d0)
2912 (test-comparison < double-float (/ 1d0 0d0) (/ 1d0 0d0))
2913 (test-comparison < double-float (/ 1d0 0d0) 1d0)
2914 (test-comparison < double-float 1d0 (/ 1d0 0d0))
2915 (test-comparison < double-float (/ 0d0 0d0) (/ 0d0 0d0))
2916 (test-comparison < double-float (/ 0d0 0d0) 0d0)
2917 (test-comparison < double-float 0d0 (/ 0d0 0d0))
2918
2919 (test-comparison > t 1 0)
2920 (test-comparison > t 0 1)
2921 (test-comparison > t 1 1)
2922 (test-comparison > t (1+ most-positive-fixnum) (+ 2 most-positive-fixnum))
2923 (test-comparison > t (+ 2 most-positive-fixnum) (1+ most-positive-fixnum))
2924 (test-comparison > fixnum 1 0)
2925 (test-comparison > fixnum 0 1)
2926 (test-comparison > fixnum 0 0)
2927 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 1 0)
2928 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 1)
2929 (test-comparison > (unsigned-byte #.sb-vm:n-word-bits) 0 0)
2930 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 0)
2931 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 0 1)
2932 (test-comparison > (signed-byte #.sb-vm:n-word-bits) 1 1)
2933
2934 (test-comparison > single-float 0.0 1.0)
2935 (test-comparison > single-float 1.0 0.0)
2936 (test-comparison > single-float 1.0 1.0)
2937 (test-comparison > single-float (/ 1.0 0.0) (/ 1.0 0.0))
2938 (test-comparison > single-float (/ 1.0 0.0) 1.0)
2939 (test-comparison > single-float 1.0 (/ 1.0 0.0))
2940 (test-comparison > single-float (/ 0.0 0.0) (/ 0.0 0.0))
2941 (test-comparison > single-float (/ 0.0 0.0) 0.0)
2942
2943 (test-comparison > double-float 0d0 1d0)
2944 (test-comparison > double-float 1d0 0d0)
2945 (test-comparison > double-float 1d0 1d0)
2946 (test-comparison > double-float (/ 1d0 0d0) (/ 1d0 0d0))
2947 (test-comparison > double-float (/ 1d0 0d0) 1d0)
2948 (test-comparison > double-float 1d0 (/ 1d0 0d0))
2949 (test-comparison > double-float (/ 0d0 0d0) (/ 0d0 0d0))
2950 (test-comparison > double-float (/ 0d0 0d0) 0d0)
2951 (test-comparison > double-float 0d0 (/ 0d0 0d0)))))
2952
2953 (with-test (:name :car-and-cdr-type-derivation-conservative)
2954 (let ((f1 (compile nil
2955 `(lambda (y)
2956 (declare (optimize speed))
2957 (let ((x (the (cons fixnum fixnum) (cons 1 2))))
2958 (declare (type (cons t fixnum) x))
2959 (rplaca x y)
2960 (+ (car x) (cdr x))))))
2961 (f2 (compile nil
2962 `(lambda (y)
2963 (declare (optimize speed))
2964 (let ((x (the (cons fixnum fixnum) (cons 1 2))))
2965 (setf (cdr x) y)
2966 (+ (car x) (cdr x)))))))
2967 (flet ((test-error (e value)
2968 (assert (typep e 'type-error))
2969 (assert (eq 'number (type-error-expected-type e)))
2970 (assert (eq value (type-error-datum e)))))
2971 (let ((v1 "foo")
2972 (v2 "bar"))
2973 (multiple-value-bind (res err) (ignore-errors (funcall f1 v1))
2974 (assert (not res))
2975 (test-error err v1))
2976 (multiple-value-bind (res err) (ignore-errors (funcall f2 v2))
2977 (assert (not res))
2978 (test-error err v2))))))
2979
2980 (with-test (:name :array-dimension-derivation-conservative)
2981 (let ((f (compile nil
2982 `(lambda (x)
2983 (declare (optimize speed))
2984 (declare (type (array * (4 4)) x))
2985 (let ((y x))
2986 (setq x (make-array '(4 4)))
2987 (adjust-array y '(3 5))
2988 (array-dimension y 0))))))
2989 (assert (= 3 (funcall f (make-array '(4 4) :adjustable t))))))
2990
2991 (with-test (:name :with-timeout-code-deletion-note)
2992 (handler-bind ((sb-ext:code-deletion-note #'error))
2993 (compile nil `(lambda ()
2994 (sb-ext:with-timeout 0
2995 (sleep 1))))))
2996
2997 (with-test (:name :full-warning-for-undefined-type-in-cl)
2998 (assert (eq :full
2999 (handler-case
3000 (compile nil `(lambda (x) (the replace x)))
3001 (style-warning ()
3002 :style)
3003 (warning ()
3004 :full)))))
3005
3006 (with-test (:name :single-warning-for-single-undefined-type)
3007 (let ((n 0))
3008 (handler-bind ((warning (lambda (c)
3009 (declare (ignore c))
3010 (incf n))))
3011 (compile nil `(lambda (x) (the #:no-type x)))
3012 (assert (= 1 n))
3013 (compile nil `(lambda (x) (the 'fixnum x)))
3014 (assert (= 2 n)))))
3015
3016 (with-test (:name :complex-subtype-dumping-in-xc)
3017 (assert
3018 (= sb-vm:complex-single-float-widetag
3019 (sb-kernel:widetag-of
3020 (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex single-float))))))
3021 (assert
3022 (= sb-vm:complex-double-float-widetag
3023 (sb-kernel:widetag-of
3024 (sb-vm:saetp-initial-element-default (sb-c::find-saetp '(complex double-float)))))))
3025
3026 (with-test (:name :complex-single-float-fill)
3027 (assert (every (lambda (x) (= #c(1.0 2.0) x))
3028 (funcall
3029 (compile nil
3030 `(lambda (n x)
3031 (make-array (list n)
3032 :element-type '(complex single-float)
3033 :initial-element x)))
3034 10
3035 #c(1.0 2.0)))))
3036
3037 (with-test (:name :regression-1.0.28.21)
3038 (let ((fun (compile nil `(lambda (x) (typep x '(simple-array * 1))))))
3039 (assert (funcall fun (vector 1 2 3)))
3040 (assert (funcall fun "abc"))
3041 (assert (not (funcall fun (make-array '(2 2)))))))
3042
3043 (with-test (:name :no-silly-compiler-notes-from-character-function)
3044 (let (current)
3045 (handler-bind ((compiler-note (lambda (e) (error "~S: ~A" current e))))
3046 (dolist (name '(char-code char-int character char-name standard-char-p
3047 graphic-char-p alpha-char-p upper-case-p lower-case-p
3048 both-case-p digit-char-p alphanumericp digit-char-p))
3049 (setf current name)
3050 (compile nil `(lambda (x)
3051 (declare (character x) (optimize speed))
3052 (,name x))))
3053 (dolist (name '(char= char/= char< char> char<= char>=
3054 char-lessp char-greaterp char-not-greaterp
3055 char-not-lessp))
3056 (setf current name)
3057 (compile nil `(lambda (x y)
3058 (declare (character x y) (optimize speed))
3059 (,name x y)))))))
3060
3061 ;;; optimizing make-array
3062 (with-test (:name (make-array :open-code-initial-contents))
3063 (assert (not (ctu:find-named-callees
3064 (compile nil
3065 `(lambda (x y z)
3066 (make-array '(3) :initial-contents (list x y z)))))))
3067 (assert (not (ctu:find-named-callees
3068 (compile nil
3069 `(lambda (x y z)
3070 (make-array '3 :initial-contents (vector x y z)))))))
3071 (assert (not (ctu:find-named-callees
3072 (compile nil
3073 `(lambda (x y z)
3074 (make-array '3 :initial-contents `(,x ,y ,z))))))))
3075
3076 ;;; optimizing array-in-bounds-p
3077 (with-test (:name :optimize-array-in-bounds-p)
3078 (locally
3079 (macrolet ((find-callees (&body body)
3080 `(ctu:find-named-callees
3081 (compile nil
3082 '(lambda ()
3083 ,@body))
3084 :name 'array-in-bounds-p))
3085 (must-optimize (&body exprs)
3086 `(progn
3087 ,@(loop for expr in exprs
3088 collect `(assert (not (find-callees
3089 ,expr))))))
3090 (must-not-optimize (&body exprs)
3091 `(progn
3092 ,@(loop for expr in exprs
3093 collect `(assert (find-callees
3094 ,expr))))))
3095 (must-optimize
3096 ;; in bounds
3097 (let ((a (make-array '(1))))
3098 (array-in-bounds-p a 0))
3099 ;; exceeds upper bound (constant)
3100 (let ((a (make-array '(1))))
3101 (array-in-bounds-p a 1))
3102 ;; exceeds upper bound (interval)
3103 (let ((a (make-array '(1))))
3104 (array-in-bounds-p a (+ 1 (random 2))))
3105 ;; negative lower bound (constant)
3106 (let ((a (make-array '(1))))
3107 (array-in-bounds-p a -1))
3108 ;; negative lower bound (interval)
3109 (let ((a (make-array 3))
3110 (i (- (random 1) 20)))
3111 (array-in-bounds-p a i))
3112 ;; multiple known dimensions
3113 (let ((a (make-array '(1 1))))
3114 (array-in-bounds-p a 0 0))
3115 ;; union types
3116 (let ((s (the (simple-string 10) (eval "0123456789"))))
3117 (array-in-bounds-p s 9)))
3118 (must-not-optimize
3119 ;; don't trust non-simple array length in safety=1
3120 (let ((a (the (array * (10 20)) (make-array '(10 20) :adjustable t))))
3121 (eval `(adjust-array ,a '(0 0)))
3122 (array-in-bounds-p a 9 0))
3123 ;; multiple unknown dimensions
3124 (let ((a (make-array (list (random 20) (random 5)))))
3125 (array-in-bounds-p a 5 2))
3126 ;; some other known dimensions
3127 (let ((a (make-array (list 1 (random 5)))))
3128 (array-in-bounds-p a 0 2))
3129 ;; subscript might be negative
3130 (let ((a (make-array '(5 10))))
3131 (array-in-bounds-p a 1 (- (random 3) 2)))
3132 ;; subscript might be too large
3133 (let ((a (make-array '(5 10))))
3134 (array-in-bounds-p a (random 6) 1))
3135 ;; unknown upper bound
3136 (let ((a (make-array '(5 10))))
3137 (array-in-bounds-p a (get-universal-time) 1))
3138 ;; unknown lower bound
3139 (let ((a (make-array '(5 30))))
3140 (array-in-bounds-p a 0 (- (get-universal-time))))
3141 ;; in theory we should be able to optimize
3142 ;; the following but the current implementation
3143 ;; doesn't cut it because the array type's
3144 ;; dimensions get reported as (* *).
3145 (let ((a (make-array (list (random 20) 1))))
3146 (array-in-bounds-p a 5 2))))))
3147
3148 ;;; optimizing (EXPT -1 INTEGER)
3149 (with-test (:name (expt -1 integer))
3150 (dolist (x '(-1 -1.0 -1.0d0))
3151 (let ((fun (compile nil `(lambda (x) (expt ,x (the fixnum x))))))
3152 (assert (not (ctu:find-named-callees fun)))
3153 (dotimes (i 12)
3154 (if (oddp i)
3155 (assert (eql x (funcall fun i)))
3156 (assert (eql (- x) (funcall fun i))))))))
3157
3158 (with-test (:name :float-division-using-exact-reciprocal)
3159 (flet ((test (lambda-form arg res &key (check-insts t))
3160 (let* ((fun (compile nil lambda-form))
3161 (disassembly (with-output-to-string (s)
3162 (disassemble fun :stream s))))
3163 ;; Let's make sure there is no division at runtime: for x86 and
3164 ;; x86-64 that implies an FDIV, DIVSS, or DIVSD instruction, so
3165 ;; look for DIV in the disassembly. It's a terrible KLUDGE, but
3166 ;; it works.
3167 #+(or x86 x86-64)
3168 (when check-insts
3169 (assert (not (search "DIV" disassembly))))
3170 ;; No generic arithmetic!
3171 (assert (not (search "GENERIC" disassembly)))
3172 (assert (eql res (funcall fun arg))))))
3173 (dolist (c '(128 64 32 16 8 4 2 1 1/2 1/4 1/8 1/16 1/32 1/64))
3174 (dolist (type '(single-float double-float))
3175 (let* ((cf (coerce c type))
3176 (arg (- (random (* 2 cf)) cf))
3177 (r1 (eval `(/ ,arg ,cf)))
3178 (r2 (eval `(/ ,arg ,(- cf)))))
3179 (test `(lambda (x) (declare (,type x)) (/ x ,cf)) arg r1)
3180 (test `(lambda (x) (declare (,type x)) (/ x ,(- cf))) arg r2)
3181 ;; rational args should get optimized as well
3182 (test `(lambda (x) (declare (,type x)) (/ x ,c)) arg r1)
3183 (test `(lambda (x) (declare (,type x)) (/ x ,(- c))) arg r2))))
3184 ;; Also check that inexact reciprocals (1) are not used by default (2) are
3185 ;; used with FLOAT-ACCURACY=0.
3186 (dolist (type '(single-float double-float))
3187 (let ((trey (coerce 3 type))
3188 (one (coerce 1 type)))
3189 (test `(lambda (x) (declare (,type x)) (/ x 3)) trey one
3190 :check-insts nil)
3191 (test `(lambda (x)
3192 (declare (,type x)
3193 (optimize (sb-c::float-accuracy 0)))
3194 (/ x 3))
3195 trey (eval `(* ,trey (/ ,trey))))))))
3196
3197 (with-test (:name :float-multiplication-by-one)
3198 (flet ((test (lambda-form arg &optional (result arg))
3199 (let* ((fun1 (compile nil lambda-form))
3200 (fun2 (funcall (compile nil `(lambda ()
3201 (declare (optimize (sb-c::float-accuracy 0)))
3202 ,lambda-form))))
3203 (disassembly1 (with-output-to-string (s)
3204 (disassemble fun1 :stream s)))
3205 (disassembly2 (with-output-to-string (s)
3206 (disassemble fun2 :stream s))))
3207 ;; Multiplication at runtime should be eliminated only with
3208 ;; FLOAT-ACCURACY=0. (To catch SNaNs.)
3209 #+(or x86 x86-64)
3210 (assert (and (search "MUL" disassembly1)
3211 (not (search "MUL" disassembly2))))
3212 ;; Not generic arithmetic, please!
3213 (assert (and (not (search "GENERIC" disassembly1))
3214 (not (search "GENERIC" disassembly2))))
3215 (assert (eql result (funcall fun1 arg)))
3216 (assert (eql result (funcall fun2 arg))))))
3217 (dolist (type '(single-float double-float))
3218 (let* ((one (coerce 1 type))
3219 (arg (random (* 2 one)))
3220 (-r (- arg)))
3221 (test `(lambda (x) (declare (,type x)) (* x 1)) arg)
3222 (test `(lambda (x) (declare (,type x)) (* x -1)) arg -r)
3223 (test `(lambda (x) (declare (,type x)) (* x ,one)) arg)
3224 (test `(lambda (x) (declare (,type x)) (* x ,(- one))) arg -r)))))
3225
3226 (with-test (:name :float-addition-of-zero)
3227 (flet ((test (lambda-form arg &optional (result arg))
3228 (let* ((fun1 (compile nil lambda-form))
3229 (fun2 (funcall (compile nil `(lambda ()
3230 (declare (optimize (sb-c::float-accuracy 0)))
3231 ,lambda-form))))
3232 (disassembly1 (with-output-to-string (s)
3233 (disassemble fun1 :stream s)))
3234 (disassembly2 (with-output-to-string (s)
3235 (disassemble fun2 :stream s))))
3236 ;; Let's make sure there is no addition at runtime: for x86 and
3237 ;; x86-64 that implies an FADD, ADDSS, or ADDSD instruction, so
3238 ;; look for the ADDs in the disassembly. It's a terrible KLUDGE,
3239 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3240 ;; addition in to catch SNaNs.
3241 #+x86
3242 (assert (and (search "FADD" disassembly1)
3243 (not (search "FADD" disassembly2))))
3244 #+x86-64
3245 (let ((inst (if (typep result 'double-float)
3246 "ADDSD" "ADDSS")))
3247 (assert (and (search inst disassembly1)
3248 (not (search inst disassembly2)))))
3249 (assert (eql result (funcall fun1 arg)))
3250 (assert (eql result (funcall fun2 arg))))))
3251 (test `(lambda (x) (declare (single-float x)) (+ x 0)) 123.45)
3252 (test `(lambda (x) (declare (single-float x)) (+ x 0.0)) 543.21)
3253 (test `(lambda (x) (declare (single-float x)) (+ x 0.0d0)) 42.00 42.d0)
3254 (test `(lambda (x) (declare (double-float x)) (+ x 0)) 123.45d0)
3255 (test `(lambda (x) (declare (double-float x)) (+ x 0.0)) 543.21d0)
3256 (test `(lambda (x) (declare (double-float x)) (+ x 0.0d0)) 42.d0)))
3257
3258 (with-test (:name :float-substraction-of-zero)
3259 (flet ((test (lambda-form arg &optional (result arg))
3260 (let* ((fun1 (compile nil lambda-form))
3261 (fun2 (funcall (compile nil `(lambda ()
3262 (declare (optimize (sb-c::float-accuracy 0)))
3263 ,lambda-form))))
3264 (disassembly1 (with-output-to-string (s)
3265 (disassemble fun1 :stream s)))
3266 (disassembly2 (with-output-to-string (s)
3267 (disassemble fun2 :stream s))))
3268 ;; Let's make sure there is no substraction at runtime: for x86
3269 ;; and x86-64 that implies an FSUB, SUBSS, or SUBSD instruction,
3270 ;; so look for SUB in the disassembly. It's a terrible KLUDGE,
3271 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3272 ;; substraction in in to catch SNaNs.
3273 #+x86
3274 (assert (and (search "FSUB" disassembly1)
3275 (not (search "FSUB" disassembly2))))
3276 #+x86-64
3277 (let ((inst (if (typep result 'double-float)
3278 "SUBSD" "SUBSS")))
3279 (assert (and (search inst disassembly1)
3280 (not (search inst disassembly2)))))
3281 (assert (eql result (funcall fun1 arg)))
3282 (assert (eql result (funcall fun2 arg))))))
3283 (test `(lambda (x) (declare (single-float x)) (- x 0)) 123.45)
3284 (test `(lambda (x) (declare (single-float x)) (- x 0.0)) 543.21)
3285 (test `(lambda (x) (declare (single-float x)) (- x 0.0d0)) 42.00 42.d0)
3286 (test `(lambda (x) (declare (double-float x)) (- x 0)) 123.45d0)
3287 (test `(lambda (x) (declare (double-float x)) (- x 0.0)) 543.21d0)
3288 (test `(lambda (x) (declare (double-float x)) (- x 0.0d0)) 42.d0)))
3289
3290 (with-test (:name :float-multiplication-by-two)
3291 (flet ((test (lambda-form arg &optional (result arg))
3292 (let* ((fun1 (compile nil lambda-form))
3293 (fun2 (funcall (compile nil `(lambda ()
3294 (declare (optimize (sb-c::float-accuracy 0)))
3295 ,lambda-form))))
3296 (disassembly1 (with-output-to-string (s)
3297 (disassemble fun1 :stream s)))
3298 (disassembly2 (with-output-to-string (s)
3299 (disassemble fun2 :stream s))))
3300 ;; Let's make sure there is no multiplication at runtime: for x86
3301 ;; and x86-64 that implies an FMUL, MULSS, or MULSD instruction,
3302 ;; so look for MUL in the disassembly. It's a terrible KLUDGE,
3303 ;; but it works.
3304 #+(or x86 x86-64)
3305 (assert (and (not (search "MUL" disassembly1))
3306 (not (search "MUL" disassembly2))))
3307 (assert (eql result (funcall fun1 arg)))
3308 (assert (eql result (funcall fun2 arg))))))
3309 (test `(lambda (x) (declare (single-float x)) (* x 2)) 123.45 246.9)
3310 (test `(lambda (x) (declare (single-float x)) (* x 2.0)) 543.21 1086.42)
3311 (test `(lambda (x) (declare (single-float x)) (* x 2.0d0)) 42.00 84.d0)
3312 (test `(lambda (x) (declare (double-float x)) (* x 2)) 123.45d0 246.9d0)
3313 (test `(lambda (x) (declare (double-float x)) (* x 2.0)) 543.21d0 1086.42d0)
3314 (test `(lambda (x) (declare (double-float x)) (* x 2.0d0)) 42.0d0 84.0d0)))
3315
3316 (with-test (:name :bug-392203)
3317 ;; Used to hit an AVER in COMVERT-MV-CALL.
3318 (assert (zerop
3319 (funcall
3320 (compile nil
3321 `(lambda ()
3322 (flet ((k (&rest x) (declare (ignore x)) 0))
3323 (multiple-value-call #'k #'k))))))))
3324
3325 (with-test (:name :allocate-closures-failing-aver)
3326 (let ((f (compile nil `(lambda ()
3327 (labels ((k (&optional x) #'k)))))))
3328 (assert (null (funcall f)))))
3329
3330 (with-test (:name :flush-vector-creation)
3331 (let ((f (compile nil `(lambda ()
3332 (dotimes (i 1024)
3333 (vector i i i))
3334 t))))
3335 (ctu:assert-no-consing (funcall f))))
3336
3337 (with-test (:name :array-type-predicates)
3338 (dolist (et (list* '(integer -1 200) '(integer -256 1)
3339 '(integer 0 128)
3340 '(integer 0 (128))
3341 '(double-float 0d0 (1d0))
3342 '(single-float (0s0) (1s0))
3343 '(or (eql 1d0) (eql 10d0))
3344 '(member 1 2 10)
3345 '(complex (member 10 20))
3346 '(complex (member 10d0 20d0))
3347 '(complex (member 10s0 20s0))
3348 '(or integer double-float)
3349 '(mod 1)
3350 '(member #\a #\b)
3351 '(eql #\a)
3352 #+sb-unicode 'extended-char
3353 #+sb-unicode '(eql #\cyrillic_small_letter_yu)
3354 sb-kernel::*specialized-array-element-types*))
3355 (when et
3356 (let* ((v (make-array 3 :element-type et))
3357 (fun (compile nil `(lambda ()
3358 (list
3359 (if (typep ,v '(simple-array ,et (*)))
3360 :good
3361 :bad)
3362 (if (typep (elt ,v 0) '(simple-array ,et (*)))
3363 :bad
3364 :good))))))
3365 (assert (equal '(:good :good) (funcall fun)))))))
3366
3367 (with-test (:name :truncate-float)
3368 (let ((s (compile nil `(lambda (x)
3369 (declare (single-float x))
3370 (truncate x))))
3371 (d (compile nil `(lambda (x)
3372 (declare (double-float x))
3373 (truncate x))))
3374 (s-inlined (compile nil '(lambda (x)
3375 (declare (type (single-float 0.0s0 1.0s0) x))
3376 (truncate x))))
3377 (d-inlined (compile nil '(lambda (x)
3378 (declare (type (double-float 0.0d0 1.0d0) x))
3379 (truncate x)))))
3380 ;; Check that there is no generic arithmetic
3381 (assert (not (search "GENERIC"
3382 (with-output-to-string (out)
3383 (disassemble s :stream out)))))
3384 (assert (not (search "GENERIC"
3385 (with-output-to-string (out)
3386 (disassemble d :stream out)))))
3387 ;; Check that we actually inlined the call when we were supposed to.
3388 (assert (not (search "UNARY-TRUNCATE"
3389 (with-output-to-string (out)
3390 (disassemble s-inlined :stream out)))))
3391 (assert (not (search "UNARY-TRUNCATE"
3392 (with-output-to-string (out)
3393 (disassemble d-inlined :stream out)))))))
3394
3395 (with-test (:name :make-array-unnamed-dimension-leaf)
3396 (let ((fun (compile nil `(lambda (stuff)
3397 (make-array (map 'list 'length stuff))))))
3398 (assert (equalp #2A((0 0 0) (0 0 0))
3399 (funcall fun '((1 2) (1 2 3)))))))
3400
3401 (with-test (:name :fp-decoding-funs-not-flushable-in-safe-code)
3402 (dolist (name '(float-sign float-radix float-digits float-precision decode-float
3403 integer-decode-float))
3404 (let ((fun (compile nil `(lambda (x)
3405 (declare (optimize safety))
3406 (,name x)
3407 nil))))
3408 (flet ((test (arg)
3409 (unless (eq :error
3410 (handler-case
3411 (funcall fun arg)
3412 (error () :error)))
3413 (error "(~S ~S) did not error"
3414 name arg))))
3415 ;; No error
3416 (funcall fun 1.0)
3417 ;; Error
3418 (test 'not-a-float)
3419 (when (member name '(decode-float integer-decode-float))
3420 (test sb-ext:single-float-positive-infinity))))))
3421
3422 (with-test (:name :sap-ref-16)
3423 (let* ((fun (compile nil `(lambda (x y)
3424 (declare (type sb-sys:system-area-pointer x)
3425 (type (integer 0 100) y))
3426 (sb-sys:sap-ref-16 x (+ 4 y)))))
3427 (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
3428 '(simple-array (unsigned-byte 8) (*))))
3429 (sap (sb-sys:vector-sap vector))
3430 (ret (funcall fun sap 0)))
3431 ;; test for either endianness
3432 (assert (or (= ret (+ (* 5 256) 4)) (= ret (+ (* 4 256) 5))))))
3433
3434 (with-test (:name :coerce-type-warning)
3435 (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
3436 (signed-byte 8) (signed-byte 16) (signed-byte 32)))
3437 (multiple-value-bind (fun warningsp failurep)
3438 (compile nil `(lambda (x)
3439 (declare (type simple-vector x))
3440 (coerce x '(vector ,type))))
3441 (assert (null warningsp))
3442 (assert (null failurep))
3443 (assert (typep (funcall fun #(1)) `(simple-array ,type (*)))))))
3444
3445 (with-test (:name :truncate-double-float)
3446 (let ((fun (compile nil `(lambda (x)
3447 (multiple-value-bind (q r)
3448 (truncate (coerce x 'double-float))
3449 (declare (type unsigned-byte q)
3450 (type double-float r))
3451 (list q r))))))
3452 (assert (equal (funcall fun 1.0d0) '(1 0.0d0)))))
3453
3454 (with-test (:name :set-slot-value-no-warning)
3455 (let ((notes 0))
3456 (handler-bind ((warning #'error)
3457 (sb-ext:compiler-note (lambda (c)
3458 (declare (ignore c))
3459 (incf notes))))
3460 (compile nil `(lambda (x y)
3461 (declare (optimize speed safety))
3462 (setf (slot-value x 'bar) y))))
3463 (assert (= 1 notes))))
3464
3465 (with-test (:name :concatenate-string-opt)
3466 (flet ((test (type grep)
3467 (let* ((fun (compile nil `(lambda (a b c d e)
3468 (concatenate ',type a b c d e))))
3469 (args '("foo" #(#\.) "bar" (#\-) "quux"))
3470 (res (apply fun args)))
3471 (assert (search grep (with-output-to-string (out)
3472 (disassemble fun :stream out))))
3473 (assert (equal (apply #'concatenate type args)
3474 res))
3475 (assert (typep res type)))))
3476 (test 'string "%CONCATENATE-TO-STRING")
3477 (test 'simple-string "%CONCATENATE-TO-STRING")
3478 (test 'base-string "%CONCATENATE-TO-BASE-STRING")
3479 (test 'simple-base-string "%CONCATENATE-TO-BASE-STRING")))
3480
3481 (with-test (:name :satisfies-no-local-fun)
3482 (let ((fun (compile nil `(lambda (arg)
3483 (labels ((local-not-global-bug (x)
3484 t)
3485 (bar (x)
3486 (typep x '(satisfies local-not-global-bug))))
3487 (bar arg))))))
3488 (assert (eq 'local-not-global-bug
3489 (handler-case
3490 (funcall fun 42)
3491 (undefined-function (c)
3492 (cell-error-name c)))))))
3493
3494 ;;; Prior to 1.0.32.x, dumping a fasl with a function with a default
3495 ;;; argument that is a complex structure (needing make-load-form
3496 ;;; processing) failed an AVER. The first attempt at a fix caused
3497 ;;; doing the same in-core to break.
3498 (with-test (:name :bug-310132)
3499 (compile nil '(lambda (&optional (foo #p"foo/bar")))))
3500
3501 (with-test (:name :bug-309129)
3502 (let* ((src '(lambda (v) (values (svref v 0) (vector-pop v))))
3503 (warningp nil)
3504 (fun (handler-bind ((warning (lambda (c)
3505 (setf warningp t) (muffle-warning c))))
3506 (compile nil src))))
3507 (assert warningp)
3508 (handler-case (funcall fun #(1))
3509 (type-error (c)
3510 ;; we used to put simply VECTOR into EXPECTED-TYPE, rather
3511 ;; than explicitly (AND VECTOR (NOT SIMPLE-ARRAY))
3512 (assert (not (typep (type-error-datum c) (type-error-expected-type c)))))
3513 (:no-error (&rest values)
3514 (declare (ignore values))
3515 (error "no error")))))
3516
3517 (with-test (:name :unary-round-type-derivation)
3518 (let* ((src '(lambda (zone)
3519 (multiple-value-bind (h m) (truncate (abs zone) 1.0)
3520 (declare (ignore h))
3521 (round (* 60.0 m)))))
3522 (fun (compile nil src)))
3523 (assert (= (funcall fun 0.5) 30))))
3524
3525 (with-test (:name :bug-525949)
3526 (let* ((src '(lambda ()
3527 (labels ((always-one () 1)
3528 (f (z)
3529 (let ((n (funcall z)))
3530 (declare (fixnum n))
3531 (the double-float (expt n 1.0d0)))))
3532 (f #'always-one))))
3533 (warningp nil)
3534 (fun (handler-bind ((warning (lambda (c)
3535 (setf warningp t) (muffle-warning c))))
3536 (compile nil src))))
3537 (assert (not warningp))
3538 (assert (= 1.0d0 (funcall fun)))))
3539
3540 (with-test (:name :%array-data-vector-type-derivation)
3541 (let* ((f (compile nil
3542 `(lambda (ary)
3543 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3544 (setf (aref ary 0 0) 0))))
3545 (text (with-output-to-string (s)
3546 (disassemble f :stream s))))
3547 (assert (not (search "OBJECT-NOT-SIMPLE-ARRAY-UNSIGNED-BYTE-32-ERROR" text)))))
3548
3549 (with-test (:name :array-storage-vector-type-derivation)
3550 (let ((f (compile nil
3551 `(lambda (ary)
3552 (declare (type (simple-array (unsigned-byte 32) (3 3)) ary))
3553 (ctu:compiler-derived-type (array-storage-vector ary))))))
3554 (assert (equal '(simple-array (unsigned-byte 32) (9))
3555 (funcall f (make-array '(3 3) :element-type '(unsigned-byte 32)))))))
3556
3557 (with-test (:name :bug-523612)
3558 (let ((fun
3559 (compile nil
3560 `(lambda (&key toff)
3561 (make-array 3 :element-type 'double-float
3562 :initial-contents
3563 (if toff (list toff 0d0 0d0) (list 0d0 0d0 0d0)))))))
3564 (assert (equalp (vector 0.0d0 0.0d0 0.0d0) (funcall fun :toff nil)))
3565 (assert (equalp (vector 2.3d0 0.0d0 0.0d0) (funcall fun :toff 2.3d0)))))
3566
3567 (with-test (:name :bug-309788)
3568 (let ((fun
3569 (compile nil
3570 `(lambda (x)
3571 (declare (optimize speed))
3572 (let ((env nil))
3573 (typep x 'fixnum env))))))
3574 (assert (not (ctu:find-named-callees fun)))))
3575
3576 (with-test (:name :bug-309124)
3577 (let ((fun
3578 (compile nil
3579 `(lambda (x)
3580 (declare (integer x))
3581 (declare (optimize speed))
3582 (cond ((typep x 'fixnum)
3583 "hala")
3584 ((typep x 'fixnum)
3585 "buba")
3586 ((typep x 'bignum)
3587 "hip")
3588 (t
3589 "zuz"))))))
3590 (assert (equal (list "hala" "hip")
3591 (sort (ctu:find-code-constants fun :type 'string)
3592 #'string<)))))
3593
3594 (with-test (:name :bug-316078)
3595 (let ((fun
3596 (compile nil
3597 `(lambda (x)
3598 (declare (type (and simple-bit-vector (satisfies bar)) x)
3599 (optimize speed))
3600 (elt x 5)))))
3601 (assert (not (ctu:find-named-callees fun)))
3602 (assert (= 1 (funcall fun #*000001)))
3603 (assert (= 0 (funcall fun #*000010)))))
3604
3605 (with-test (:name :mult-by-one-in-float-acc-zero)
3606 (assert (eql 1.0 (funcall (compile nil `(lambda (x)
3607 (declare (optimize (sb-c::float-accuracy 0)))
3608 (* x 1.0)))
3609 1)))
3610 (assert (eql -1.0 (funcall (compile nil `(lambda (x)
3611 (declare (optimize (sb-c::float-accuracy 0)))
3612 (* x -1.0)))
3613 1)))
3614 (assert (eql 1.0d0 (funcall (compile nil `(lambda (x)
3615 (declare (optimize (sb-c::float-accuracy 0)))
3616 (* x 1.0d0)))
3617 1)))
3618 (assert (eql -1.0d0 (funcall (compile nil `(lambda (x)
3619 (declare (optimize (sb-c::float-accuracy 0)))
3620 (* x -1.0d0)))
3621 1))))
3622
3623 (with-test (:name :dotimes-non-integer-counter-value)
3624 (assert-error (dotimes (i 8.6)) type-error))
3625
3626 (with-test (:name :bug-454681)
3627 ;; This used to break due to reference to a dead lambda-var during
3628 ;; inline expansion.
3629 (assert (compile nil
3630 `(lambda ()
3631 (multiple-value-bind (iterator+977 getter+978)
3632 (does-not-exist-but-does-not-matter)
3633 (flet ((iterator+976 ()
3634 (funcall iterator+977)))
3635 (declare (inline iterator+976))
3636 (let ((iterator+976 #'iterator+976))
3637 (funcall iterator+976))))))))
3638
3639 (with-test (:name :complex-float-local-fun-args)
3640 ;; As of 1.0.27.14, the lambda below failed to compile due to the
3641 ;; compiler attempting to pass unboxed complex floats to Z and the
3642 ;; MOVE-ARG method not expecting the register being used as a
3643 ;; temporary frame pointer. Reported by sykopomp in #lispgames,
3644 ;; reduced test case provided by _3b`.
3645 (compile nil '(lambda (a)
3646 (labels ((z (b c)
3647 (declare ((complex double-float) b c))
3648 (* b (z b c))))
3649 (loop for i below 10 do
3650 (setf a (z a a)))))))
3651
3652 (with-test (:name :bug-309130)
3653 (assert (eq :warning
3654 (handler-case
3655 (compile nil `(lambda () (svref (make-array 8 :adjustable t) 1)))
3656 ((and warning (not style-warning)) ()
3657 :warning))))
3658 (assert (eq :warning
3659 (handler-case
3660 (compile nil `(lambda (x)
3661 (declare (optimize (debug 0)))
3662 (declare (type vector x))
3663 (list (fill-pointer x) (svref x 1))))
3664 ((and warning (not style-warning)) ()
3665 :warning))))
3666 (assert (eq :warning
3667 (handler-case
3668 (compile nil `(lambda (x)
3669 (list (vector-push (svref x 0) x))))
3670 ((and warning (not style-warning)) ()
3671 :warning))))
3672 (assert (eq :warning
3673 (handler-case
3674 (compile nil `(lambda (x)
3675 (list (vector-push-extend (svref x 0) x))))
3676 ((and warning (not style-warning)) ()
3677 :warning)))))
3678
3679 (with-test (:name :bug-646796)
3680 (assert 42
3681 (funcall
3682 (compile nil
3683 `(lambda ()
3684 (load-time-value (the (values fixnum) 42)))))))
3685
3686 (with-test (:name :bug-654289)
3687 ;; Test that compile-times don't explode when quoted constants
3688 ;; get big.
3689 (labels ((time-n (n)
3690 (gc :full t) ; Let's not confuse the issue with GC
3691 (let* ((tree (make-tree (expt 10 n) nil))
3692 (t0 (get-internal-run-time))
3693 (f (compile nil `(lambda (x) (eq x (quote ,tree)))))
3694 (t1 (get-internal-run-time)))
3695 (assert (funcall f tree))
3696 (- t1 t0)))
3697 (make-tree (n acc)
3698 (cond ((zerop n) acc)
3699 (t (make-tree (1- n) (cons acc acc))))))
3700 (let* ((times (loop for i from 0 upto 4
3701 collect (time-n i)))
3702 (max-small (reduce #'max times :end 3))
3703 (max-big (reduce #'max times :start 3)))
3704 ;; This way is hopefully fairly CPU-performance insensitive.
3705 (unless (> (+ (truncate internal-time-units-per-second 10)
3706 (* 2 max-small))
3707 max-big)
3708 (error "Bad scaling or test? ~S" times)))))
3709
3710 (with-test (:name :bug-309063)
3711 (let ((fun (compile nil `(lambda (x)
3712 (declare (type (integer 0 0) x))
3713 (ash x 100)))))
3714 (assert (zerop (funcall fun 0)))))
3715
3716 (with-test (:name :bug-655872)
3717 (let ((f (compile nil `(lambda (x)
3718 (declare (optimize (safety 3)))
3719 (aref (locally (declare (optimize (safety 0)))
3720 (coerce x '(simple-vector 128)))
3721 60))))
3722 (long (make-array 100 :element-type 'fixnum)))
3723 (dotimes (i 100)
3724 (setf (aref long i) i))
3725 ;; 1. COERCE doesn't check the length in unsafe code.
3726 (assert (eql 60 (funcall f long)))
3727 ;; 2. The compiler doesn't trust the length from COERCE
3728 (assert (eq :caught
3729 (handler-case
3730 (funcall f (list 1 2 3))
3731 (sb-int:invalid-array-index-error (e)
3732 (assert (eql 60 (type-error-datum e)))
3733 (assert (equal '(integer 0 (3)) (type-error-expected-type e)))
3734 :caught))))))
3735
3736 (with-test (:name :bug-655203-regression)
3737 (let ((fun (compile nil
3738 `(LAMBDA (VARIABLE)
3739 (LET ((CONTINUATION
3740 (LAMBDA
3741 (&OPTIONAL DUMMY &REST OTHER)
3742 (DECLARE (IGNORE OTHER))
3743 (PRIN1 DUMMY)
3744 (PRIN1 VARIABLE))))
3745 (FUNCALL CONTINUATION (LIST 1 2)))))))
3746 ;; This used to signal a bogus type-error.
3747 (assert (equal (with-output-to-string (*standard-output*)
3748 (funcall fun t))
3749 "(1 2)T"))))
3750
3751 (with-test (:name :constant-concatenate-compile-time)
3752 (flet ((make-lambda (n)
3753 `(lambda (x)
3754 (declare (optimize (speed 3) (space 0)))
3755 (concatenate 'string x ,(make-string n)))))
3756 (let* ((l0 (make-lambda 1))
3757 (l1 (make-lambda 10))
3758 (l2 (make-lambda 100))
3759 (l3 (make-lambda 1000))
3760 (t0 (get-internal-run-time))
3761 (f0 (compile nil l0))
3762 (t1 (get-internal-run-time))
3763 (f1 (compile nil l1))
3764 (t2 (get-internal-run-time))
3765 (f2 (compile nil l2))
3766 (t3 (get-internal-run-time))
3767 (f3 (compile nil l3))
3768 (t4 (get-internal-run-time))
3769 (d0 (- t1 t0))
3770 (d1 (- t2 t1))
3771 (d2 (- t3 t2))
3772 (d3 (- t4 t3))
3773 (short-avg (/ (+ d0 d1 d2) 3)))
3774 (assert (and f1 f2 f3))
3775 (assert (< d3 (* 10 short-avg))))))
3776
3777 (with-test (:name :bug-384892)
3778 (assert (equal
3779 ;; The assertion that BOOLEAN becomes (MEMBER T NIL)
3780 ;; is slightly brittle, but the rest of the
3781 ;; assertion is ok.
3782 '(function (fixnum fixnum &key (:k1 (member t nil)))
3783 (values (member t) &optional))
3784 (sb-kernel:%simple-fun-type
3785 (compile nil `(lambda (x y &key k1)
3786 (declare (fixnum x y))
3787 (declare (boolean k1))
3788 (declare (ignore x y k1))
3789 t))))))
3790
3791 (with-test (:name :bug-309448)
3792 ;; Like all tests trying to verify that something doesn't blow up
3793 ;; compile-times this is bound to be a bit brittle, but at least
3794 ;; here we try to establish a decent baseline.
3795 (labels ((time-it (lambda want &optional times)
3796 (gc :full t) ; let's keep GCs coming from other code out...
3797 (let* ((start (get-internal-run-time))
3798 (iterations 0)
3799 (fun (if times
3800 (loop repeat times
3801 for result = (compile nil lambda)
3802 finally (return result))
3803 (loop for result = (compile nil lambda)
3804 do (incf iterations)
3805 until (> (get-internal-run-time) (+ start 10))
3806 finally (return result))))
3807 (end (get-internal-run-time))
3808 (got (funcall fun)))
3809 (unless (eql want got)
3810 (error "wanted ~S, got ~S" want got))
3811 (values (- end start) iterations)))
3812 (test-it (simple result1 complex result2)
3813 (multiple-value-bind (time-simple iterations)
3814 (time-it simple result1)
3815 (assert (>= (* 10 (1+ time-simple))
3816 (time-it complex result2 iterations))))))
3817 ;; This is mostly identical as the next one, but doesn't create
3818 ;; hairy unions of numeric types.
3819 (test-it `(lambda ()
3820 (labels ((bar (baz bim)
3821 (let ((n (+ baz bim)))
3822 (* n (+ n 1) bim))))
3823 (let ((a (bar 1 1))
3824 (b (bar 1 1))
3825 (c (bar 1 1)))
3826 (- (+ a b) c))))
3827 6
3828 `(lambda ()
3829 (labels ((bar (baz bim)
3830 (let ((n (+ baz bim)))
3831 (* n (+ n 1) bim))))
3832 (let ((a (bar 1 1))
3833 (b (bar 1 5))
3834 (c (bar 1 15)))
3835 (- (+ a b) c))))
3836 -3864)
3837 (test-it `(lambda ()
3838 (labels ((sum-d (n)
3839 (let ((m (truncate 999 n)))
3840 (/ (* n m (1+ m)) 2))))
3841 (- (+ (sum-d 3)
3842 (sum-d 3))
3843 (sum-d 3))))
3844 166833
3845 `(lambda ()
3846 (labels ((sum-d (n)
3847 (let ((m (truncate 999 n)))
3848 (/ (* n m (1+ m)) 2))))
3849 (- (+ (sum-d 3)
3850 (sum-d 5))
3851 (sum-d 15))))
3852 233168)))
3853
3854 (with-test (:name :regression-1.0.44.34)
3855 (compile nil '(lambda (z &rest args)
3856 (declare (dynamic-extent args))
3857 (flet ((foo (w v) (list v w)))
3858 (setq z 0)
3859 (flet ((foo ()
3860 (foo z args)))
3861 (declare (sb-int:truly-dynamic-extent #'foo))
3862 (call #'foo nil))))))
3863
3864 (with-test (:name :bug-713626)
3865 (let ((f (eval '(constantly 42))))
3866 (handler-bind ((warning #'error))
3867 (assert (= 42 (funcall (compile nil `(lambda () (funcall ,f 1 2 3)))))))))
3868
3869 (with-test (:name :known-fun-allows-other-keys)
3870 (handler-bind ((warning #'error))
3871 (funcall (compile nil '(lambda () (directory "." :allow-other-keys t))))
3872 (funcall (compile nil `(lambda () (directory "." :bar t :allow-other-keys t))))))
3873
3874 (with-test (:name :bug-551227)
3875 ;; This function causes constraint analysis to perform a
3876 ;; ref-substitution that alters the A referred to in (G A) at in the
3877 ;; consequent of the IF to refer to be NUMBER, from the
3878 ;; LET-converted inline-expansion of MOD. This leads to attempting
3879 ;; to CLOSE-OVER a variable that simply isn't in scope when it is
3880 ;; referenced.
3881 (compile nil '(lambda (a)
3882 (if (let ((s a))
3883 (block :block
3884 (map nil
3885 (lambda (e)
3886 (return-from :block
3887 (f (mod a e))))
3888 s)))
3889 (g a)))))
3890
3891 (with-test (:name :funcall-lambda-inlined)
3892 (assert (not
3893 (ctu:find-code-constants
3894 (compile nil
3895 `(lambda (x y)
3896 (+ x (funcall (lambda (z) z) y))))
3897 :type 'function))))
3898
3899 (with-test (:name :bug-720382)
3900 (let ((w 0))
3901 (let ((f
3902 (handler-bind (((and warning (not style-warning))
3903 (lambda (c) (incf w))))
3904 (compile nil `(lambda (b) ((lambda () b) 1))))))
3905 (assert (= w 1))
3906 (assert (eq :error
3907 (handler-case (funcall f 0)
3908 (error () :error)))))))
3909
3910 (with-test (:name :multiple-args-to-function)
3911 (let ((form `(flet ((foo (&optional (x 13)) x))
3912 (funcall (function foo 42))))
3913 #+sb-eval (*evaluator-mode* :interpret))
3914 #+sb-eval
3915 (assert (eq :error
3916 (handler-case (eval form)
3917 (error () :error))))
3918 (multiple-value-bind (fun warn fail)
3919 (compile nil `(lambda () ,form))
3920 (assert (and warn fail))
3921 (assert (eq :error
3922 (handler-case (funcall fun)
3923 (error () :error)))))))
3924
3925 ;;; This doesn't test LVAR-FUN-IS directly, but captures it
3926 ;;; pretty accurately anyways.
3927 (with-test (:name :lvar-fun-is)
3928 (dolist (fun (list
3929 (lambda (x) (member x x :test #'eq))
3930 (lambda (x) (member x x :test 'eq))
3931 (lambda (x) (member x x :test #.#'eq))))
3932 (assert (equal (list #'sb-kernel:%member-eq)
3933 (ctu:find-named-callees fun))))
3934 (dolist (fun (list
3935 (lambda (x)
3936 (declare (notinline eq))
3937 (member x x :test #'eq))
3938 (lambda (x)
3939 (declare (notinline eq))
3940 (member x x :test 'eq))
3941 (lambda (x)
3942 (declare (notinline eq))
3943 (member x x :test #.#'eq))))
3944 (assert (member #'sb-kernel:%member-test
3945 (ctu:find-named-callees fun)))))
3946
3947 (with-test (:name :delete-to-delq-opt)
3948 (dolist (fun (list (lambda (x y)
3949 (declare (list y))
3950 (delete x y :test #'eq))
3951 (lambda (x y)
3952 (declare (fixnum x) (list y))
3953 (delete x y))
3954 (lambda (x y)
3955 (declare (symbol x) (list y))
3956 (delete x y :test #'eql))))
3957 (assert (equal (list #'sb-int:delq)
3958 (ctu:find-named-callees fun)))))
3959
3960 (with-test (:name :bug-767959)
3961 ;; This used to signal an error.
3962 (compile nil `(lambda ()
3963 (declare (optimize sb-c:store-coverage-data))
3964 (assoc
3965 nil
3966 '((:ordinary . ordinary-lambda-list))))))
3967
3968 ;; This test failed formerly because the source transform of TYPEP would be
3969 ;; disabled when storing coverage data, thus giving no semantics to
3970 ;; expressions such as (TYPEP x 'INTEGER). The compiler could therefore not
3971 ;; prove that the else clause of the IF is unreachable - which it must be
3972 ;; since X is asserted to be fixnum. The conflicting requirement on X
3973 ;; that it be acceptable to LENGTH signaled a full warning.
3974 ;; Nobody on sbcl-devel could remember why the source transform was disabled,
3975 ;; but nobody disagreed with undoing the disabling.
3976 (with-test (:name :sb-cover-and-typep)
3977 (multiple-value-bind (fun warnings-p failure-p)
3978 (compile nil '(lambda (x)
3979 (declare (fixnum x) (optimize sb-c:store-coverage-data))
3980 (if (typep x 'integer) x (length x))))
3981 (assert (and fun (not warnings-p) (not failure-p)))))
3982
3983 (with-test (:name :member-on-long-constant-list)
3984 ;; This used to blow stack with a sufficiently long list.
3985 (let ((cycle (list t)))
3986 (nconc cycle cycle)
3987 (compile nil `(lambda (x)
3988 (member x ',cycle)))))
3989
3990 (with-test (:name :bug-722734)
3991 (assert-error
3992 (funcall (compile
3993 nil
3994 '(lambda ()
3995 (eql (make-array 6)
3996 (list unbound-variable-1 unbound-variable-2)))))))
3997
3998 (with-test (:name :bug-771673)
3999 (assert (equal `(the foo bar) (macroexpand `(truly-the foo bar))))
4000 ;; Make sure the compiler doesn't use THE, and check that setf-expansions
4001 ;; work.
4002 (let ((f (compile nil `(lambda (x y)
4003 (setf (truly-the fixnum (car x)) y)))))
4004 (let* ((cell (cons t t)))
4005 (funcall f cell :ok)
4006 (assert (equal '(:ok . t) cell)))))
4007
4008 (with-test (:name (:bug-793771 +))
4009 (let ((f (compile nil `(lambda (x y)
4010 (declare (type (single-float 2.0) x)
4011 (type (single-float (0.0)) y))
4012 (+ x y)))))
4013 (assert (equal `(function ((single-float 2.0) (single-float (0.0)))
4014 (values (single-float 2.0) &optional))
4015 (sb-kernel:%simple-fun-type f)))))
4016
4017 (with-test (:name (:bug-793771 -))
4018 (let ((f (compile nil `(lambda (x y)
4019 (declare (type (single-float * 2.0) x)
4020 (type (single-float (0.0)) y))
4021 (- x y)))))
4022 (assert (equal `(function ((single-float * 2.0) (single-float (0.0)))
4023 (values (single-float * 2.0) &optional))
4024 (sb-kernel:%simple-fun-type f)))))
4025
4026 (with-test (:name (:bug-793771 *))
4027 (let ((f (compile nil `(lambda (x)
4028 (declare (type (single-float (0.0)) x))
4029 (* x 0.1)))))
4030 (assert (equal `(function ((single-float (0.0)))
4031 (values (or (member 0.0) (single-float (0.0))) &optional))
4032 (sb-kernel:%simple-fun-type f)))))
4033
4034 (with-test (:name (:bug-793771 /))
4035 (let ((f (compile nil `(lambda (x)
4036 (declare (type (single-float (0.0)) x))
4037 (/ x 3.0)))))
4038 (assert (equal `(function ((single-float (0.0)))
4039 (values (or (member 0.0) (single-float (0.0))) &optional))
4040 (sb-kernel:%simple-fun-type f)))))
4041
4042 (with-test (:name (:bug-486812 single-float))
4043 (compile nil `(lambda ()
4044 (sb-kernel:make-single-float -1))))
4045
4046 (with-test (:name (:bug-486812 double-float))
4047 (compile nil `(lambda ()
4048 (sb-kernel:make-double-float -1 0))))
4049
4050 (with-test (:name :bug-729765)
4051 (compile nil `(lambda (a b)
4052 (declare ((integer 1 1) a)
4053 ((integer 0 1) b)
4054 (optimize debug))
4055 (lambda () (< b a)))))
4056
4057 ;; Actually tests the assembly of RIP-relative operands to comparison
4058 ;; functions (one of the few x86 instructions that have extra bytes
4059 ;; *after* the mem operand's effective address, resulting in a wrong
4060 ;; offset).
4061 (with-test (:name :cmpps)
4062 (let ((foo (compile nil `(lambda (x)
4063 (= #C(2.0 3.0) (the (complex single-float) x))))))
4064 (assert (funcall foo #C(2.0 3.0)))
4065 (assert (not (funcall foo #C(1.0 2.0))))))
4066
4067 (with-test (:name :cmppd)
4068 (let ((foo (compile nil `(lambda (x)
4069 (= #C(2d0 3d0) (the (complex double-float) x))))))
4070 (assert (funcall foo #C(2d0 3d0)))
4071 (assert (not (funcall foo #C(1d0 2d0))))))
4072
4073 (with-test (:name :lvar-externally-checkable-type-nil)
4074 ;; Used to signal a BUG during compilation.
4075 (let ((fun (compile nil `(lambda (a) (parse-integer "12321321" (the (member :start) a) 1)))))
4076 (multiple-value-bind (i p) (funcall fun :start)
4077 (assert (= 2321321 i))
4078 (assert (= 8 p)))
4079 (multiple-value-bind (i e) (ignore-errors (funcall fun :end))
4080 (assert (not i))
4081 (assert (typep e 'type-error)))))
4082
4083 (with-test (:name :simple-type-error-in-bound-propagation-a)
4084 (compile nil `(lambda (i)
4085 (declare (unsigned-byte i))
4086 (expt 10 (expt 7 (- 2 i))))))
4087
4088 (with-test (:name :simple-type-error-in-bound-propagation-b)
4089 (assert (equal `(FUNCTION (UNSIGNED-BYTE)
4090 (VALUES (SINGLE-FLOAT -1F0 1F0) &OPTIONAL))
4091 (sb-kernel:%simple-fun-type
4092 (compile nil `(lambda (i)
4093 (declare (unsigned-byte i))
4094 (cos (expt 10 (+ 4096 i)))))))))
4095
4096 (with-test (:name :fixed-%more-arg-values)
4097 (let ((fun (compile nil `(lambda (&rest rest)
4098 (declare (optimize (safety 0)))
4099 (apply #'cons rest)))))
4100 (assert (equal '(car . cdr) (funcall fun 'car 'cdr)))))
4101
4102 (with-test (:name :bug-826970)
4103 (let ((fun (compile nil `(lambda (a b c)
4104 (declare (type (member -2 1) b))
4105 (array-in-bounds-p a 4 b c)))))
4106 (assert (funcall fun (make-array '(5 2 2)) 1 1))))
4107
4108 (with-test (:name :bug-826971)
4109 (let* ((foo "foo")
4110 (fun (compile nil `(lambda (p1 p2)
4111 (schar (the (eql ,foo) p1) p2)))))
4112 (assert (eql #\f (funcall fun foo 0)))))
4113
4114 (with-test (:name :bug-738464)
4115 (multiple-value-bind (fun warn fail)
4116 (compile nil `(lambda ()
4117 (flet ((foo () 42))
4118 (declare (ftype non-function-type foo))
4119 (foo))))
4120 (assert (eql 42 (funcall fun)))
4121 (assert (and warn (not fail)))))
4122
4123 (with-test (:name :bug-832005)
4124 (let ((fun (compile nil `(lambda (x)
4125 (declare (type (complex single-float) x))
4126 (+ #C(0.0 1.0) x)))))
4127 (assert (= (funcall fun #C(1.0 2.0))
4128 #C(1.0 3.0)))))
4129
4130 ;; A refactoring 1.0.12.18 caused lossy computation of primitive
4131 ;; types for member types.
4132 (with-test (:name :member-type-primitive-type)
4133 (let ((fun (compile nil `(lambda (p1 p2 p3)
4134 (if p1
4135 (the (member #c(1.2d0 1d0)) p2)
4136 (the (eql #c(1.0 1.0)) p3))))))
4137 (assert (eql (funcall fun 1 #c(1.2d0 1d0) #c(1.0 1.0))
4138 #c(1.2d0 1.0d0)))))
4139
4140 ;; Fall-through jump elimination made control flow fall through to trampolines.
4141 ;; Reported by Eric Marsden on sbcl-devel@ 2011.10.26, with a test case
4142 ;; reproduced below (triggered a corruption warning and a memory fault).
4143 (with-test (:name :bug-883500)
4144 (funcall (compile nil `(lambda (a)
4145 (declare (type (integer -50 50) a))
4146 (declare (optimize (speed 0)))
4147 (mod (mod a (min -5 a)) 5)))
4148 1))
4149
4150 ;; Test for literals too large for the ISA (e.g. (SIGNED-BYTE 13) on SPARC).
4151 #+sb-unicode
4152 (with-test (:name :bug-883519)
4153 (compile nil `(lambda (x)
4154 (declare (type character x))
4155 (eql x #\U0010FFFF))))
4156
4157 ;; Wide fixnum platforms had buggy address computation in atomic-incf/aref
4158 (with-test (:name :bug-887220)
4159 (let ((incfer (compile
4160 nil
4161 `(lambda (vector index)
4162 (declare (type (simple-array sb-ext:word (4))
4163 vector)
4164 (type (mod 4) index))
4165 (sb-ext:atomic-incf (aref vector index) 1)
4166 vector))))
4167 (assert (equalp (funcall incfer
4168 (make-array 4 :element-type 'sb-ext:word
4169 :initial-element 0)
4170 1)
4171 #(0 1 0 0)))))
4172
4173 (with-test (:name :catch-interferes-with-debug-names)
4174 (let ((fun (funcall
4175 (compile nil
4176 `(lambda ()
4177 (catch 'out
4178 (flet ((foo ()
4179 (throw 'out (lambda () t))))
4180 (foo))))))))
4181 (assert (equal '(lambda () :in foo) (sb-kernel:%fun-name fun)))))
4182
4183 (with-test (:name :interval-div-signed-zero)
4184 (let ((fun (compile nil
4185 `(Lambda (a)
4186 (declare (type (member 0 -272413371076) a))
4187 (ffloor (the number a) -63243.127451934015d0)))))
4188 (multiple-value-bind (q r) (funcall fun 0)
4189 (assert (eql -0d0 q))
4190 (assert (eql 0d0 r)))))
4191
4192 (with-test (:name :non-constant-keyword-typecheck)
4193 (let ((fun (compile nil
4194 `(lambda (p1 p3 p4)
4195 (declare (type keyword p3))
4196 (tree-equal p1 (cons 1 2) (the (member :test) p3) p4)))))
4197 (assert (funcall fun (cons 1.0 2.0) :test '=))))
4198
4199 (with-test (:name :truncate-wild-values)
4200 (multiple-value-bind (q r)
4201 (handler-bind ((warning #'error))
4202 (let ((sb-c::*check-consistency* t))
4203 (funcall (compile nil
4204 `(lambda (a)
4205 (declare (type (member 1d0 2d0) a))
4206 (block return-value-tag
4207 (funcall
4208 (the function
4209 (catch 'debug-catch-tag
4210 (return-from return-value-tag
4211 (progn (truncate a)))))))))
4212 2d0)))
4213 (assert (eql 2 q))
4214 (assert (eql 0d0 r))))
4215
4216 (with-test (:name :boxed-fp-constant-for-full-call)
4217 (let ((fun (compile nil
4218 `(lambda (x)
4219 (declare (double-float x))
4220 (unknown-fun 1.0d0 (+ 1.0d0 x))))))
4221 (assert (equal '(1.0d0) (ctu:find-code-constants fun :type 'double-float)))))
4222
4223 (with-test (:name :only-one-boxed-constant-for-multiple-uses)
4224 (let* ((big (1+ most-positive-fixnum))
4225 (fun (compile nil
4226 `(lambda (x)
4227 (unknown-fun ,big (+ ,big x))))))
4228 (assert (= 1 (length (ctu:find-code-constants fun :type `(eql ,big)))))))
4229
4230 (with-test (:name :fixnum+float-coerces-fixnum
4231 :skipped-on :x86)
4232 (let ((fun (compile nil
4233 `(lambda (x y)
4234 (declare (fixnum x)
4235 (single-float y))
4236 (+ x y)))))
4237 (assert (not (ctu:find-named-callees fun)))
4238 (assert (not (search "GENERIC"
4239 (with-output-to-string (s)
4240 (disassemble fun :stream s)))))))
4241
4242 (with-test (:name :bug-803508)
4243 (compile nil `(lambda ()
4244 (print
4245 (lambda (bar)
4246 (declare (dynamic-extent bar))
4247 (foo bar))))))
4248
4249 (with-test (:name :bug-803508-b)
4250 (compile nil `(lambda ()
4251 (list
4252 (lambda (bar)
4253 (declare (dynamic-extent bar))
4254 (foo bar))))))
4255
4256 (with-test (:name :bug-803508-c)
4257 (compile nil `(lambda ()
4258 (list
4259 (lambda (bar &optional quux)
4260 (declare (dynamic-extent bar quux))
4261 (foo bar quux))))))
4262
4263 (with-test (:name :cprop-with-constant-but-assigned-to-closure-variable)
4264 (compile nil `(lambda (b c d)
4265 (declare (type (integer -20545789 207590862) c))
4266 (declare (type (integer -1 -1) d))
4267 (let ((i (unwind-protect 32 (shiftf d -1))))
4268 (or (if (= d c) 2 (= 3 b)) 4)))))
4269
4270 (with-test (:name :bug-913232)
4271 (compile nil `(lambda (x)
4272 (declare (optimize speed)
4273 (type (or (and (or (integer -100 -50)
4274 (integer 100 200)) (satisfies foo))
4275 (and (or (integer 0 10) (integer 20 30)) a)) x))
4276 x))
4277 (compile nil `(lambda (x)
4278 (declare (optimize speed)
4279 (type (and fixnum a) x))
4280 x)))
4281
4282 (with-test (:name :bug-959687)
4283 (multiple-value-bind (fun warn fail)
4284 (compile nil `(lambda (x)
4285 (case x
4286 (t
4287 :its-a-t)
4288 (otherwise
4289 :somethign-else))))
4290 (assert (and warn fail))
4291 (assert (not (ignore-errors (funcall fun t)))))
4292 (multiple-value-bind (fun warn fail)
4293 (compile nil `(lambda (x)
4294 (case x
4295 (otherwise
4296 :its-an-otherwise)
4297 (t
4298 :somethign-else))))
4299 (assert (and warn fail))
4300 (assert (not (ignore-errors (funcall fun t))))))
4301
4302 (with-test (:name :bug-924276)
4303 (assert (eq :style-warning
4304 (handler-case
4305 (compile nil `(lambda (a)
4306 (cons a (symbol-macrolet ((b 1))
4307 (declare (ignorable a))
4308 :c))))
4309 (style-warning ()
4310 :style-warning)))))
4311
4312 (with-test (:name :bug-974406)
4313 (let ((fun32 (compile nil `(lambda (x)
4314 (declare (optimize speed (safety 0)))
4315 (declare (type (integer 53 86) x))
4316 (logand (+ x 1032791128) 11007078467))))
4317 (fun64 (compile nil `(lambda (x)
4318 (declare (optimize speed (safety 0)))
4319 (declare (type (integer 53 86) x))
4320 (logand (+ x 1152921504606846975)
4321 38046409652025950207)))))
4322 (assert (= (funcall fun32 61) 268574721))
4323 (assert (= (funcall fun64 61) 60)))
4324 (let (result)
4325 (do ((width 5 (1+ width)))
4326 ((= width 130))
4327 (dotimes (extra 4)
4328 (let ((fun (compile nil `(lambda (x)
4329 (declare (optimize speed (safety 0)))
4330 (declare (type (integer 1 16) x))
4331 (logand
4332 (+ x ,(1- (ash 1 width)))
4333 ,(logior (ash 1 (+ width 1 extra))
4334 (1- (ash 1 width))))))))
4335 (unless (= (funcall fun 16) (logand 15 (1- (ash 1 width))))
4336 (push (cons width extra) result)))))
4337 (assert (null result))))
4338
4339 ;; On x86-64 MOVE-IMMEDIATE of fixnum values into memory either directly
4340 ;; uses a MOV into memory or goes through a temporary register if the
4341 ;; value is larger than a certain number of bits. Check that it respects
4342 ;; the limits of immediate arguments to the MOV instruction (if not, the
4343 ;; assembler will fail an assertion) and doesn't have sign-extension
4344 ;; problems. (The test passes fixnum constants through the MOVE VOP
4345 ;; which calls MOVE-IMMEDIATE.)
4346 (with-test (:name :constant-fixnum-move)
4347 (let ((f (compile nil `(lambda (g)
4348 (funcall g
4349 ;; The first three args are
4350 ;; uninteresting as they are
4351 ;; passed in registers.
4352 1 2 3
4353 ,@(loop for i from 27 to 32
4354 collect (expt 2 i)))))))
4355 (assert (every #'plusp (funcall f #'list)))))
4356
4357 (with-test (:name (:malformed-ignore :lp-1000239))
4358 (assert-error
4359 (eval '(lambda () (declare (ignore (function . a)))))
4360 sb-int:simple-program-error)
4361 (assert-error
4362 (eval '(lambda () (declare (ignore (function a b)))))
4363 sb-int:simple-program-error)
4364 (assert-error
4365 (eval '(lambda () (declare (ignore (function)))))
4366 sb-int:simple-program-error)
4367 (assert-error
4368 (eval '(lambda () (declare (ignore (a)))))
4369 sb-int:simple-program-error)
4370 (assert-error
4371 (eval '(lambda () (declare (ignorable (a b)))))
4372 sb-int:simple-program-error))
4373
4374 (with-test (:name :malformed-type-declaraions)
4375 (compile nil '(lambda (a) (declare (type (integer 1 2 . 3) a)))))
4376
4377 (with-test (:name :compiled-program-error-escaped-source)
4378 (assert
4379 (handler-case
4380 (funcall (compile nil `(lambda () (lambda ("foo")))))
4381 (sb-int:compiled-program-error (e)
4382 (let ((source (read-from-string (sb-kernel::program-error-source e))))
4383 (equal source '#'(lambda ("foo"))))))))
4384
4385 (with-test (:name :escape-analysis-for-nlxs)
4386 (flet ((test (check lambda &rest args)
4387 (let* ((cell-note nil)
4388 (fun (handler-bind ((compiler-note
4389 (lambda (note)
4390 (when (search
4391 "Allocating a value-cell at runtime for"
4392 (princ-to-string note))
4393 (setf cell-note t)))))
4394 (compile nil lambda))))
4395 (assert (eql check cell-note))
4396 (if check
4397 (assert
4398 (eq :ok
4399 (handler-case
4400 (dolist (arg args nil)
4401 (setf fun (funcall fun arg)))
4402 (sb-int:simple-control-error (e)
4403 (when (equal
4404 (simple-condition-format-control e)
4405 "attempt to RETURN-FROM a block or GO to a tag that no longer exists")
4406 :ok)))))
4407 (ctu:assert-no-consing (apply fun args))))))
4408 (test nil `(lambda (x)
4409 (declare (optimize speed))
4410 (block out
4411 (flet ((ex () (return-from out 'out!)))
4412 (typecase x
4413 (cons (or (car x) (ex)))
4414 (t (ex)))))) :foo)
4415 (test t `(lambda (x)
4416 (declare (optimize speed))
4417 (funcall
4418 (block nasty
4419 (flet ((oops () (return-from nasty t)))
4420 #'oops)))) t)
4421 (test t `(lambda (r)
4422 (declare (optimize speed))
4423 (block out
4424 (flet ((ex () (return-from out r)))
4425 (lambda (x)
4426 (typecase x
4427 (cons (or (car x) (ex)))
4428 (t (ex))))))) t t)
4429 (test t `(lambda (x)
4430 (declare (optimize speed))
4431 (flet ((eh (x)
4432 (flet ((meh () (return-from eh 'meh)))
4433 (lambda ()
4434 (typecase x
4435 (cons (or (car x) (meh)))
4436 (t (meh)))))))
4437 (funcall (eh x)))) t t)))
4438
4439 (with-test (:name (:bug-1050768 :symptom))
4440 ;; Used to signal an error.
4441 (compile nil
4442 `(lambda (string position)
4443 (char string position)
4444 (array-in-bounds-p string (1+ position)))))
4445
4446 (with-test (:name (:bug-1050768 :cause))
4447 (let ((types `((string string)
4448 ((or (simple-array character 24) (vector t 24))
4449 (or (simple-array character 24) (vector t))))))
4450 (dolist (pair types)
4451 (destructuring-bind (orig conservative) pair
4452 (assert sb-c::(type= (specifier-type cl-user::conservative)
4453 (conservative-type (specifier-type cl-user::orig))))))))
4454
4455 (with-test (:name (:smodular64 :wrong-width))
4456 (let ((fun (compile nil
4457 '(lambda (x)
4458 (declare (type (signed-byte 64) x))
4459 (sb-c::mask-signed-field 64 (- x 7033717698976965573))))))
4460 (assert (= (funcall fun 10038) -7033717698976955535))))
4461
4462 (with-test (:name (:smodular32 :wrong-width))
4463 (let ((fun (compile nil '(lambda (x)
4464 (declare (type (signed-byte 31) x))
4465 (sb-c::mask-signed-field 31 (- x 1055131947))))))
4466 (assert (= (funcall fun 10038) -1055121909))))
4467
4468 (with-test (:name :first-open-coded)
4469 (let ((fun (compile nil `(lambda (x) (first x)))))
4470 (assert (not (ctu:find-named-callees fun)))))
4471
4472 (with-test (:name :second-open-coded)
4473 (let ((fun (compile nil `(lambda (x) (second x)))))
4474 (assert (not (ctu:find-named-callees fun)))))
4475
4476 (with-test (:name :svref-of-symbol-macro)
4477 (compile nil `(lambda (x)
4478 (symbol-macrolet ((sv x))
4479 (values (svref sv 0) (setf (svref sv 0) 99))))))
4480
4481 ;; The compiler used to update the receiving LVAR's type too
4482 ;; aggressively when converting a large constant to a smaller
4483 ;; (potentially signed) one, causing other branches to be
4484 ;; inferred as dead.
4485 (with-test (:name :modular-cut-constant-to-width)
4486 (let ((test (compile nil
4487 `(lambda (x)
4488 (logand 254
4489 (case x
4490 ((3) x)
4491 ((2 2 0 -2 -1 2) 9223372036854775803)
4492 (t 358458651)))))))
4493 (assert (= (funcall test -10470605025) 26))))
4494
4495 (with-test (:name :append-type-derivation)
4496 (let ((test-cases
4497 '((lambda () (append 10)) (integer 10 10)
4498 (lambda () (append nil 10)) (integer 10 10)
4499 (lambda (x) (append x 10)) (or (integer 10 10) cons)
4500 (lambda (x) (append x (cons 1 2))) cons
4501 (lambda (x y) (append x (cons 1 2) y)) cons
4502 (lambda (x y) (nconc x (the list y) x)) t
4503 (lambda (x y) (nconc (the atom x) y)) t
4504 (lambda (x y) (nconc (the (or null (eql 10)) x) y)) t
4505 (lambda (x y) (nconc (the (or cons vector) x) y)) cons
4506 (lambda (x y) (nconc (the sequence x) y)) t
4507 (lambda (x y) (print (length y)) (append x y)) sequence
4508 (lambda (x y) (print (length y)) (append x y)) sequence
4509 (lambda (x y) (append (the (member (a) (b)) x) y)) cons
4510 (lambda (x y) (append (the (member (a) (b) c) x) y)) cons
4511 (lambda (x y) (append (the (member (a) (b) nil) x) y)) t)))
4512 (loop for (function result-type) on test-cases by #'cddr
4513 do (assert (sb-kernel:type= (sb-kernel:specifier-type
4514 (car (cdaddr (sb-kernel:%simple-fun-type
4515 (compile nil function)))))
4516 (sb-kernel:specifier-type result-type))))))
4517
4518 (with-test (:name :bug-504121)
4519 (compile nil `(lambda (s)
4520 (let ((p1 #'upper-case-p))
4521 (funcall
4522 (lambda (g)
4523 (funcall p1 g))))
4524 (let ((p2 #'(lambda (char) (upper-case-p char))))
4525 (funcall p2 s)))))
4526
4527 (with-test (:name (:bug-504121 :optional-missing))
4528 (compile nil `(lambda (s)
4529 (let ((p1 #'upper-case-p))
4530 (funcall
4531 (lambda (g &optional x)
4532 (funcall p1 g))))
4533 (let ((p2 #'(lambda (char) (upper-case-p char))))
4534 (funcall p2 s)))))
4535
4536 (with-test (:name (:bug-504121 :optional-superfluous))
4537 (compile nil `(lambda (s)
4538 (let ((p1 #'upper-case-p))
4539 (funcall
4540 (lambda (g &optional x)
4541 (funcall p1 g))
4542 #\1 2 3))
4543 (let ((p2 #'(lambda (char) (upper-case-p char))))
4544 (funcall p2 s)))))
4545
4546 (with-test (:name (:bug-504121 :key-odd))
4547 (compile nil `(lambda (s)
4548 (let ((p1 #'upper-case-p))
4549 (funcall
4550 (lambda (g &key x)
4551 (funcall p1 g))
4552 #\1 :x))
4553 (let ((p2 #'(lambda (char) (upper-case-p char))))
4554 (funcall p2 s)))))
4555
4556 (with-test (:name (:bug-504121 :key-unknown))
4557 (compile nil `(lambda (s)
4558 (let ((p1 #'upper-case-p))
4559 (funcall
4560 (lambda (g &key x)
4561 (funcall p1 g))
4562 #\1 :y 2))
4563 (let ((p2 #'(lambda (char) (upper-case-p char))))
4564 (funcall p2 s)))))
4565
4566 (with-test (:name :bug-1181684)
4567 (compile nil `(lambda ()
4568 (let ((hash #xD13CCD13))
4569 (setf hash (logand most-positive-word
4570 (ash hash 5)))))))
4571
4572 (with-test (:name (:local-&optional-recursive-inline :bug-1180992))
4573 (compile nil
4574 `(lambda ()
4575 (labels ((called (&optional a))
4576 (recursed (&optional b)
4577 (called)
4578 (recursed)))
4579 (declare (inline recursed called))
4580 (recursed)))))
4581
4582 (with-test (:name :constant-fold-logtest)
4583 (assert (equal (sb-kernel:%simple-fun-type
4584 (compile nil `(lambda (x)
4585 (declare (type (mod 1024) x)
4586 (optimize speed))
4587 (logtest x 2048))))
4588 '(function ((unsigned-byte 10)) (values null &optional)))))
4589
4590 ;; type mismatches on LVARs with multiple potential sources used to
4591 ;; be reported as mismatches with the value NIL. Make sure we get
4592 ;; a warning, but that it doesn't complain about a constant NIL ...
4593 ;; of type FIXNUM.
4594 (with-test (:name (:multiple-use-lvar-interpreted-as-NIL :cast))
4595 (block nil
4596 (handler-bind ((sb-int:type-warning
4597 (lambda (c)
4598 (assert
4599 (not (search "Constant "
4600 (simple-condition-format-control
4601 c))))
4602 (return))))
4603 (compile nil `(lambda (x y z)
4604 (declare (type fixnum y z))
4605 (aref (if x y z) 0))))
4606 (error "Where's my warning?")))
4607
4608 (with-test (:name (:multiple-use-lvar-interpreted-as-NIL catch))
4609 (block nil
4610 (handler-bind ((style-warning
4611 (lambda (c)
4612 (assert
4613 (not (position
4614 nil
4615 (simple-condition-format-arguments c))))
4616 (return))))
4617 (compile nil `(lambda (x y z f)
4618 (declare (type fixnum y z))
4619 (catch (if x y z) (funcall f)))))
4620 (error "Where's my style-warning?")))
4621
4622 ;; Smoke test for rightward shifts
4623 (with-test (:name (:ash/right-signed))
4624 (let* ((f (compile nil `(lambda (x y)
4625 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4626 (type sb-vm:signed-word x)
4627 (optimize speed))
4628 (ash x (- y)))))
4629 (max (ash most-positive-word -1))
4630 (min (- -1 max)))
4631 (flet ((test (x y)
4632 (assert (= (ash x (- y))
4633 (funcall f x y)))))
4634 (dotimes (x 32)
4635 (dotimes (y (* 2 sb-vm:n-word-bits))
4636 (test x y)
4637 (test (- x) y)
4638 (test (- max x) y)
4639 (test (+ min x) y))))))
4640
4641 (with-test (:name (:ash/right-unsigned))
4642 (let ((f (compile nil `(lambda (x y)
4643 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4644 (type word x)
4645 (optimize speed))
4646 (ash x (- y)))))
4647 (max most-positive-word))
4648 (flet ((test (x y)
4649 (assert (= (ash x (- y))
4650 (funcall f x y)))))
4651 (dotimes (x 32)
4652 (dotimes (y (* 2 sb-vm:n-word-bits))
4653 (test x y)
4654 (test (- max x) y))))))
4655
4656 (with-test (:name (:ash/right-fixnum))
4657 (let ((f (compile nil `(lambda (x y)
4658 (declare (type (mod ,(* 2 sb-vm:n-word-bits)) y)
4659 (type fixnum x)
4660 (optimize speed))
4661 (ash x (- y))))))
4662 (flet ((test (x y)
4663 (assert (= (ash x (- y))
4664 (funcall f x y)))))
4665 (dotimes (x 32)
4666 (dotimes (y (* 2 sb-vm:n-word-bits))
4667 (test x y)
4668 (test (- x) y)
4669 (test (- most-positive-fixnum x) y)
4670 (test (+ most-negative-fixnum x) y))))))
4671
4672 ;; expected failure
4673 (with-test (:name :fold-index-addressing-positive-offset)
4674 (let ((f (compile nil `(lambda (i)
4675 (if (typep i '(integer -31 31))
4676 (aref #. (make-array 63) (+ i 31))
4677 (error "foo"))))))
4678 (funcall f -31)))
4679
4680 ;; 5d3a728 broke something like this in CL-PPCRE
4681 (with-test (:name :fold-index-addressing-potentially-negative-index)
4682 (compile nil `(lambda (index vector)
4683 (declare (optimize speed (safety 0))
4684 ((simple-array character (*)) vector)
4685 ((unsigned-byte 24) index))
4686 (aref vector (1+ (mod index (1- (length vector))))))))
4687
4688 (with-test (:name :constant-fold-ash/right-fixnum)
4689 (compile nil `(lambda (a b)
4690 (declare (type fixnum a)
4691 (type (integer * -84) b))
4692 (ash a b))))
4693
4694 (with-test (:name :constant-fold-ash/right-word)
4695 (compile nil `(lambda (a b)
4696 (declare (type word a)
4697 (type (integer * -84) b))
4698 (ash a b))))
4699
4700 (with-test (:name :nconc-derive-type)
4701 (let ((function (compile nil `(lambda (x y)
4702 (declare (type (or cons fixnum) x))
4703 (nconc x y)))))
4704 (assert (equal (sb-kernel:%simple-fun-type function)
4705 '(function ((or cons fixnum) t) (values cons &optional))))))
4706
4707 ;; make sure that all data-vector-ref-with-offset VOPs are either
4708 ;; specialised on a 0 offset or accept signed indices
4709 (with-test (:name :data-vector-ref-with-offset-signed-index)
4710 (let ((dvr (find-symbol "DATA-VECTOR-REF-WITH-OFFSET" "SB-KERNEL")))
4711 (when dvr
4712 (assert
4713 (null
4714 (loop for info in (sb-c::fun-info-templates
4715 (sb-c::fun-info-or-lose dvr))
4716 for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
4717 unless (or (typep second-arg '(cons (eql :constant)))
4718 (find '(integer 0 0) third-arg :test 'equal)
4719 (equal second-arg
4720 `(:or ,(sb-c::primitive-type-or-lose
4721 'sb-vm::positive-fixnum)
4722 ,(sb-c::primitive-type-or-lose
4723 'fixnum))))
4724 collect info))))))
4725
4726 (with-test (:name :data-vector-set-with-offset-signed-index)
4727 (let ((dvr (find-symbol "DATA-VECTOR-SET-WITH-OFFSET" "SB-KERNEL")))
4728 (when dvr
4729 (assert
4730 (null
4731 (loop for info in (sb-c::fun-info-templates
4732 (sb-c::fun-info-or-lose dvr))
4733 for (nil second-arg third-arg) = (sb-c::vop-info-arg-types info)
4734 unless (or (typep second-arg '(cons (eql :constant)))
4735 (find '(integer 0 0) third-arg :test 'equal)
4736 (equal second-arg
4737 `(:or ,(sb-c::primitive-type-or-lose
4738 'sb-vm::positive-fixnum)
4739 ,(sb-c::primitive-type-or-lose
4740 'fixnum))))
4741 collect info))))))
4742
4743 (with-test (:name :maybe-inline-ref-to-dead-lambda)
4744 (compile nil `(lambda (string)
4745 (declare (optimize speed (space 0)))
4746 (cond ((every #'digit-char-p string)
4747 nil)
4748 ((some (lambda (c)
4749 (digit-char-p c))
4750 string))))))
4751
4752 ;; the x87 backend used to sometimes signal FP errors during boxing,
4753 ;; because converting between double and single float values was a
4754 ;; noop (fixed), and no doubt many remaining issues. We now store
4755 ;; the value outside pseudo-atomic, so any SIGFPE should be handled
4756 ;; corrrectly.
4757 ;;
4758 ;; When it fails, this test lands into ldb.
4759 (with-test (:name :no-overflow-during-allocation)
4760 (handler-case (eval '(cosh 90))
4761 (floating-point-overflow ()
4762 t)))
4763
4764 ;; unbounded integer types could break integer arithmetic.
4765 (with-test (:name :bug-1199127)
4766 (compile nil `(lambda (b)
4767 (declare (type (integer -1225923945345 -832450738898) b))
4768 (declare (optimize (speed 3) (space 3) (safety 2)
4769 (debug 0) (compilation-speed 1)))
4770 (loop for lv1 below 3
4771 sum (logorc2
4772 (if (>= 0 lv1)
4773 (ash b (min 25 lv1))
4774 0)
4775 -2)))))
4776
4777 ;; non-trivial modular arithmetic operations would evaluate to wider results
4778 ;; than expected, and never be cut to the right final bitwidth.
4779 (with-test (:name :bug-1199428-1)
4780 (let ((f1 (compile nil `(lambda (a c)
4781 (declare (type (integer -2 1217810089) a))
4782 (declare (type (integer -6895591104928 -561736648588) c))
4783 (declare (optimize (speed 2) (space 0) (safety 2) (debug 0)
4784 (compilation-speed 3)))
4785 (logandc1 (gcd c)
4786 (+ (- a c)
4787 (loop for lv2 below 1 count t))))))
4788 (f2 (compile nil `(lambda (a c)
4789 (declare (notinline - + gcd logandc1))
4790 (declare (optimize (speed 1) (space 1) (safety 0) (debug 1)
4791 (compilation-speed 3)))
4792 (logandc1 (gcd c)
4793 (+ (- a c)
4794 (loop for lv2 below 1 count t)))))))
4795 (let ((a 530436387)
4796 (c -4890629672277))
4797 (assert (eql (funcall f1 a c)
4798 (funcall f2 a c))))))
4799
4800 (with-test (:name :bug-1199428-2)
4801 (let ((f1 (compile nil `(lambda (a b)
4802 (declare (type (integer -1869232508 -6939151) a))
4803 (declare (type (integer -11466348357 -2645644006) b))
4804 (declare (optimize (speed 1) (space 0) (safety 2) (debug 2)
4805 (compilation-speed 2)))
4806 (logand (lognand a -6) (* b -502823994)))))
4807 (f2 (compile nil `(lambda (a b)
4808 (logand (lognand a -6) (* b -502823994))))))
4809 (let ((a -1491588365)
4810 (b -3745511761))
4811 (assert (eql (funcall f1 a b)
4812 (funcall f2 a b))))))
4813
4814 ;; win32 is very specific about the order in which catch blocks
4815 ;; must be allocated on the stack
4816 (with-test (:name :bug-1072739)
4817 (let ((f (compile nil
4818 `(lambda ()
4819 (STRING=
4820 (LET ((% 23))
4821 (WITH-OUTPUT-TO-STRING (G13908)
4822 (PRINC
4823 (LET ()
4824 (DECLARE (OPTIMIZE (SB-EXT:INHIBIT-WARNINGS 3)))
4825 (HANDLER-CASE
4826 (WITH-OUTPUT-TO-STRING (G13909) (PRINC %A%B% G13909) G13909)
4827 (UNBOUND-VARIABLE NIL
4828 (HANDLER-CASE
4829 (WITH-OUTPUT-TO-STRING (G13914)
4830 (PRINC %A%B% G13914)
4831 (PRINC "" G13914)
4832 G13914)
4833 (UNBOUND-VARIABLE NIL
4834 (HANDLER-CASE
4835 (WITH-OUTPUT-TO-STRING (G13913)
4836 (PRINC %A%B G13913)
4837 (PRINC "%" G13913)
4838 G13913)
4839 (UNBOUND-VARIABLE NIL
4840 (HANDLER-CASE
4841 (WITH-OUTPUT-TO-STRING (G13912)
4842 (PRINC %A% G13912)
4843 (PRINC "b%" G13912)
4844 G13912)
4845 (UNBOUND-VARIABLE NIL
4846 (HANDLER-CASE
4847 (WITH-OUTPUT-TO-STRING (G13911)
4848 (PRINC %A G13911)
4849 (PRINC "%b%" G13911)
4850 G13911)
4851 (UNBOUND-VARIABLE NIL
4852 (HANDLER-CASE
4853 (WITH-OUTPUT-TO-STRING (G13910)
4854 (PRINC % G13910)
4855 (PRINC "a%b%" G13910)
4856 G13910)
4857 (UNBOUND-VARIABLE NIL
4858 (ERROR "Interpolation error in \"%a%b%\"
4859 "))))))))))))))
4860 G13908)))
4861 "23a%b%")))))
4862 (assert (funcall f))))
4863
4864 (with-test (:name :equal-equalp-transforms)
4865 (let* ((s "foo")
4866 (bit-vector #*11001100)
4867 (values `(nil 1 2 "test"
4868 ;; Floats duplicated here to ensure we get newly created instances
4869 (read-from-string "1.1") (read-from-string "1.2d0")
4870 (read-from-string "1.1") (read-from-string "1.2d0")
4871 1.1 1.2d0 '("foo" "bar" "test")
4872 #(1 2 3 4) #*101010 (make-broadcast-stream) #p"/tmp/file"
4873 ,s (copy-seq ,s) ,bit-vector (copy-seq ,bit-vector)
4874 ,(make-hash-table) #\a #\b #\A #\C
4875 ,(make-random-state) 1/2 2/3)))
4876 ;; Test all permutations of different types
4877 (assert
4878 (loop
4879 for x in values
4880 always (loop
4881 for y in values
4882 always
4883 (and (eq (funcall (compile nil `(lambda (x y)
4884 (equal (the ,(type-of x) x)
4885 (the ,(type-of y) y))))
4886 x y)
4887 (equal x y))
4888 (eq (funcall (compile nil `(lambda (x y)
4889 (equalp (the ,(type-of x) x)
4890 (the ,(type-of y) y))))
4891 x y)
4892 (equalp x y))))))
4893 (assert
4894 (funcall (compile
4895 nil
4896 `(lambda (x y)
4897 (equal (the (cons (or simple-bit-vector simple-base-string))
4898 x)
4899 (the (cons (or (and bit-vector (not simple-array))
4900 (simple-array character (*))))
4901 y))))
4902 (list (string 'list))
4903 (list "LIST")))
4904 (assert
4905 (funcall (compile
4906 nil
4907 `(lambda (x y)
4908 (equalp (the (cons (or simple-bit-vector simple-base-string))
4909 x)
4910 (the (cons (or (and bit-vector (not simple-array))
4911 (simple-array character (*))))
4912 y))))
4913 (list (string 'list))
4914 (list "lisT")))))
4915
4916 (with-test (:name (restart-case optimize speed compiler-note)
4917 :skipped-on :sparc) ; crashes the test driver
4918 (handler-bind ((compiler-note #'error))
4919 (compile nil '(lambda ()
4920 (declare (optimize speed))
4921 (restart-case () (c ()))))
4922 (compile nil '(lambda ()
4923 (declare (optimize speed))
4924 (let (x)
4925 (restart-case (setf x (car (compute-restarts)))
4926 (c ()))
4927 x)))))
4928
4929 (with-test (:name :copy-more-arg
4930 :fails-on '(not (or :x86 :x86-64 :arm)))
4931 ;; copy-more-arg might not copy in the right direction
4932 ;; when there are more fixed args than stack frame slots,
4933 ;; and thus end up splatting a single argument everywhere.
4934 ;; Failing platforms still start their stack frames at 8 slots, so
4935 ;; this is less likely to happen.
4936 (let ((limit 33))
4937 (labels ((iota (n)
4938 (loop for i below n collect i))
4939 (test-function (function skip)
4940 ;; function should just be (subseq x skip)
4941 (loop for i from skip below (+ skip limit) do
4942 (let* ((values (iota i))
4943 (f (apply function values))
4944 (subseq (subseq values skip)))
4945 (assert (equal f subseq)))))
4946 (make-function (n)
4947 (let ((gensyms (loop for i below n collect (gensym))))
4948 (compile nil `(lambda (,@gensyms &rest rest)
4949 (declare (ignore ,@gensyms))
4950 rest)))))
4951 (dotimes (i limit)
4952 (test-function (make-function i) i)))))
4953
4954 (with-test (:name :apply-aref)
4955 (flet ((test (form)
4956 (let (warning)
4957 (handler-bind ((warning (lambda (c) (setf warning c))))
4958 (compile nil `(lambda (x y) (setf (apply #'sbit x y) 10))))
4959 (assert (not warning)))))
4960 (test `(lambda (x y) (setf (apply #'aref x y) 21)))
4961 (test `(lambda (x y) (setf (apply #'bit x y) 1)))
4962 (test `(lambda (x y) (setf (apply #'sbit x y) 0)))))
4963
4964 (with-test (:name :warn-on-the-values-constant)
4965 (multiple-value-bind (fun warnings-p failure-p)
4966 (compile nil
4967 ;; The compiler used to elide this test without
4968 ;; noting that the type demands multiple values.
4969 '(lambda () (the (values fixnum fixnum) 1)))
4970 (declare (ignore warnings-p))
4971 (assert (functionp fun))
4972 (assert failure-p)))
4973
4974 ;; quantifiers shouldn't cons themselves.
4975 (with-test (:name :quantifiers-no-consing)
4976 (let ((constantly-t (lambda (x) x t))
4977 (constantly-nil (lambda (x) x nil))
4978 (list (make-list 1000 :initial-element nil))
4979 (vector (make-array 1000 :initial-element nil)))
4980 (macrolet ((test (quantifier)
4981 (let ((function (make-symbol (format nil "TEST-~A" quantifier))))
4982 `(flet ((,function (function sequence)
4983 (,quantifier function sequence)))
4984 (ctu:assert-no-consing (,function constantly-t list))
4985 (ctu:assert-no-consing (,function constantly-nil vector))))))
4986 (test some)
4987 (test every)
4988 (test notany)
4989 (test notevery))))
4990
4991 (with-test (:name :propagate-complex-type-tests)
4992 (flet ((test (type value)
4993 (let ((ftype (sb-kernel:%simple-fun-type
4994 (compile nil `(lambda (x)
4995 (if (typep x ',type)
4996 x
4997 ',value))))))
4998 (assert (typep ftype `(cons (eql function))))
4999 (assert (= 3 (length ftype)))
5000 (let* ((return (third ftype))
5001 (rtype (second return)))
5002 (assert (typep return `(cons (eql values)
5003 (cons t
5004 (cons (eql &optional)
5005 null)))))
5006 (assert (and (subtypep rtype type)
5007 (subtypep type rtype)))))))
5008 (mapc (lambda (params)
5009 (apply #'test params))
5010 `(((unsigned-byte 17) 0)
5011 ((member 1 3 5 7) 5)
5012 ((or symbol (eql 42)) t)))))
5013
5014 (with-test (:name :constant-fold-complex-type-tests)
5015 (assert (equal (sb-kernel:%simple-fun-type
5016 (compile nil `(lambda (x)
5017 (if (typep x '(member 1 3))
5018 (typep x '(member 1 3 15))
5019 t))))
5020 `(function (t) (values (member t) &optional))))
5021 (assert (equal (sb-kernel:%simple-fun-type
5022 (compile nil `(lambda (x)
5023 (declare (type (member 1 3) x))
5024 (typep x '(member 1 3 15)))))
5025 `(function ((or (integer 1 1) (integer 3 3)))
5026 (values (member t) &optional)))))
5027
5028 (with-test (:name :quietly-row-major-index-no-dimensions)
5029 (assert (handler-case
5030 (compile nil `(lambda (x) (array-row-major-index x)))
5031 (warning () nil))))
5032
5033 (with-test (:name :array-rank-transform)
5034 (compile nil `(lambda (a) (array-rank (the an-imaginary-type a)))))
5035
5036 (with-test (:name (:array-rank-fold :bug-1252108))
5037 (let (noted)
5038 (handler-bind ((sb-ext::code-deletion-note
5039 (lambda (x)
5040 (setf noted x))))
5041 (compile nil
5042 `(lambda (a)
5043 (typecase a
5044 ((array t 2)
5045 (when (= (array-rank a) 3)
5046 (array-dimension a 2)))))))
5047 (assert noted)))
5048
5049 (assert-error (upgraded-array-element-type 'an-undefined-type))
5050
5051 (with-test (:name :xchg-misencoding)
5052 (assert (eql (funcall (compile nil '(lambda (a b)
5053 (declare (optimize (speed 3) (safety 2))
5054 (type single-float a))
5055 (unless (eql b 1/2)
5056 (min a -1f0))))
5057 0f0 1)
5058 -1f0)))
5059
5060 (with-test (:name :malformed-declare)
5061 (multiple-value-bind (fun warnings-p failure-p)
5062 (compile nil '(lambda (x)
5063 (declare (unsigned-byte (x)))
5064 x))
5065 (assert (and fun warnings-p failure-p))))
5066
5067 (with-test (:name :no-dubious-asterisk-warning)
5068 (multiple-value-bind (fun warnings-p failure-p)
5069 (compile
5070 nil
5071 '(lambda (foo)
5072 (macrolet ((frob-some-stuff (&rest exprs)
5073 (let ((temps
5074 (mapcar
5075 (lambda (x)
5076 (if (symbolp x) (copy-symbol x) (gensym)))
5077 exprs)))
5078 `(let ,(mapcar #'list temps exprs)
5079 (if (and ,@temps)
5080 (format t "Got~@{ ~S~^ and~}~%" ,@temps))))))
5081 (frob-some-stuff *print-base* (car foo)))))
5082 (assert (and fun (not warnings-p) (not failure-p)))))
5083
5084 (with-test (:name :interr-type-specifier-hashing)
5085 (let ((specifiers
5086 (remove
5087 'simple-vector
5088 (map 'list
5089 (lambda (saetp)
5090 (sb-c::type-specifier
5091 (sb-c::specifier-type
5092 `(simple-array ,(sb-vm:saetp-specifier saetp) (*)))))
5093 sb-vm:*specialized-array-element-type-properties*))))
5094 (assert (sb-c::%interr-symbol-for-type-spec `(or ,@specifiers)))
5095 (assert (sb-c::%interr-symbol-for-type-spec
5096 `(or ,@specifiers system-area-pointer)))))
5097
5098 (with-test (:name :simple-rank-1-array-*-p-works)
5099 (assert (funcall (compile nil
5100 '(lambda () (typep #() '(simple-array * (*)))))))
5101 (loop for saetp across sb-vm:*specialized-array-element-type-properties*
5102 do
5103 (dotimes (n-dimensions 3) ; test ranks 0, 1, and 2.
5104 (let ((dims (make-list n-dimensions :initial-element 2)))
5105 (dolist (adjustable-p '(nil t))
5106 (let ((a (make-array dims :element-type (sb-vm:saetp-specifier saetp)
5107 :adjustable adjustable-p)))
5108 (assert (eq (and (= n-dimensions 1) (not adjustable-p))
5109 (typep a '(simple-array * (*)))))))))))
5110
5111 (with-test (:name :array-subtype-tests
5112 :skipped-on '(:not (:or :x86 :x86-64)))
5113 (assert (funcall (compile nil
5114 '(lambda ()
5115 (typep #() '(or simple-vector simple-string))))))
5116 (flet ((approx-lines-of-assembly-code (type-expr)
5117 (count #\Newline
5118 (with-output-to-string (s)
5119 (disassemble
5120 `(lambda (x)
5121 (declare (optimize (sb-c::verify-arg-count 0)))
5122 (typep x ',type-expr))
5123 :stream s)))))
5124 ;; These are fragile, but less bad than the possibility of messing up
5125 ;; any vops, especially since the generic code in 'vm-type' checks for
5126 ;; a vop by its name in a place that would otherwise be agnostic of the
5127 ;; backend were it not for my inability to test all platforms.
5128 (assert (< (approx-lines-of-assembly-code
5129 '(simple-array * (*))) 25))
5130 ;; this tested all possible widetags one at a time, e.g. in VECTOR-SAP
5131 (assert (< (approx-lines-of-assembly-code
5132 '(sb-kernel:simple-unboxed-array (*))) 25))
5133 ;; This is actually a strange type but it's what ANSI-STREAM-READ-N-BYTES
5134 ;; declares as its buffer, which would choke in %BYTE-BLT if you gave it
5135 ;; (simple-array t (*)). But that's a different problem.
5136 (assert (< (approx-lines-of-assembly-code
5137 '(or system-area-pointer (simple-array * (*)))) 29))
5138 ;; And this was used by %BYTE-BLT which tested widetags one-at-a-time.
5139 (assert (< (approx-lines-of-assembly-code
5140 '(or system-area-pointer (sb-kernel:simple-unboxed-array (*))))
5141 29))))
5142
5143 (with-test (:name :local-argument-mismatch-error-string)
5144 (let ((f (compile nil `(lambda (x)
5145 (flet ((foo ()))
5146 (foo x))))))
5147 (multiple-value-bind (ok err) (ignore-errors (funcall f 42))
5148 (assert (not ok))
5149 (assert (search "FLET FOO" (princ-to-string err))))))
5150
5151 (with-test (:name :bug-1310574-0)
5152 (multiple-value-bind (function warning failure)
5153 (compile nil `(lambda (a)
5154 (typecase a
5155 ((or (array * (* * 3)) (array * (* * 4)))
5156 (case (array-rank a)
5157 (2 (aref a 1 2)))))))
5158 (declare (ignore function))
5159 (assert (not warning))
5160 (assert (not failure))))
5161
5162 (with-test (:name :bug-1310574-1)
5163 (multiple-value-bind (function warning failure)
5164 (compile nil `(lambda (a)
5165 (typecase a
5166 ((or (array * ()) (array * (1)) (array * (1 2)))
5167 (case (array-rank a)
5168 (3 (aref a 1 2 3)))))))
5169 (declare (ignore function))
5170 (assert (not warning))
5171 (assert (not failure))))
5172
5173 (with-test (:name :bug-573747)
5174 (multiple-value-bind (function warnings-p failure-p)
5175 (compile nil '(lambda (x) (progn (declare (integer x)) (* x 6))))
5176 (assert warnings-p)
5177 (assert failure-p)))
5178
5179 ;; Something in this function used to confuse lifetime analysis into
5180 ;; recording multiple conflicts for a single TNs in the dolist block.
5181 (with-test (:name :bug-1327008)
5182 (handler-bind (((or style-warning compiler-note)
5183 (lambda (c)
5184 (muffle-warning c))))
5185 (compile nil
5186 `(lambda (scheduler-spec
5187 schedule-generation-method
5188 utc-earliest-time utc-latest-time
5189 utc-other-earliest-time utc-other-latest-time
5190 &rest keys
5191 &key queue
5192 maximum-mileage
5193 maximum-extra-legs
5194 maximum-connection-time
5195 slice-number
5196 scheduler-hints
5197 permitted-route-locations prohibited-route-locations
5198 preferred-connection-locations disfavored-connection-locations
5199 origins destinations
5200 permitted-carriers prohibited-carriers
5201 permitted-operating-carriers prohibited-operating-carriers
5202 start-airports end-airports
5203 circuity-limit
5204 specified-circuity-limit-extra-miles
5205 (preferred-carriers :unspecified)
5206 &allow-other-keys)
5207 (declare (optimize speed))
5208 (let ((table1 (list nil))
5209 (table2 (list nil))
5210 (skip-flifo-checks (getf scheduler-spec :skip-flifo-checks))
5211 (construct-gaps-p (getf scheduler-spec :construct-gaps-p))
5212 (gap-locations (getf scheduler-spec :gap-locations))
5213 (result-array (make-array 100))
5214 (number-dequeued 0)
5215 (n-new 0)
5216 (n-calcs 0)
5217 (exit-reason 0)
5218 (prev-start-airports origins)
5219 (prev-end-airports destinations)
5220 (prev-permitted-carriers permitted-carriers))
5221 (flet ((run-with-hint (hint random-magic other-randomness
5222 maximum-extra-legs
5223 preferred-origins
5224 preferred-destinations
5225 same-pass-p)
5226 (let* ((hint-permitted-carriers (first hint))
5227 (preferred-end-airports
5228 (ecase schedule-generation-method
5229 (:DEPARTURE preferred-destinations)
5230 (:ARRIVAL preferred-origins)))
5231 (revised-permitted-carriers
5232 (cond ((and hint-permitted-carriers
5233 (not (eq permitted-carriers :ANY)))
5234 (intersection permitted-carriers
5235 hint-permitted-carriers))
5236 (hint-permitted-carriers)
5237 (permitted-carriers)))
5238 (revised-maximum-mileage
5239 (min (let ((maximum-mileage 0))
5240 (dolist (o start-airports)
5241 (dolist (d end-airports)
5242 (setf maximum-mileage
5243 (max maximum-mileage (mileage o d)))))
5244 (round (+ (* circuity-limit maximum-mileage)
5245 (or specified-circuity-limit-extra-miles
5246 (hairy-calculation slice-number)))))
5247 maximum-mileage)))
5248 (when (or (not (equal start-airports prev-start-airports))
5249 (not (equal end-airports prev-end-airports))
5250 (and (not (equal revised-permitted-carriers
5251 prev-permitted-carriers))))
5252 (incf n-calcs)
5253 (calculate-vectors
5254 prohibited-carriers
5255 permitted-operating-carriers
5256 prohibited-operating-carriers
5257 permitted-route-locations
5258 prohibited-route-locations
5259 construct-gaps-p
5260 gap-locations
5261 preferred-carriers)
5262 (setf prev-permitted-carriers revised-permitted-carriers))
5263 (multiple-value-bind (this-number-dequeued
5264 this-exit-reason
5265 this-n-new)
5266 (apply #'schedule-loop
5267 utc-earliest-time utc-other-earliest-time
5268 utc-latest-time utc-other-latest-time
5269 scheduler-spec schedule-generation-method
5270 queue
5271 :maximum-mileage revised-maximum-mileage
5272 :maximum-extra-legs maximum-extra-legs
5273 :maximum-connection-time maximum-connection-time
5274 :same-pass-p same-pass-p
5275 :preferred-end-airports preferred-end-airports
5276 :maximum-blah random-magic
5277 :skip-flifo-checks skip-flifo-checks
5278 :magic1 table1
5279 :magic2 table2
5280 :preferred-connection-locations preferred-connection-locations
5281 :disfavored-connection-locations disfavored-connection-locations
5282 keys)
5283 (when other-randomness
5284 (loop for i fixnum from n-new to (+ n-new (1- this-n-new))
5285 do (hairy-calculation i result-array)))
5286 (incf number-dequeued this-number-dequeued)
5287 (incf n-new this-n-new)
5288 (setq exit-reason (logior exit-reason this-exit-reason))))))
5289 (let ((n-hints-processed 0))
5290 (dolist (hint scheduler-hints)
5291 (run-with-hint hint n-hints-processed t 0
5292 nil nil nil)
5293 (incf n-hints-processed)))
5294 (run-with-hint nil 42 nil maximum-extra-legs
5295 '(yyy) '(xxx) t))
5296 exit-reason)))))
5297
5298 (with-test (:name :dead-code-in-optional-dispatch)
5299 (multiple-value-bind (f warningp)
5300 ;; the translation of each optional entry is
5301 ;; (let ((#:g (error "nope"))) (funcall #<clambda> ...))
5302 ;; but the funcall is unreachable. Since this is an artifact of how the
5303 ;; lambda is converted, it should not generate a note as if in user code.
5304 (compile nil '(lambda (a &optional (b (error "nope")) (c (error "nope")))
5305 (values c b a)))
5306 (assert (and f (not warningp)))))
5307
5308 (with-test (:name :nth-value-of-non-constant-N)
5309 (labels ((foo (n f) (nth-value n (funcall f)))
5310 (bar () (values 0 1 2 3 4 5 6 7 8 9)))
5311 (assert (= (foo 5 #'bar) 5)) ; basic correctness
5312 (assert (eq (foo 12 #'bar) nil))
5313 (ctu:assert-no-consing (eql (foo 953 #'bar) 953))))
5314
5315 (with-test (:name :position-derive-type-optimizer)
5316 (assert-code-deletion-note
5317 '(lambda (x) ; the call to POSITION can't return 4
5318 (let ((i (position x #(a b c d) :test 'eq)))
5319 (case i (4 'nope) (t 'okeydokey))))))
5320
5321 ;; Assert that DO-PACKED-TNS has unsurprising behavior if the body RETURNs.
5322 ;; This isn't a test in the problem domain of CL - it's of an internal macro,
5323 ;; and x86-64-specific not because of broken-ness, but because it uses
5324 ;; known random TNs to play with. Printing "skipped on" for other backends
5325 ;; would be somewhat misleading in as much as it means nothing about
5326 ;; the correctness of the test on other architectures.
5327 #+x86-64
5328 (with-test (:name :do-packed-tn-iterator)
5329 (dotimes (i (ash 1 6))
5330 (labels ((make-tns (n)
5331 (mapcar 'copy-structure
5332 (subseq `sb-vm::(,rax-tn ,rbx-tn ,rcx-tn) 0 n)))
5333 (link (list)
5334 (when list
5335 (setf (sb-c::tn-next (car list)) (link (cdr list)))
5336 (car list))))
5337 (let* ((normal (make-tns (ldb (byte 2 0) i)))
5338 (restricted (make-tns (ldb (byte 2 2) i)))
5339 (wired (make-tns (ldb (byte 2 4) i)))
5340 (expect (append normal restricted wired))
5341 (comp (sb-c::make-empty-component))
5342 (ir2-comp (sb-c::make-ir2-component)))
5343 (setf (sb-c::component-info comp) ir2-comp
5344 (sb-c::ir2-component-normal-tns ir2-comp) (link normal)
5345 (sb-c::ir2-component-restricted-tns ir2-comp) (link restricted)
5346 (sb-c::ir2-component-wired-tns ir2-comp) (link wired))
5347 (let* ((list)
5348 (result (sb-c::do-packed-tns (tn comp 42) (push tn list))))
5349 (assert (eq result 42))
5350 (assert (equal expect (nreverse list))))
5351 (let* ((n 0) (list)
5352 (result (sb-c::do-packed-tns (tn comp 'bar)
5353 (push tn list)
5354 (if (= (incf n) 4) (return 'foo)))))
5355 (assert (eq result (if (>= (length expect) 4) 'foo 'bar)))
5356 (assert (equal (subseq expect 0 (min 4 (length expect)))
5357 (nreverse list))))))))
5358
5359 ;; lp# 310267
5360 (with-test (:name :optimize-quality-multiply-specified)
5361 (let ((*error-output* (make-broadcast-stream)))
5362 (let ((sb-c::*policy* sb-c::*policy*)) ; to keep this test pure
5363 (assert-signal (proclaim '(optimize space debug (space 0)))
5364 style-warning))
5365 (assert-signal
5366 (compile nil '(lambda () (declare (optimize speed (speed 0))) 5))
5367 style-warning)
5368 (assert-signal
5369 (compile nil '(lambda () (declare (optimize speed) (optimize (speed 0))) 5))
5370 style-warning)
5371 (assert-signal
5372 (compile nil '(lambda ()
5373 (declare (optimize speed)) (declare (optimize (speed 0)))
5374 5))
5375 style-warning))
5376
5377 ;; these are OK
5378 (assert-no-signal (proclaim '(optimize (space 3) space)))
5379 (assert-no-signal
5380 (compile nil '(lambda () (declare (optimize speed (speed 3))) 5)))
5381 (assert-no-signal
5382 (compile nil '(lambda () (declare (optimize speed) (optimize (speed 3))) 5)))
5383 (assert-no-signal
5384 (compile nil '(lambda ()
5385 (declare (optimize speed)) (declare (optimize (speed 3)))
5386 5))))
5387
5388 (with-test (:name :truncate-type-derivation)
5389 (assert (=
5390 4
5391 (funcall
5392 (compile nil
5393 '(lambda (a b)
5394 (truncate a
5395 (the (rational (1) (3)) b))))
5396 10 5/2))))
5397
5398 (with-test (:name :constantp-on-a-literal-function-works)
5399 (assert (constantp `(the (function (list) t) ,#'car))))
5400
5401 (with-test (:name :arg-count-error)
5402 (assert (eq :win (handler-case (funcall (intern "CONS") 1 2 3)
5403 (sb-int:simple-program-error () :win)
5404 (condition () :lose)))))
5405
5406 (with-test (:name :mv-conversion)
5407 (compile nil '(lambda (a)
5408 (tagbody (go 0)
5409 (list (unwind-protect a))
5410 (multiple-value-call #'list
5411 (values (catch 'ct5 (go 0))))
5412 0))))
5413
5414 (with-test (:name (:null-cleanups-1 :bug-1416704 :bug-404441))
5415 (let ((x (funcall
5416 (compile nil `(lambda ()
5417 (lambda (x)
5418 (declare (optimize speed))
5419 (if x
5420 (funcall (flet ((bar () 10)) #'bar))
5421 (funcall (flet ((fez ()
5422 (funcall (flet ((foo () 20)) #'foo))))
5423 #'fez)))))))))
5424 (assert (= (funcall x t) 10))
5425 (assert (= (funcall x nil) 20))))
5426
5427 (with-test (:name (:null-cleanups-2 :bug-1416704 :bug-404441))
5428 (let ((fun (funcall
5429 (compile nil `(lambda ()
5430 (lambda (x)
5431 (declare (optimize speed))
5432 (let* ((a2 (lambda () 20))
5433 (a4 (lambda ()))
5434 (a0 (flet ((f () (funcall a2)))
5435 #'f))
5436 (a3 (lambda ()
5437 (if x
5438 (if x
5439 (throw 'x 10)
5440 (let ((a5 (lambda () (funcall a4))))
5441 (funcall a5)))
5442 (funcall a0)))))
5443 (funcall a3))))))))
5444 (assert (= (catch 'x (funcall fun t)) 10))
5445 (assert (= (catch 'x (funcall fun nil)) 20))))
5446
5447
5448 (with-test (:name :locall-already-let-converted)
5449 (assert (eq (funcall
5450 (funcall
5451 (compile
5452 nil
5453 '(lambda ()
5454 (flet ((call (ff)
5455 (flet ((f () (return-from f ff)))
5456 (declare (inline f))
5457 (f)
5458 (f))))
5459 (declare (inline call))
5460 (call 1)
5461 (call (lambda () 'result)))))))
5462 'result)))
5463
5464 (with-test (:name :debug-dump-elsewhere)
5465 (assert
5466 (eql
5467 (catch 'x
5468 (funcall
5469 (compile nil
5470 '(lambda ()
5471 (declare (optimize debug))
5472 (throw 'x *)))))
5473 *)))
5474
5475 (with-test (:name :typep-quasiquoted-constant)
5476 (assert (null (ctu:find-named-callees
5477 (compile nil
5478 '(lambda (x)
5479 (typep x `(signed-byte ,sb-vm:n-word-bits))))))))
5480 (with-test (:name :logior-transform)
5481 (let ((function (compile nil '(lambda (c)
5482 (flet ((f (x)
5483 (the integer x)))
5484 (logior c (f nil)))))))
5485 (assert-error (funcall function 10)
5486 type-error)))
5487
5488 (with-test (:name :eql/integer-folding)
5489 (multiple-value-bind (f warning)
5490 (compile nil
5491 '(lambda (a)
5492 (fceiling (the (member 2.3 21672589639883401935) a))))
5493 (assert (and f (not warning)))))
5494
5495 (with-test (:name :position-derive-type)
5496 (let ((f (compile nil
5497 '(lambda (x)
5498 (declare (type (simple-string 90) x))
5499 (declare (muffle-conditions code-deletion-note))
5500 (let ((b (position #\i x)))
5501 (if (and (integerp b) (> b 100))
5502 'yikes 'okey-dokey))))))
5503 ;; The function can not return YIKES
5504 (assert (not (ctu:find-code-constants f :type '(eql yikes))))))
5505
5506 (with-test (:name :compile-file-error-position-reporting)
5507 (dolist (input '("data/wonky1.lisp" "data/wonky2.lisp" "data/wonky3.lisp"))
5508 (let ((expect (with-open-file (f input) (read f))))
5509 (assert (stringp expect))
5510 (let ((err-string (with-output-to-string (*error-output*)
5511 (compile-file input :print nil))))
5512 (assert (search expect err-string))))))
5513
5514 (with-test (:name :coerce-derive-type)
5515 (macrolet ((check (type ll form &rest values)
5516 `(assert (equal (funcall (compile nil `(lambda ,',ll
5517 (ctu:compiler-derived-type ,',form)))
5518 ,@values)
5519 ',type))))
5520 (check list
5521 (a)
5522 (coerce a 'list)
5523 nil)
5524 (check (unsigned-byte 32)
5525 (a)
5526 (coerce a '(unsigned-byte 32))
5527 10)
5528 (check character
5529 (a x)
5530 (coerce a (array-element-type (the (array character) x)))
5531 #\a
5532 "abc")
5533 (check (unsigned-byte 32)
5534 (a x)
5535 (coerce a (array-element-type (the (array (unsigned-byte 32)) x)))
5536 10
5537 (make-array 10 :element-type '(unsigned-byte 32)))))
5538
5539 (with-test (:name :associate-args)
5540 (assert-error
5541 (funcall (compile nil `(lambda (x) (+ 1 x nil)))
5542 2))
5543 (assert-error
5544 (funcall (compile nil `(lambda (x) (/ 1 x nil))) 4)))
5545
5546 (with-test (:name :eager-substitute-single-use-lvar)
5547 (assert (= (funcall
5548 (compile nil
5549 `(lambda (a)
5550 (declare (optimize (debug 0) (safety 0)))
5551 (let ((a (the fixnum a))
5552 (x 1)
5553 z)
5554 (tagbody
5555 (flet ((jump () (go loop)))
5556 (jump))
5557 loop
5558 (setf z (the fixnum (if (= x 1) #xFFF a)))
5559 (unless (= x 0)
5560 (setf x 0)
5561 (go loop)))
5562 z)))
5563 2))))
5564
5565 (with-test (:name :vop-on-eql-type)
5566 (assert (= (funcall
5567 (funcall (compile nil
5568 `(lambda (b)
5569 (declare ((eql -7) b)
5570 (optimize debug))
5571 (lambda (x)
5572 (logior x b))))
5573 -7)
5574 3)
5575 -5)))
5576
5577 (with-test (:name :malformed-macrolet)
5578 (flet ((test (form)
5579 (multiple-value-bind (fun warn fail)
5580 (compile nil `(lambda () ,form))
5581 (assert (and warn fail))
5582 (assert-error (funcall fun) sb-int:compiled-program-error))))
5583 (test '(macrolet (foo () 'bar)))
5584 (test '(macrolet x))
5585 (test '(symbol-macrolet x))
5586 (test '(symbol-macrolet (x)))))
5587
5588
5589 (with-test (:name :malformed-flet)
5590 (flet ((test (form)
5591 (multiple-value-bind (fun warn fail)
5592 (compile nil `(lambda () ,form))
5593 (assert (and warn fail))
5594 (assert-error (funcall fun) sb-int:compiled-program-error))))
5595 (test '(flet (foo () 'bar)))
5596 (test '(flet x))
5597 (test '(labels (foo () 'bar)))
5598 (test '(labels x))))
Common Lisp compiler and runtime