1 ;;;; various compiler tests without side effects
3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; While most of SBCL is derived from the CMU CL system, the test
7 ;;;; files (like this one) were written from scratch after the fork
10 ;;;; This software is in the public domain and is provided with
11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
12 ;;;; more information.
14 (cl:in-package
:cl-user
)
16 (load "compiler-test-util.lisp")
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
))
22 ;;; Exercise a compiler bug (by crashing the compiler).
24 ;;; This test code is from Douglas Crosher's simplified TICKLE-BUG
25 ;;; (2000-09-06 on cmucl-imp).
27 ;;; The bug was fixed by Douglas Crosher's patch, massaged for SBCL by
28 ;;; Martin Atzmueller (2000-09-13 on sbcl-devel).
48 ;;; Exercise a compiler bug (by crashing the compiler).
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.
55 (block used-by-some-y?
59 (return-from used-by-some-y? t
)))))
60 (declare (inline frob
))
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)
74 (declare (special x
)) y
)))))
75 (assert (= 1 ; (used to give 1 even under bug 112, still works after fix)
80 (declare (special x
)) y
)))))
82 ;;; another LET-related bug fixed by Alexey Dejneka at the same
84 (multiple-value-bind (fun warnings-p failure-p
)
85 ;; should complain about duplicate variable names in LET binding
91 (declare (ignore warnings-p
))
92 (assert (functionp fun
))
95 ;;; bug 169 (reported by Alexey Dejneka 2002-05-12, fixed by David
96 ;;; Lichteblau 2002-05-21)
98 (multiple-value-bind (fun warnings-p failure-p
)
100 ;; Compiling this code should cause a STYLE-WARNING
101 ;; about *X* looking like a special variable but not
105 (funcall (symbol-function 'x-getter
))
107 (assert (functionp fun
))
109 (assert (not failure-p
)))
110 (multiple-value-bind (fun warnings-p failure-p
)
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).
117 (declare (special *x
*))
118 (funcall (symbol-function 'x-getter
))
120 (assert (functionp fun
))
121 (assert (not warnings-p
))
122 (assert (not failure-p
))))
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*
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
)))
136 (when (typep i
'(and integer
(satisfies oddp
)))
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
)))
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))))))
150 ;;; on the PPC, we got the magic numbers in undefined_tramp wrong for
151 ;;; a while; fixed by CSR 2002-07-18
152 (multiple-value-bind (value error
)
153 (ignore-errors (some-undefined-function))
154 (assert (null value
))
155 (assert (eq (cell-error-name error
) 'some-undefined-function
)))
157 ;;; Non-symbols shouldn't be allowed as VARs in lambda lists. (Where VAR
158 ;;; is a variable name, as in section 3.4.1 of the ANSI spec.)
159 (assert (null (ignore-errors (eval '(lambda ("foo") 12)))))
160 (assert (ignore-errors (eval '(lambda (foo) 12))))
161 (assert (null (ignore-errors (eval '(lambda (&optional
12) "foo")))))
162 (assert (ignore-errors (eval '(lambda (&optional twelve
) "foo"))))
163 (assert (null (ignore-errors (eval '(lambda (&optional
(12 12)) "foo")))))
164 (assert (ignore-errors (eval '(lambda (&optional
(twelve 12)) "foo"))))
165 (assert (null (ignore-errors (eval '(lambda (&key
#\c
) "foo")))))
166 (assert (ignore-errors (eval '(lambda (&key c
) "foo"))))
167 (assert (null (ignore-errors (eval '(lambda (&key
(#\c
#\c
)) "foo")))))
168 (assert (ignore-errors (eval '(lambda (&key
(c #\c
)) "foo"))))
169 (assert (null (ignore-errors (eval '(lambda (&key
((#\c
#\c
) #\c
)) "foo")))))
170 (assert (ignore-errors (eval '(lambda (&key
((:c cbyanyothername
) #\c
)) "foo"))))
172 ;;; As reported and fixed by Antonio Martinez-Shotton sbcl-devel
173 ;;; 2002-09-12, this failed in sbcl-0.7.7.23. (with failed AVER
174 ;;; "(LEAF-HAS-SOURCE-NAME-P LEAF)")
175 (assert (= (funcall (eval `(lambda (x) (funcall ,(lambda (y) (+ y
3)) x
))) 14)
178 ;;; bug 181: bad type specifier dropped compiler into debugger
179 (assert (list (compile nil
'(lambda (x)
180 (declare (type (0) x
))
183 (let ((f (compile nil
'(lambda (x)
184 (make-array 1 :element-type
'(0))))))
185 (assert (null (ignore-errors (funcall f
)))))
187 ;;; the following functions must not be flushable
188 (dolist (form '((make-sequence 'fixnum
10)
189 (concatenate 'fixnum nil
)
190 (map 'fixnum
#'identity nil
)
191 (merge 'fixnum nil nil
#'<)))
192 (assert (not (eval `(locally (declare (optimize (safety 0)))
193 (ignore-errors (progn ,form t
)))))))
195 (dolist (form '((values-list (car (list '(1 .
2))))
197 (atan #c
(1 1) (car (list #c
(2 2))))
198 (nthcdr (car (list (floor (cos 3)))) '(1 2 3 4 5))
199 (nthcdr (car (list 5)) '(1 2 .
3))))
200 (assert (not (eval `(locally (declare (optimize (safety 3)))
201 (ignore-errors (progn ,form t
)))))))
203 ;;; feature: we shall complain if functions which are only useful for
204 ;;; their result are called and their result ignored.
205 (loop for
(form expected-des
) in
206 '(((progn (nreverse (list 1 2)) t
)
207 "The return value of NREVERSE should not be discarded.")
208 ((progn (nreconc (list 1 2) (list 3 4)) t
)
209 "The return value of NRECONC should not be discarded.")
211 (declare (inline sort
))
212 (sort (list 1 2) #'<) t
)
213 ;; FIXME: it would be nice if this warned on non-inlined sort
214 ;; but the current simple boolean function attribute
215 ;; can't express the condition that would be required.
216 "The return value of STABLE-SORT-LIST should not be discarded.")
217 ((progn (sort (vector 1 2) #'<) t
)
218 ;; Apparently, SBCL (but not CL) guarantees in-place vector
219 ;; sort, so no warning.
221 ((progn (delete 2 (list 1 2)) t
)
222 "The return value of DELETE should not be discarded.")
223 ((progn (delete-if #'evenp
(list 1 2)) t
)
224 ("The return value of DELETE-IF should not be discarded."))
225 ((progn (delete-if #'evenp
(vector 1 2)) t
)
226 ("The return value of DELETE-IF should not be discarded."))
227 ((progn (delete-if-not #'evenp
(list 1 2)) t
)
228 "The return value of DELETE-IF-NOT should not be discarded.")
229 ((progn (delete-duplicates (list 1 2)) t
)
230 "The return value of DELETE-DUPLICATES should not be discarded.")
231 ((progn (merge 'list
(list 1 3) (list 2 4) #'<) t
)
232 "The return value of MERGE should not be discarded.")
233 ((progn (nreconc (list 1 3) (list 2 4)) t
)
234 "The return value of NRECONC should not be discarded.")
235 ((progn (nunion (list 1 3) (list 2 4)) t
)
236 "The return value of NUNION should not be discarded.")
237 ((progn (nintersection (list 1 3) (list 2 4)) t
)
238 "The return value of NINTERSECTION should not be discarded.")
239 ((progn (nset-difference (list 1 3) (list 2 4)) t
)
240 "The return value of NSET-DIFFERENCE should not be discarded.")
241 ((progn (nset-exclusive-or (list 1 3) (list 2 4)) t
)
242 "The return value of NSET-EXCLUSIVE-OR should not be discarded."))
243 for expected
= (if (listp expected-des
)
247 (multiple-value-bind (fun warnings-p failure-p
)
248 (handler-bind ((style-warning (lambda (c)
250 (let ((expect-one (pop expected
)))
251 (assert (search expect-one
252 (with-standard-io-syntax
253 (let ((*print-right-margin
* nil
))
254 (princ-to-string c
))))
256 "~S should have warned ~S, but instead warned: ~A"
258 (error "~S shouldn't give a(nother) warning, but did: ~A" form c
)))))
259 (compile nil
`(lambda () ,form
)))
260 (declare (ignore warnings-p
))
261 (assert (functionp fun
))
262 (assert (null expected
)
264 "~S should have warned ~S, but didn't."
266 (assert (not failure-p
))))
268 ;;; a bug in the MAP deftransform caused non-VECTOR array specifiers
269 ;;; to cause errors in the compiler. Fixed by CSR in 0.7.8.10
270 (assert (list (compile nil
'(lambda (x) (map 'simple-array
'identity x
)))))
272 ;;; bug 129: insufficient syntax checking in MACROLET
273 (multiple-value-bind (result error
)
274 (ignore-errors (eval '(macrolet ((foo x
`',x
)) (foo 1 2 3))))
275 (assert (null result
))
276 (assert (typep error
'error
)))
278 ;;; bug 124: environment of MACROLET-introduced macro expanders
280 (macrolet ((mext (x) `(cons :mext
,x
)))
281 (macrolet ((mint (y) `'(:mint
,(mext y
))))
284 '((:MEXT
1 2) (:MINT
(:MEXT
1 2)))))
286 ;;; bug 48c: SYMBOL-MACROLET should signal PROGRAM-ERROR if introduced
287 ;;; symbol is declared to be SPECIAL
288 (multiple-value-bind (result error
)
289 (ignore-errors (funcall (lambda ()
290 (symbol-macrolet ((s '(1 2)))
291 (declare (special s
))
293 (assert (null result
))
294 (assert (typep error
'program-error
)))
296 ;;; ECASE should treat a bare T as a literal key
297 (multiple-value-bind (result error
)
298 (ignore-errors (ecase 1 (t 0)))
299 (assert (null result
))
300 (assert (typep error
'type-error
)))
302 (multiple-value-bind (result error
)
303 (ignore-errors (ecase 1 (t 0) (1 2)))
304 (assert (eql result
2))
305 (assert (null error
)))
307 ;;; FTYPE should accept any functional type specifier
308 (compile nil
'(lambda (x) (declare (ftype function f
)) (f x
)))
310 ;;; FUNCALL of special operators and macros should signal an
311 ;;; UNDEFINED-FUNCTION error
312 (multiple-value-bind (result error
)
313 (ignore-errors (funcall 'quote
1))
314 (assert (null result
))
315 (assert (typep error
'undefined-function
))
316 (assert (eq (cell-error-name error
) 'quote
)))
317 (multiple-value-bind (result error
)
318 (ignore-errors (funcall 'and
1))
319 (assert (null result
))
320 (assert (typep error
'undefined-function
))
321 (assert (eq (cell-error-name error
) 'and
)))
323 ;;; PSETQ should behave when given complex symbol-macro arguments
324 (multiple-value-bind (sequence index
)
325 (symbol-macrolet ((x (aref a
(incf i
)))
326 (y (aref a
(incf i
))))
327 (let ((a (copy-seq #(0 1 2 3 4 5 6 7 8 9)))
329 (psetq x
(aref a
(incf i
))
332 (assert (equalp sequence
#(0 2 2 4 4 5 6 7 8 9)))
333 (assert (= index
4)))
335 (multiple-value-bind (result error
)
337 (let ((x (list 1 2)))
340 (assert (null result
))
341 (assert (typep error
'program-error
)))
343 ;;; COPY-SEQ should work on known-complex vectors:
345 (let ((v (make-array 0 :fill-pointer
0)))
346 (vector-push-extend 1 v
)
349 ;;; to support INLINE functions inside MACROLET, it is necessary for
350 ;;; FUNCTION-LAMBDA-EXPRESSION to return a proper lambda expression in
351 ;;; certain circumstances, one of which is when compile is called from
354 (function-lambda-expression
355 (compile nil
'(lambda (x) (block nil
(print x
)))))
356 '(lambda (x) (block nil
(print x
)))))
358 ;;; bug 62: too cautious type inference in a loop
363 (declare (optimize speed
(safety 0)))
365 (array (loop (print (car a
)))))))))
367 ;;; Bug reported by Robert E. Brown sbcl-devel 2003-02-02: compiler
370 '(lambda (key tree collect-path-p
)
371 (let ((lessp (key-lessp tree
))
372 (equalp (key-equalp tree
)))
373 (declare (type (function (t t
) boolean
) lessp equalp
))
375 (loop for node
= (root-node tree
)
376 then
(if (funcall lessp key
(node-key node
))
380 do
(return (values nil nil nil
))
381 do
(when collect-path-p
383 (when (funcall equalp key
(node-key node
))
384 (return (values node path t
))))))))
386 ;;; CONSTANTLY should return a side-effect-free function (bug caught
387 ;;; by Paul Dietz' test suite)
389 (let ((fn (constantly (progn (incf i
) 1))))
391 (assert (= (funcall fn
) 1))
393 (assert (= (funcall fn
) 1))
396 ;;; Bug 240 reported by tonyms on #lisp IRC 2003-02-25 (modified version)
397 (loop for
(fun warns-p
) in
398 '(((lambda (&optional
*x
*) *x
*) t
)
399 ((lambda (&optional
*x
* &rest y
) (values *x
* y
)) t
)
400 ((lambda (&optional
*print-length
*) (values *print-length
*)) nil
)
401 ((lambda (&optional
*print-length
* &rest y
) (values *print-length
* y
)) nil
)
402 ((lambda (&optional
*x
*) (declare (special *x
*)) (values *x
*)) nil
)
403 ((lambda (&optional
*x
* &rest y
) (declare (special *x
*)) (values *x
* y
)) nil
))
404 for real-warns-p
= (nth-value 1 (compile nil fun
))
405 do
(assert (eq warns-p real-warns-p
)))
407 ;;; Bug reported by Gilbert Baumann on #lisp IRC 2003-03-26
408 (assert (equal (funcall (eval '(lambda (x &optional
(y (pop x
))) (list x y
)))
412 ;;; Bug reported by Paul Dietz on cmucl-imp and fixed by Gerd
413 ;;; Moellmann: CONVERT-MORE-CALL failed on the following call
414 (assert (eq (eval '((lambda (&key
) 'u
) :allow-other-keys nil
)) 'u
))
417 (raises-error?
(multiple-value-bind (a b c
)
418 (eval '(truncate 3 4))
419 (declare (integer c
))
423 (assert (equal (multiple-value-list (the (values &rest integer
)
427 ;;; Bug relating to confused representation for the wild function
429 (assert (null (funcall (eval '(lambda () (multiple-value-list (values)))))))
431 ;;; &ENVIRONMENT parameter should be bound first (from Paul Dietz'
433 (assert (eql (macrolet ((foo () 1))
434 (macrolet ((%f
(&optional
(x (macroexpand '(foo) env
)) &environment env
)
439 ;;; MACROLET should check for duplicated names
440 (dolist (ll '((x (z x
))
441 (x y
&optional z x w
)
445 (x &optional
(y nil x
))
446 (x &optional
(y nil y
))
449 (&key
(y nil z
) (z nil w
))
450 (&whole x
&optional x
)
451 (&environment x
&whole x
)))
456 (macrolet ((foo ,ll nil
)
457 (bar (&environment env
)
458 `',(macro-function 'foo env
)))
461 (values nil t t
))))))
463 (assert (typep (eval `(the arithmetic-error
464 ',(make-condition 'arithmetic-error
)))
467 (assert (not (nth-value
468 2 (compile nil
'(lambda ()
469 (make-array nil
:initial-element
11))))))
471 (assert (raises-error?
(funcall (eval #'open
) "assertoid.lisp"
472 :external-format
'#:nonsense
)))
473 (assert (raises-error?
(funcall (eval #'load
) "assertoid.lisp"
474 :external-format
'#:nonsense
)))
476 (assert (= (the (values integer symbol
) (values 1 'foo
13)) 1))
478 (let ((f (compile nil
480 (declare (optimize (safety 3)))
481 (list (the fixnum
(the (real 0) (eval v
))))))))
482 (assert (raises-error?
(funcall f
0.1) type-error
))
483 (assert (raises-error?
(funcall f -
1) type-error
)))
485 ;;; the implicit block does not enclose lambda list
486 (let ((forms '((defmacro #1=#:foo
(&optional
(x (return-from #1#))))
487 #+nil
(macrolet ((#2=#:foo
(&optional
(x (return-from #2#))))))
488 (define-compiler-macro #3=#:foo
(&optional
(x (return-from #3#))))
489 (deftype #4=#:foo
(&optional
(x (return-from #4#))))
490 (define-setf-expander #5=#:foo
(&optional
(x (return-from #5#))))
491 (defsetf #6=#:foo
(&optional
(x (return-from #6#))) ()))))
493 (assert (nth-value 2 (compile nil
`(lambda () ,form
))))))
495 (assert (nth-value 2 (compile nil
497 (svref (make-array '(8 9) :adjustable t
) 1)))))
499 ;;; CHAR= did not check types of its arguments (reported by Adam Warner)
500 (raises-error?
(funcall (compile nil
'(lambda (x y z
) (char= x y z
)))
503 (raises-error?
(funcall (compile nil
505 (declare (optimize (speed 3) (safety 3)))
510 ;;; Compiler lost return type of MAPCAR and friends
511 (dolist (fun '(mapcar mapc maplist mapl
))
512 (assert (nth-value 2 (compile nil
514 (1+ (,fun
#'print x
)))))))
516 (assert (nth-value 2 (compile nil
518 (declare (notinline mapcar
))
519 (1+ (mapcar #'print
'(1 2 3)))))))
521 ;;; bug found by Paul Dietz: (SETF AREF) for bit vectors with constant
522 ;;; index was effectless
523 (let ((f (compile nil
'(lambda (a v
)
524 (declare (type simple-bit-vector a
) (type bit v
))
525 (declare (optimize (speed 3) (safety 0)))
528 (let ((y (make-array 2 :element-type
'bit
:initial-element
0)))
529 (assert (equal y
#*00))
531 (assert (equal y
#*10))))
533 ;;; use of declared array types
534 (handler-bind ((sb-ext:compiler-note
#'error
))
535 (compile nil
'(lambda (x)
536 (declare (type (simple-array (simple-string 3) (5)) x
)
538 (aref (aref x
0) 0))))
540 (handler-bind ((sb-ext:compiler-note
#'error
))
541 (compile nil
'(lambda (x)
542 (declare (type (simple-array (simple-array bit
(10)) (10)) x
)
544 (1+ (aref (aref x
0) 0)))))
547 (let ((f (compile nil
'(lambda (x) (typep x
'(not (member 0d0
)))))))
548 (assert (funcall f
1d0
)))
550 (compile nil
'(lambda (x)
551 (declare (double-float x
))
555 ;;; bogus optimization of BIT-NOT
556 (multiple-value-bind (result x
)
557 (eval '(let ((x (eval #*1001)))
558 (declare (optimize (speed 2) (space 3))
559 (type (bit-vector) x
))
560 (values (bit-not x nil
) x
)))
561 (assert (equal x
#*1001))
562 (assert (equal result
#*0110)))
564 ;;; the VECTOR type in CONCATENATE/MERGE/MAKE-SEQUENCE means (VECTOR T).
565 (handler-bind ((sb-ext:compiler-note
#'error
))
566 (assert (equalp (funcall
570 (let ((x (make-sequence 'vector
10 :initial-element
'a
)))
573 #(a a a a b a a a a a
))))
575 ;;; this is not a check for a bug, but rather a test of compiler
577 (dolist (type '((integer 0 *) ; upper bound
580 (real * (-10)) ; lower bound
585 (declare (optimize (speed 3) (compilation-speed 0)))
586 (loop for i from
1 to
(the (integer -
17 10) n
) by
2
587 collect
(when (> (random 10) 5)
588 (the ,type
(- i
11)))))))))
592 ;;; We suppose that INTEGER arithmetic cannot be efficient, and the
593 ;;; compiler has an optimized VOP for +; so this code should cause an
595 (assert (eq (block nil
597 (compile nil
'(lambda (i)
598 (declare (optimize speed
))
599 (declare (type integer i
))
601 (sb-ext:compiler-note
(c) (return :good
))))
604 ;;; bug 277: IGNORE/IGNORABLE declarations should be acceptable for
606 (assert (not (nth-value 1 (compile nil
'(lambda (u v
)
607 (symbol-macrolet ((x u
)
613 ;;; bug reported by Paul Dietz: wrong optimizer for (EXPT ... 0)
614 (loop for
(x type
) in
617 (-14/3 (rational -
8 11))
626 (#c
(-3 4) (complex fixnum
))
627 (#c
(-3 4) (complex rational
))
628 (#c
(-3/7 4) (complex rational
))
629 (#c
(2s0 3s0
) (complex short-float
))
630 (#c
(2f0 3f0
) (complex single-float
))
631 (#c
(2d0 3d0
) (complex double-float
))
632 (#c
(2l0 3l0) (complex long-float
))
633 (#c
(2d0 3s0
) (complex float
))
634 (#c
(2 3f0
) (complex real
))
635 (#c
(2 3d0
) (complex real
))
636 (#c
(-3/7 4) (complex real
))
639 do
(dolist (zero '(0 0s0
0f0
0d0
0l0))
640 (dolist (real-zero (list zero
(- zero
)))
641 (let* ((src `(lambda (x) (expt (the ,type x
) ,real-zero
)))
642 (fun (compile nil src
))
643 (result (1+ (funcall (eval #'*) x real-zero
))))
644 (assert (eql result
(funcall fun x
)))))))
646 ;;; (SIGNED-BYTE 1) [ returned from the logxor derive-type optimizer ]
647 ;;; wasn't recognized as a good type specifier.
648 (let ((fun (lambda (x y
)
649 (declare (type (integer -
1 0) x y
) (optimize speed
))
651 (assert (= (funcall fun
0 0) 0))
652 (assert (= (funcall fun
0 -
1) -
1))
653 (assert (= (funcall fun -
1 -
1) 0)))
655 ;;; from PFD's torture test, triggering a bug in our effective address
660 (declare (type (integer 8 22337) b
))
663 (* (logandc1 (max -
29303 b
) 4) b
)
664 (abs (logorc1 (+ (logandc1 -
11 b
) 2607688420) -
31153924)))
665 (logeqv (max a
0) b
))))
667 ;;; Alpha floating point modes weren't being reset after an exception,
668 ;;; leading to an exception on the second compile, below.
669 (compile nil
'(lambda (x y
) (declare (type (double-float 0.0d0
) x y
)) (/ x y
)))
670 (handler-case (/ 1.0 0.0)
671 ;; provoke an exception
672 (arithmetic-error ()))
673 (compile nil
'(lambda (x y
) (declare (type (double-float 0.0d0
) x y
)) (/ x y
)))
675 ;;; bug reported by Paul Dietz: component last block does not have
679 (declare (notinline + logand
)
680 (optimize (speed 0)))
684 (RETURN-FROM B5 -
220)))
686 (+ 359749 35728422))))
689 ;;; bug 294 reported by Paul Dietz: miscompilation of REM and MOD
690 (assert (= (funcall (compile nil
`(lambda (b)
691 (declare (optimize (speed 3))
692 (type (integer 2 152044363) b
))
693 (rem b
(min -
16 0))))
697 (assert (= (funcall (compile nil
`(lambda (c)
698 (declare (optimize (speed 3))
699 (type (integer 23062188 149459656) c
))
704 ;;; bug reported by Paul Dietz: block splitting inside FLUSH-DEAD-CODE
708 (LOGEQV (REM C -
6758)
709 (REM B
(MAX 44 (RETURN-FROM B6 A
)))))))
711 (compile nil
'(lambda ()
713 (flet ((foo (x y
) (if (> x y
) (print x
) (print y
))))
716 (foo (return 14) 2)))))
718 ;;; bug in Alpha backend: not enough sanity checking of arguments to
720 (assert (= (funcall (compile nil
727 ;;; bug found by WHN and pfdietz: compiler failure while referencing
728 ;;; an entry point inside a deleted lambda
729 (compile nil
'(lambda ()
734 (flet ((truly (fn bbd
)
738 (multiple-value-prog1
755 (wum #'bbfn
"hc3" (list)))
757 (compile nil
'(lambda () (flet ((%f
() (unwind-protect nil
))) nil
)))
759 ;;; the strength reduction of constant multiplication used (before
760 ;;; sbcl-0.8.4.x) to lie to the compiler. This meant that, under
761 ;;; certain circumstances, the compiler would derive that a perfectly
762 ;;; reasonable multiplication never returned, causing chaos. Fixed by
763 ;;; explicitly doing modular arithmetic, and relying on the backends
768 (declare (type (integer 178956970 178956970) x
)
774 ;;; bug in modular arithmetic and type specifiers
775 (assert (= (funcall (compile nil
(lambda (x) (logand x x
0)))
779 ;;; MISC.99 from Paul Dietz' random tester: FAST-ASH-MOD32-C VOP
780 ;;; produced wrong result for shift >=32 on X86
781 (assert (= 0 (funcall
784 (declare (type (integer 4303063 101130078) a
))
785 (mask-field (byte 18 2) (ash a
77))))
787 ;;; rewrite the test case to get the unsigned-byte 32/64
788 ;;; implementation even after implementing some modular arithmetic
789 ;;; with signed-byte 30:
790 (assert (= 0 (funcall
793 (declare (type (integer 4303063 101130078) a
))
794 (mask-field (byte 30 2) (ash a
77))))
796 (assert (= 0 (funcall
799 (declare (type (integer 4303063 101130078) a
))
800 (mask-field (byte 64 2) (ash a
77))))
802 ;;; and a similar test case for the signed masking extension (not the
803 ;;; final interface, so change the call when necessary):
804 (assert (= 0 (funcall
807 (declare (type (integer 4303063 101130078) a
))
808 (sb-c::mask-signed-field
30 (ash a
77))))
810 (assert (= 0 (funcall
813 (declare (type (integer 4303063 101130078) a
))
814 (sb-c::mask-signed-field
61 (ash a
77))))
817 ;;; MISC.101 and MISC.103: FLUSH-DEST did not mark the USE's block for
818 ;;; type check regeneration
819 (assert (eql (funcall
820 (compile nil
'(lambda (a c
)
821 (declare (type (integer 185501219873 303014665162) a
))
822 (declare (type (integer -
160758 255724) c
))
823 (declare (optimize (speed 3)))
825 (- -
554046873252388011622614991634432
827 (unwind-protect 2791485))))
828 (max (ignore-errors a
)
829 (let ((v6 (- v8
(restart-case 980))))
833 (assert (eql (funcall
834 (compile nil
'(lambda (a b
)
842 (load-time-value -
6876935))))
843 (if (logbitp 1 a
) b
(setq a -
1522022182249))))))))
844 -
1802767029877 -
12374959963)
847 ;;; various MISC.*, related to NODEs/LVARs with derived type NIL
848 (assert (eql (funcall (compile nil
'(lambda (c)
849 (declare (type (integer -
3924 1001809828) c
))
850 (declare (optimize (speed 3)))
851 (min 47 (if (ldb-test (byte 2 14) c
)
853 (ignore-errors -
732893970)))))
856 (assert (eql (funcall
857 (compile nil
'(lambda (b)
858 (declare (type (integer -
1598566306 2941) b
))
859 (declare (optimize (speed 3)))
860 (max -
148949 (ignore-errors b
))))
863 (assert (eql (funcall
864 (compile nil
'(lambda (b c
)
865 (declare (type (integer -
4 -
3) c
))
867 (flet ((%f1
(f1-1 f1-2 f1-3
)
868 (if (logbitp 0 (return-from b7
869 (- -
815145138 f1-2
)))
870 (return-from b7 -
2611670)
872 (let ((v2 (%f1 -
2464 (%f1 -
1146 c c
) -
2)))
876 (assert (eql (funcall
879 (declare (type (integer -
29742055786 23602182204) b
))
880 (declare (type (integer -
7409 -
2075) c
))
881 (declare (optimize (speed 3)))
885 (ignore-errors (return-from b6
886 (if (= c
8) b
82674))))))
890 (assert (equal (multiple-value-list
892 (compile nil
'(lambda (a)
893 (declare (type (integer -
944 -
472) a
))
894 (declare (optimize (speed 3)))
898 (if (= 55957 a
) -
117 (ignore-errors
899 (return-from b3 a
))))))))
904 (assert (zerop (funcall
907 (declare (type (integer 79828 2625480458) a
))
908 (declare (type (integer -
4363283 8171697) b
))
909 (declare (type (integer -
301 0) c
))
910 (if (equal 6392154 (logxor a b
))
914 (logior (logandc2 c v5
)
915 (common-lisp:handler-case
916 (ash a
(min 36 22477)))))))))
919 ;;; MISC.152, 153: deleted code and iteration var type inference
920 (assert (eql (funcall
924 (let ((v1 (let ((v8 (unwind-protect 9365)))
928 (labels ((%f11
(f11-1) f11-1
))
932 (labels ((%f6
(f6-1 f6-2 f6-3
) v1
))
933 (dpb (unwind-protect a
)
935 (labels ((%f4
() 27322826))
936 (%f6 -
2 -
108626545 (%f4
))))))))))))
940 (assert (eql (funcall
945 ((-96879 -
1035 -
57680 -
106404 -
94516 -
125088)
946 (unwind-protect 90309179))
947 ((-20811 -
86901 -
9368 -
98520 -
71594)
948 (let ((v9 (unwind-protect 136707)))
951 (let ((v4 (return-from b3 v9
)))
952 (- (ignore-errors (return-from b3 v4
))))))))
960 (assert (eql (funcall
971 &optional
(f17-4 185155520) (f17-5 c
)
974 (%f17 -
1046 a
1115306 (%f17 b -
146330 422) -
337817)))
975 (f15-5 a
) (f15-6 -
40))
976 (return-from b3 -
16)))
977 (multiple-value-call #'%f15
(values -
519354 a
121 c -
1905))))))
982 (assert (eql (funcall
986 (declare (notinline list apply
))
987 (declare (optimize (safety 3)))
988 (declare (optimize (speed 0)))
989 (declare (optimize (debug 0)))
990 (labels ((%f12
(f12-1 f12-2
)
991 (labels ((%f2
(f2-1 f2-2
)
998 (return-from %f12 b
)))
1001 (%f18
(%f18
150 -
64 f12-1
)
1008 &optional
(f7-3 (%f6
)))
1011 (%f2 b -
36582571))))
1012 (apply #'%f12
(list 774 -
4413)))))
1017 (assert (eql (funcall
1021 (declare (notinline values
))
1022 (declare (optimize (safety 3)))
1023 (declare (optimize (speed 0)))
1024 (declare (optimize (debug 0)))
1027 &optional
(f11-3 c
) (f11-4 7947114)
1029 (flet ((%f3
(f3-1 &optional
(f3-2 b
) (f3-3 5529))
1031 (multiple-value-call #'%f3
1032 (values (%f3 -
30637724 b
) c
)))))
1034 (if (and nil
(%f11 a a
))
1035 (if (%f11 a
421778 4030 1)
1041 (%f11 c a c -
4 214720)
1053 ;;; MISC.177, 182: IR2 copy propagation missed a hidden write to a
1054 ;;; local lambda argument
1060 (declare (type (integer 804561 7640697) a
))
1061 (declare (type (integer -
1 10441401) b
))
1062 (declare (type (integer -
864634669 55189745) c
))
1063 (declare (ignorable a b c
))
1064 (declare (optimize (speed 3)))
1065 (declare (optimize (safety 1)))
1066 (declare (optimize (debug 1)))
1069 (labels ((%f4
() (round 200048 (max 99 c
))))
1072 (labels ((%f3
(f3-1) -
162967612))
1073 (%f3
(let* ((v8 (%f4
)))
1074 (setq f11-1
(%f4
)))))))))
1075 (%f11 -
120429363 (%f11
62362 b
)))))
1076 6714367 9645616 -
637681868)
1079 ;;; Bug reported by Paul F. Dietz caused by derive type loss in VALUE
1081 (assert (equal (multiple-value-list
1083 (compile nil
'(lambda ()
1084 (declare (optimize (speed 1) (space 0) (safety 3) (debug 3) (compilation-speed 1)))
1087 (flet ((%f16
() 0)) (%f16
))))))))
1096 (declare (type (integer 867934833 3293695878) a
))
1097 (declare (type (integer -
82111 1776797) b
))
1098 (declare (type (integer -
1432413516 54121964) c
))
1099 (declare (optimize (speed 3)))
1100 (declare (optimize (safety 1)))
1101 (declare (optimize (debug 1)))
1103 (flet ((%f15
(f15-1 &optional
(f15-2 c
))
1104 (labels ((%f1
(f1-1 f1-2
) 0))
1107 (multiple-value-call #'%f15
1108 (values (%f15 c
0) (%f15
0)))))
1110 (flet ((%f8
(f8-1 &optional
(f8-2 (%f4
)) (f8-3 0))
1114 3040851270 1664281 -
1340106197)))
1122 (declare (notinline <=))
1123 (declare (optimize (speed 2) (space 3) (safety 0)
1124 (debug 1) (compilation-speed 3)))
1125 (if (if (<= 0) nil nil
)
1126 (labels ((%f9
(f9-1 f9-2 f9-3
)
1128 (dotimes (iv4 5 a
) (%f9
0 0 b
)))
1132 ;;; MISC.259-264 (aka "CSR screwed up implementing *-MOD32")
1138 (declare (type (integer 177547470 226026978) a
))
1139 (declare (optimize (speed 3) (space 0) (safety 0) (debug 0)
1140 (compilation-speed 1)))
1141 (logand a
(* a
438810))))
1146 ;;;; Bugs in stack analysis
1147 ;;; bug 299 (reported by PFD)
1153 (declare (optimize (debug 1)))
1154 (multiple-value-call #'list
1155 (if (eval t
) (eval '(values :a
:b
:c
)) nil
)
1156 (catch 'foo
(throw 'foo
(values :x
:y
)))))))
1158 ;;; bug 298 (= MISC.183)
1159 (assert (zerop (funcall
1163 (declare (type (integer -
368154 377964) a
))
1164 (declare (type (integer 5044 14959) b
))
1165 (declare (type (integer -
184859815 -
8066427) c
))
1166 (declare (ignorable a b c
))
1167 (declare (optimize (speed 3)))
1168 (declare (optimize (safety 1)))
1169 (declare (optimize (debug 1)))
1171 (flet ((%f3
(f3-1 f3-2 f3-3
) 0))
1172 (apply #'%f3
0 (catch 'foo
(return-from b7
(%f3
0 b c
))) c nil
)))))
1174 (assert (equal (eval '(let () (apply #'list
1 (list (catch 'a
(throw 'a
(block b
2)))))))
1180 (multiple-value-call #'list
1184 (multiple-value-call #'list
1190 (return-from quux
1)
1191 (throw 'baz
2))))))))))))))
1192 (assert (equal (funcall f t
) '(:b
1)))
1193 (assert (equal (funcall f nil
) '(:a
2))))
1201 (declare (type (integer 5 155656586618) a
))
1202 (declare (type (integer -
15492 196529) b
))
1203 (declare (type (integer 7 10) c
))
1204 (declare (optimize (speed 3)))
1205 (declare (optimize (safety 1)))
1206 (declare (optimize (debug 1)))
1209 &optional
(f3-4 a
) (f3-5 0)
1211 (labels ((%f10
(f10-1 f10-2 f10-3
)
1216 (- (if (equal a b
) b
(%f10 c a
0))
1217 (catch 'ct2
(throw 'ct2 c
)))
1220 (%f3
(%f3
(%f3 b
0 0 0) a
0) a b b b c
)))) 5 0 7)
1225 '(let* ((form '(labels ((%f3
(f3-1 f3-2
) f3-1
))
1226 (apply #'%f3 b
(catch 'ct8
(throw 'ct8
(logeqv (%f3 c
0)))) nil
)))
1229 (declare (type (integer -
2 19) b
)
1230 (type (integer -
1520 218978) c
)
1231 (optimize (speed 3) (safety 1) (debug 1)))
1234 (declare (notinline logeqv apply
)
1235 (optimize (safety 3) (speed 0) (debug 0)))
1237 (cf1 (compile nil fn1
))
1238 (cf2 (compile nil fn2
))
1239 (result1 (multiple-value-list (funcall cf1
2 18886)))
1240 (result2 (multiple-value-list (funcall cf2
2 18886))))
1241 (if (equal result1 result2
)
1243 (values result1 result2
))))
1253 (optimize (speed 3) (space 3) (safety 1)
1254 (debug 2) (compilation-speed 0)))
1255 (apply (constantly 0) (catch 'ct2
0) 0 (catch 'ct2
0) nil
))))))
1258 (assert (zerop (funcall
1262 (declare (optimize (speed 2) (space 0) (safety 3) (debug 1)
1263 (compilation-speed 2)))
1264 (apply (constantly 0)
1268 (apply (constantly 0)
1287 (declare (optimize (speed 1) (space 0) (safety 0) (debug 0)))
1288 (multiple-value-prog1
1289 (the integer
(catch 'ct8
(catch 'ct7
15867134)))
1290 (catch 'ct1
(throw 'ct1
0))))))
1293 ;;; misc.361: replacing CAST with (m-v-call #'%compile-time-type-error)
1294 ;;; could transform known-values LVAR to UVL
1295 (assert (zerop (funcall
1299 (declare (notinline boole values denominator list
))
1305 (compilation-speed 2)))
1310 (let ((v9 (ignore-errors (throw 'ct6
0))))
1312 (progv nil nil
(values (boole boole-and
0 v9
)))))))))
1315 ;;; non-continuous dead UVL blocks
1316 (defun non-continuous-stack-test (x)
1317 (multiple-value-call #'list
1318 (eval '(values 11 12))
1319 (eval '(values 13 14))
1321 (return-from non-continuous-stack-test
1322 (multiple-value-call #'list
1323 (eval '(values :b1
:b2
))
1324 (eval '(values :b3
:b4
))
1327 (multiple-value-call (eval #'values
)
1328 (eval '(values 1 2))
1329 (eval '(values 3 4))
1332 (multiple-value-call (eval #'values
)
1333 (eval '(values :a1
:a2
))
1334 (eval '(values :a3
:a4
))
1337 (multiple-value-call (eval #'values
)
1338 (eval '(values 5 6))
1339 (eval '(values 7 8))
1342 (return-from int
:int
))))))))))))))))
1343 (assert (equal (non-continuous-stack-test t
) '(11 12 13 14 1 2 3 4 5 6 7 8 :ext
)))
1344 (assert (equal (non-continuous-stack-test nil
) '(:b1
:b2
:b3
:b4
:a1
:a2
:a3
:a4
:int
)))
1346 ;;; MISC.362: environment of UNWIND-PROTECTor is different from that
1348 (assert (equal (multiple-value-list (funcall
1352 (declare (optimize (speed 3) (space 3) (safety 2)
1353 (debug 2) (compilation-speed 3)))
1356 (labels ((%f15
(f15-1 f15-2 f15-3
)
1357 (rational (throw 'ct5
0))))
1363 (progv '(*s2
* *s5
*) (list 0 (%f15
0 g
0)) b
)
1367 (common-lisp:handler-case
0)))))
1379 (declare (notinline funcall min coerce
))
1385 (compilation-speed 1)))
1386 (flet ((%f12
(f12-1)
1389 (if f12-1
(multiple-value-prog1
1390 b
(return-from %f12
0))
1393 (funcall #'%f12
0))))
1396 ;;; Discussion of a CMUCL PCL bug on Sparc with Raymond Toy revealed a
1397 ;;; potential problem: optimizers and type derivers for MAX and MIN
1398 ;;; were not consistent in treating EQUALP, but not EQL, arguments.
1399 (dolist (f '(min max
))
1400 (loop for complex-arg-args in
'((1d0 2d0
) (0d0 1d0
))
1401 for complex-arg
= `(if x
,@complex-arg-args
)
1403 (loop for args in
`((1 ,complex-arg
)
1405 for form
= `(,f
,@args
)
1406 for f1
= (compile nil
`(lambda (x) ,form
))
1407 and f2
= (compile nil
`(lambda (x) (declare (notinline min max
))
1410 (dolist (x '(nil t
))
1411 (assert (eql (funcall f1 x
) (funcall f2 x
)))))))
1414 (handler-case (compile nil
'(lambda (x)
1415 (declare (optimize (speed 3) (safety 0)))
1416 (the double-float
(sqrt (the double-float x
)))))
1417 (sb-ext:compiler-note
(c)
1418 ;; Ignore the note for the float -> pointer conversion of the
1420 (unless (string= (car (last (sb-c::simple-condition-format-arguments c
)))
1422 (error "Compiler does not trust result type assertion."))))
1424 (let ((f (compile nil
'(lambda (x)
1425 (declare (optimize speed
(safety 0)))
1428 (multiple-value-prog1
1429 (sqrt (the double-float x
))
1431 (return :minus
)))))))))
1432 (assert (eql (funcall f -
1d0
) :minus
))
1433 (assert (eql (funcall f
4d0
) 2d0
)))
1435 ;;; bug 304: SBCL produced something similar to (/ (ASH x 4) 8)
1437 (compile nil
'(lambda (a i
)
1439 (declare (optimize (speed 3) (safety 0) (space 0) (debug 0)
1440 (inhibit-warnings 0)))
1441 (declare (type (alien (* (unsigned 8))) a
)
1442 (type (unsigned-byte 32) i
))
1444 (compiler-note () (error "The code is not optimized.")))
1447 (compile nil
'(lambda (x)
1448 (declare (type (integer -
100 100) x
))
1449 (declare (optimize speed
))
1450 (declare (notinline identity
))
1452 (compiler-note () (error "IDENTITY derive-type not applied.")))
1454 (assert (null (funcall (compile nil
'(lambda (x) (funcall #'cddr x
))) nil
)))
1456 ;;; MISC.293 = easy variant of bug 303: repeated write to the same
1457 ;;; LVAR; here the first write may be cleared before the second is
1465 (declare (notinline complex
))
1466 (declare (optimize (speed 1) (space 0) (safety 1)
1467 (debug 3) (compilation-speed 3)))
1468 (flet ((%f
() (multiple-value-prog1 0 (return-from %f
0))))
1469 (complex (%f
) 0)))))))
1471 ;;; MISC.110A: CAST optimizer forgot to flush LVAR derived type
1472 (assert (zerop (funcall
1476 (declare (type (integer -
1294746569 1640996137) a
))
1477 (declare (type (integer -
807801310 3) c
))
1478 (declare (optimize (speed 3) (space 3) (safety 0) (debug 0) (compilation-speed 3)))
1485 (progn (if (ldb-test (byte 0 0) (rational (throw 'ct7
0))) 0 0) 0))))
1487 391833530 -
32785211)))
1489 ;;; efficiency notes for ordinary code
1490 (macrolet ((frob (arglist &body body
)
1493 (compile nil
'(lambda ,arglist
,@body
))
1494 (sb-ext:compiler-note
(e)
1495 (error "bad compiler note for ~S:~% ~A" ',body e
)))
1498 (compile nil
'(lambda ,arglist
(declare (optimize speed
))
1500 (sb-ext:compiler-note
(e) (throw :got-note nil
)))
1501 (error "missing compiler note for ~S" ',body
)))))
1502 (frob (x) (funcall x
))
1503 (frob (x y
) (find x y
))
1504 (frob (x y
) (find-if x y
))
1505 (frob (x y
) (find-if-not x y
))
1506 (frob (x y
) (position x y
))
1507 (frob (x y
) (position-if x y
))
1508 (frob (x y
) (position-if-not x y
))
1509 (frob (x) (aref x
0)))
1511 (macrolet ((frob (style-warn-p form
)
1513 `(catch :got-style-warning
1516 (style-warning (e) (throw :got-style-warning nil
)))
1517 (error "missing style-warning for ~S" ',form
))
1521 (error "bad style-warning for ~S: ~A" ',form e
))))))
1522 (frob t
(lambda (x &optional y
&key z
) (list x y z
)))
1523 (frob nil
(lambda (x &optional y z
) (list x y z
)))
1524 (frob nil
(lambda (x &key y z
) (list x y z
)))
1525 (frob t
(defgeneric #:foo
(x &optional y
&key z
)))
1526 (frob nil
(defgeneric #:foo
(x &optional y z
)))
1527 (frob nil
(defgeneric #:foo
(x &key y z
)))
1528 (frob t
(defun #:foo
(x) (flet ((foo (x &optional y
&key z
) (list x y z
))) (foo x x
:z x
)))))
1530 ;;; this was a bug in the LOGXOR type deriver. The top form gave a
1531 ;;; note, because the system failed to derive the fact that the return
1532 ;;; from LOGXOR was small and negative, though the bottom one worked.
1533 (handler-bind ((sb-ext:compiler-note
#'error
))
1534 (compile nil
'(lambda ()
1535 (declare (optimize speed
(safety 0)))
1537 (declare (type (integer 3 6) x
)
1538 (type (integer -
6 -
3) y
))
1539 (+ (logxor x y
) most-positive-fixnum
)))))
1540 (handler-bind ((sb-ext:compiler-note
#'error
))
1541 (compile nil
'(lambda ()
1542 (declare (optimize speed
(safety 0)))
1544 (declare (type (integer 3 6) y
)
1545 (type (integer -
6 -
3) x
))
1546 (+ (logxor x y
) most-positive-fixnum
)))))
1548 ;;; check that modular ash gives the right answer, to protect against
1549 ;;; possible misunderstandings about the hardware shift instruction.
1550 (assert (zerop (funcall
1551 (compile nil
'(lambda (x y
)
1552 (declare (optimize speed
)
1553 (type (unsigned-byte 32) x y
))
1554 (logand #xffffffff
(ash x y
))))
1557 ;;; code instrumenting problems
1560 (declare (optimize (debug 3)))
1561 (list (the integer
(if nil
14 t
)))))
1565 (DECLARE (NOTINLINE LOGORC1 BYTE MASK-FIELD
))
1571 (COMPILATION-SPEED 0)))
1572 (MASK-FIELD (BYTE 7 26)
1574 (TAGBODY (THE INTEGER
(CATCH 'CT4
(LOGORC1 C -
15950))) 1)
1578 '(lambda (buffer i end
)
1579 (declare (optimize (debug 3)))
1580 (loop (when (not (eql 0 end
)) (return)))
1581 (let ((s (make-string end
)))
1582 (setf (schar s i
) (schar buffer i
))
1585 ;;; check that constant string prefix and suffix don't cause the
1586 ;;; compiler to emit code deletion notes.
1587 (handler-bind ((sb-ext:code-deletion-note
#'error
))
1588 (compile nil
'(lambda (s x
)
1589 (pprint-logical-block (s x
:prefix
"(")
1591 (compile nil
'(lambda (s x
)
1592 (pprint-logical-block (s x
:per-line-prefix
";")
1594 (compile nil
'(lambda (s x
)
1595 (pprint-logical-block (s x
:suffix
">")
1598 ;;; MISC.427: loop analysis requires complete DFO structure
1599 (assert (eql 17 (funcall
1603 (declare (notinline list reduce logior
))
1604 (declare (optimize (safety 2) (compilation-speed 1)
1605 (speed 3) (space 2) (debug 2)))
1607 (let* ((v5 (reduce #'+ (list 0 a
))))
1608 (declare (dynamic-extent v5
))
1613 (assert (zerop (funcall
1617 (declare (type (integer -
8431780939320 1571817471932) a
))
1618 (declare (type (integer -
4085 0) b
))
1619 (declare (ignorable a b
))
1622 (compilation-speed 0)
1623 #+sbcl
(sb-c:insert-step-conditions
0)
1630 (elt '(1954479092053)
1634 (lognand iv1
(ash iv1
(min 53 iv1
)))
1637 -
7639589303599 -
1368)))
1642 (declare (type (integer) a
))
1643 (declare (type (integer) b
))
1644 (declare (ignorable a b
))
1645 (declare (optimize (space 2) (compilation-speed 0)
1646 (debug 0) (safety 0) (speed 3)))
1648 (when (< iv1
2) (print 'x
)) ;; request for second constraint propagation pass
1649 (print (if (< iv1 iv1
)
1650 (logand (ash iv1 iv1
) 1)
1653 ;;; MISC.435: lambda var substitution in a deleted code.
1654 (assert (zerop (funcall
1658 (declare (notinline aref logandc2 gcd make-array
))
1660 (optimize (space 0) (safety 0) (compilation-speed 3)
1661 (speed 3) (debug 1)))
1664 (let* ((v2 (make-array nil
:initial-element
(catch 'ct1
(go tag2
)))))
1665 (declare (dynamic-extent v2
))
1666 (gcd (go tag2
) (logandc2 (catch 'ct2 c
) (aref v2
))))
1669 3021871717588 -
866608 -
2 -
17194)))
1671 ;;; MISC.436, 438: lost reoptimization
1672 (assert (zerop (funcall
1676 (declare (type (integer -
2917822 2783884) a
))
1677 (declare (type (integer 0 160159) b
))
1678 (declare (ignorable a b
))
1680 (optimize (compilation-speed 1)
1684 ; #+sbcl (sb-c:insert-step-conditions 0)
1698 '(-10197561 486 430631291
1704 (assert (zerop (funcall
1708 (declare (type (integer 0 1696) a
))
1709 ; (declare (ignorable a))
1710 (declare (optimize (space 2) (debug 0) (safety 1)
1711 (compilation-speed 0) (speed 1)))
1712 (if (logbitp 0 (ash (1- a
) (min 11 a
))) 0 0)))
1719 (declare (type (simple-array function
(2)) s
) (type ei ei
))
1720 (funcall (aref s ei
) x y
))))
1722 ;;; MISC.320: ir1-transform can create an intercomponent reference to
1724 (assert (eql 102 (funcall
1728 (declare (optimize (speed 3) (space 0) (safety 2)
1729 (debug 2) (compilation-speed 0)))
1732 (flet ((%f12
() (rem 0 -
43)))
1733 (multiple-value-call #'%f12
(values))))))))))
1735 ;;; MISC.437: lost reoptimization after FLUSH-DEST
1736 (assert (zerop (funcall
1739 '(lambda (a b c d e
)
1740 (declare (notinline values complex eql
))
1742 (optimize (compilation-speed 3)
1749 &optional
(f10-4 (ignore-errors 0)) (f10-5 0)
1750 &key
&allow-other-keys
)
1751 (if (or (eql 0 0) t
) 0 (if f10-1
0 0))))
1752 (complex (multiple-value-call #'%f10
(values a c b
0 0)) 0))))
1753 80043 74953652306 33658947 -
63099937105 -
27842393)))
1755 ;;; bug #351 -- program-error for malformed LET and LET*, including those
1756 ;;; resulting from SETF of LET.
1757 (dolist (fun (list (compile nil
'(lambda () (let :bogus-let
:oops
)))
1758 (compile nil
'(lambda () (let* :bogus-let
* :oops
)))
1759 (compile nil
'(lambda (x) (push x
(let ((y 0)) y
))))))
1760 (assert (functionp fun
))
1761 (multiple-value-bind (res err
) (ignore-errors (funcall fun
))
1763 (assert (typep err
'program-error
))))
1765 (let ((fun (compile nil
'(lambda (x) (random (if x
10 20))))))
1766 (dotimes (i 100 (error "bad RANDOM distribution"))
1767 (when (> (funcall fun nil
) 9)
1770 (when (> (funcall fun t
) 9)
1771 (error "bad RANDOM event"))))
1773 ;;; 0.8.17.28-sma.1 lost derived type information.
1774 (with-test (:name
"0.8.17.28-sma.1" :fails-on
:sparc
)
1775 (handler-bind ((sb-ext:compiler-note
(lambda (c) (error "~A" c
))))
1778 (declare (optimize (speed 3) (safety 0)))
1779 (declare (type (integer 0 80) x
)
1780 (type (integer 0 11) y
)
1781 (type (simple-array (unsigned-byte 32) (*)) v
))
1782 (setf (aref v
0) (* (* x
#.
(floor (ash 1 32) (* 11 80))) y
))
1785 ;;; Bug reported by Robert J. Macomber: instrumenting of more-entry
1786 ;;; prevented open coding of %LISTIFY-REST-ARGS.
1787 (let ((f (compile nil
'(lambda ()
1788 (declare (optimize (debug 3)))
1789 (with-simple-restart (blah "blah") (error "blah"))))))
1790 (handler-bind ((error (lambda (c) (invoke-restart 'blah
))))
1791 (assert (equal (multiple-value-list (funcall f
)) '(nil t
)))))
1793 ;;; Bug reported by Timmy Douglas: overflow in bit vector setter with
1794 ;;; constant index and value.
1795 (loop for n-bits
= 1 then
(* n-bits
2)
1796 for type
= `(unsigned-byte ,n-bits
)
1797 and v-max
= (1- (ash 1 n-bits
))
1798 while
(<= n-bits sb-vm
:n-word-bits
)
1800 (let* ((n (* 2 (1+ (- sb-vm
::n-word-bits n-bits
))))
1801 (array1 (make-array n
:element-type type
))
1802 (array2 (make-array n
:element-type type
)))
1804 (dolist (v (list 0 v-max
))
1805 (let ((f (compile nil
`(lambda (a)
1806 (declare (type (simple-array ,type
(,n
)) a
))
1807 (setf (aref a
,i
) ,v
)))))
1808 (fill array1
(- v-max v
))
1809 (fill array2
(- v-max v
))
1811 (setf (aref array2 i
) v
)
1812 (assert (every #'= array1 array2
)))))))
1814 (let ((fn (compile nil
'(lambda (x)
1815 (declare (type bit x
))
1816 (declare (optimize speed
))
1817 (let ((b (make-array 64 :element-type
'bit
1818 :initial-element
0)))
1820 (assert (= (funcall fn
0) 64))
1821 (assert (= (funcall fn
1) 0)))
1823 (let ((fn (compile nil
'(lambda (x y
)
1824 (declare (type simple-bit-vector x y
))
1825 (declare (optimize speed
))
1829 (make-array 64 :element-type
'bit
:initial-element
0)
1830 (make-array 64 :element-type
'bit
:initial-element
0)))
1834 (make-array 64 :element-type
'bit
:initial-element
0)
1835 (let ((b (make-array 64 :element-type
'bit
:initial-element
0)))
1836 (setf (sbit b
63) 1)
1839 ;;; MISC.535: compiler failure
1840 (let ((c0 #c
(4196.088977268509d0 -
15943.3603515625d0
)))
1841 (assert (not (funcall
1845 (declare (optimize speed
(safety 1))
1848 (eql (the (complex double-float
) p1
) p2
)))
1849 c0
#c
(12 612/979)))))
1851 ;;; reported by Lutz Euler: we shouldn't signal a compiler note for
1852 ;;; simple-bit-vector functions.
1853 (handler-bind ((sb-ext:compiler-note
#'error
))
1854 (compile nil
'(lambda (x)
1855 (declare (type simple-bit-vector x
))
1857 (handler-bind ((sb-ext:compiler-note
#'error
))
1858 (compile nil
'(lambda (x y
)
1859 (declare (type simple-bit-vector x y
))
1862 ;;; MISC.550: CAST merging in IR1 finalization caused unexpected
1863 ;;; code transformations.
1864 (assert (eql (funcall
1868 (declare (optimize (speed 3) (safety 2) (debug 3) (space 3))
1871 (or p1
(the (eql t
) p2
))))
1875 ;;; MISC.548: type check weakening converts required type into
1882 (declare (optimize (speed 2) (safety 1) (debug 3) (space 2)))
1883 (atom (the (member f assoc-if write-line t w
) p1
))))
1886 ;;; Free special bindings only apply to the body of the binding form, not
1887 ;;; the initialization forms.
1889 (funcall (compile 'nil
1892 (declare (special x
))
1894 ((lambda (&optional
(y x
))
1895 (declare (special x
)) y
)))))))))
1897 ;;; Bug from pfdietz's random tester: the compiler knew that IMAGPART of
1898 ;;; a rational was zero, but didn't do the substitution, leading to a
1899 ;;; crash in the ASH vop (since a shift of 57 wouldn't fit in the
1900 ;;; machine's ASH instruction's immediate field) that the compiler
1901 ;;; thought was legitimate.
1903 ;;; FIXME: this has been recorded as bug 383. The attempted fix (sbcl
1904 ;;; 0.9.2.6) led to lots of spurious optimization notes. So the bug stil
1905 ;;; exist and this test case serves as a reminder of the problem.
1906 ;;; --njf, 2005-07-05
1910 (DECLARE (TYPE (INTEGER -
2 14) B
))
1911 (DECLARE (IGNORABLE B
))
1912 (ASH (IMAGPART B
) 57)))
1914 ;;; bug reported by Eduardo Mu\~noz
1915 (multiple-value-bind (fun warnings failure
)
1916 (compile nil
'(lambda (struct first
)
1917 (declare (optimize speed
))
1918 (let* ((nodes (nodes struct
))
1919 (bars (bars struct
))
1920 (length (length nodes
))
1921 (new (make-array length
:fill-pointer
0)))
1922 (vector-push first new
)
1923 (loop with i fixnum
= 0
1924 for newl fixnum
= (length new
)
1925 while
(< newl length
) do
1926 (let ((oldl (length new
)))
1927 (loop for j fixnum from i below newl do
1928 (dolist (n (node-neighbours (aref new j
) bars
))
1929 (unless (find n new
)
1930 (vector-push n new
))))
1933 (declare (ignore fun warnings failure
))
1934 (assert (not failure
)))
1936 ;;; bug #389: "0.0 can't be converted to type NIL." (Brian Rowe
1938 (compile nil
'(lambda (x y a b c
)
1939 (- y
(* (signum x
) (sqrt (abs (- (* b x
) c
)))))))
1941 ;;; Type inference from CHECK-TYPE
1942 (let ((count0 0) (count1 0))
1943 (handler-bind ((sb-ext:compiler-note
(lambda (c) (incf count0
))))
1944 (compile nil
'(lambda (x)
1945 (declare (optimize (speed 3)))
1947 ;; forced-to-do GENERIC-+, etc, possible word -> bignum conversion note
1948 (assert (> count0
1))
1949 (handler-bind ((sb-ext:compiler-note
(lambda (c) (incf count1
))))
1950 (compile nil
'(lambda (x)
1951 (declare (optimize (speed 3)))
1952 (check-type x fixnum
)
1954 ;; Only the posssible word -> bignum conversion note
1955 (assert (= count1
1)))
1957 ;;; Up to 0.9.8.22 x86-64 had broken return value handling in the
1958 ;;; %SET-SAP-REF-DOUBLE/SINGLE VOPs.
1959 (with-test (:name
:sap-ref-float
)
1960 (compile nil
'(lambda (sap)
1961 (let ((x (setf (sb-vm::sap-ref-double sap
0) 1d0
)))
1963 (compile nil
'(lambda (sap)
1964 (let ((x (setf (sb-vm::sap-ref-single sap
0) 1d0
)))
1968 (with-test (:name
:string-union-types
)
1969 (compile nil
'(lambda (x)
1970 (declare (type (or (simple-array character
(6))
1971 (simple-array character
(5))) x
))
1974 ;;; MISC.623: missing functions for constant-folding
1980 (declare (optimize (space 2) (speed 0) (debug 2)
1981 (compilation-speed 3) (safety 0)))
1982 (loop for lv3 below
1
1984 (loop for lv2 below
2
1986 (bit #*1001101001001
1987 (min 12 (max 0 lv3
))))))))))))
1989 ;;; MISC.624: erroneous AVER in x86's %LOGBITP VOPs
1995 (declare (type (integer 21 28) a
))
1996 (declare (optimize (compilation-speed 1) (safety 2)
1997 (speed 0) (debug 0) (space 1)))
1998 (let* ((v7 (flet ((%f3
(f3-1 f3-2
)
1999 (loop for lv2 below
1
2003 (min 7 (max 0 (eval '0))))))))
2008 ;;; MISC.626: bandaged AVER was still wrong
2009 (assert (eql -
829253
2014 (declare (type (integer -
902970 2) a
))
2015 (declare (optimize (space 2) (debug 0) (compilation-speed 1)
2016 (speed 0) (safety 3)))
2017 (prog2 (if (logbitp 30 a
) 0 (block b3
0)) a
)))
2020 ;; MISC.628: constant-folding %LOGBITP was buggy
2026 (declare (optimize (safety 3) (space 3) (compilation-speed 3)
2027 (speed 0) (debug 1)))
2028 (not (not (logbitp 0 (floor 2147483651 (min -
23 0))))))))))
2030 ;; mistyping found by random-tester
2036 (declare (optimize (speed 1) (debug 0)
2037 (space 2) (safety 0) (compilation-speed 0)))
2039 (* (/ (multiple-value-prog1 -
29457482 -
5602513511) 1))))))))
2041 ;; aggressive constant folding (bug #400)
2043 (eq t
(funcall (compile nil
'(lambda () (or t
(the integer
(/ 1 0))))))))
2045 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-non-var-1
))
2048 (compile nil
'(lambda (x y
)
2049 (when (eql x
(length y
))
2051 (declare (optimize (speed 3)))
2053 (compiler-note () (error "The code is not optimized.")))))
2055 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-non-var-2
))
2058 (compile nil
'(lambda (x y
)
2059 (when (eql (length y
) x
)
2061 (declare (optimize (speed 3)))
2063 (compiler-note () (error "The code is not optimized.")))))
2065 (with-test (:name
(:compiler
:constraint-propagation
:float-bounds-1
))
2067 (compile nil
'(lambda (x)
2068 (declare (type (single-float * (3.0
)) x
))
2072 (compiler-note () (error "Deleted reachable code."))))
2074 (with-test (:name
(:compiler
:constraint-propagation
:float-bounds-2
))
2077 (compile nil
'(lambda (x)
2078 (declare (type single-float x
))
2081 (error "This is unreachable.")))))
2082 (compiler-note () (throw :note nil
)))
2083 (error "Unreachable code undetected.")))
2085 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-var-1
))
2088 (compile nil
'(lambda (x y
)
2089 (when (typep y
'fixnum
)
2091 (unless (typep x
'fixnum
)
2092 (error "This is unreachable"))
2094 (compiler-note () (throw :note nil
)))
2095 (error "Unreachable code undetected.")))
2097 (with-test (:name
(:compiler
:constraint-propagation
:var-eql-to-var-2
))
2100 (compile nil
'(lambda (x y
)
2101 (when (typep y
'fixnum
)
2103 (unless (typep x
'fixnum
)
2104 (error "This is unreachable"))
2106 (compiler-note () (throw :note nil
)))
2107 (error "Unreachable code undetected.")))
2109 ;; Reported by John Wiseman, sbcl-devel
2110 ;; Subject: [Sbcl-devel] float type derivation bug?
2111 ;; Date: Tue, 4 Apr 2006 15:28:15 -0700
2112 (with-test (:name
(:type-derivation
:float-bounds
))
2113 (compile nil
'(lambda (bits)
2114 (let* ((s (if (= (ash bits -
31) 0) 1 -
1))
2115 (e (logand (ash bits -
23) #xff
))
2117 (ash (logand bits
#x7fffff
) 1)
2118 (logior (logand bits
#x7fffff
) #x800000
))))
2119 (float (* s m
(expt 2 (- e
150))))))))
2121 ;; Reported by James Knight
2122 ;; Subject: [Sbcl-devel] AVER: "(EQ (SB-NAME (SC-SB (TN-SC TN))) 'REGISTERS)"
2123 ;; Date: Fri, 24 Mar 2006 19:30:00 -0500
2124 (with-test (:name
:logbitp-vop
)
2126 '(lambda (days shift
)
2127 (declare (type fixnum shift days
))
2129 (canonicalized-shift (+ shift
1))
2130 (first-wrapping-day (- 1 canonicalized-shift
)))
2131 (declare (type fixnum result
))
2132 (dotimes (source-day 7)
2133 (declare (type (integer 0 6) source-day
))
2134 (when (logbitp source-day days
)
2138 (if (< source-day first-wrapping-day
)
2139 (+ source-day canonicalized-shift
)
2141 canonicalized-shift
) 7)))))))
2144 ;;; MISC.637: incorrect delaying of conversion of optional entries
2145 ;;; with hairy constant defaults
2146 (let ((f '(lambda ()
2147 (labels ((%f11
(f11-2 &key key1
)
2148 (labels ((%f8
(f8-2 &optional
(f8-5 (if nil
(return-from %f11
0) 0)))
2153 (assert (eq (funcall (compile nil f
)) :good
)))
2155 ;;; MISC.555: new reference to an already-optimized local function
2156 (let* ((l '(lambda (p1)
2157 (declare (optimize (speed 1) (safety 2) (debug 2) (space 0)) (type keyword p1
))
2159 (f (compile nil l
)))
2160 (assert (funcall f
:good
))
2161 (assert (nth-value 1 (ignore-errors (funcall f
42)))))
2163 ;;; Check that the compiler doesn't munge *RANDOM-STATE*.
2164 (let* ((state (make-random-state))
2165 (*random-state
* (make-random-state state
))
2166 (a (random most-positive-fixnum
)))
2167 (setf *random-state
* state
)
2168 (compile nil
`(lambda (x a
)
2169 (declare (single-float x
)
2170 (type (simple-array double-float
) a
))
2171 (+ (loop for i across a
2174 (assert (= a
(random most-positive-fixnum
))))
2176 ;;; MISC.641: LET-conversion after physical environment analysis lost NLX-INFOs
2177 (let ((form '(lambda ()
2178 (declare (optimize (speed 1) (space 0) (debug 2)
2179 (compilation-speed 0) (safety 1)))
2180 (flet ((%f3
(f3-1 &key
(key1 (count (floor 0 (min -
74 0)) #())))
2182 (apply #'%f3
0 nil
)))))
2183 (assert (zerop (funcall (compile nil form
)))))
2185 ;;; size mismatch: #<SB-VM::EA :DWORD base=#<SB-C:TN t1[RDX]> disp=1> is a :DWORD and #<SB-C:TN t2[RAX]> is a :QWORD. on x86-64
2186 (compile nil
'(lambda ()
2187 (let ((x (make-array '(1) :element-type
'(signed-byte 32))))
2188 (setf (aref x
0) 1))))
2190 ;;; step instrumentation confusing the compiler, reported by Faré
2191 (handler-bind ((warning #'error
))
2192 (compile nil
'(lambda ()
2193 (declare (optimize (debug 2))) ; not debug 3!
2194 (let ((val "foobar"))
2195 (map-into (make-array (list (length val
))
2196 :element-type
'(unsigned-byte 8))
2197 #'char-code val
)))))
2199 ;;; overconfident primitive type computation leading to bogus type
2201 (let* ((form1 '(lambda (x)
2202 (declare (type (and condition function
) x
))
2204 (fun1 (compile nil form1
))
2206 (declare (type (and standard-object function
) x
))
2208 (fun2 (compile nil form2
)))
2209 (assert (raises-error?
(funcall fun1
(make-condition 'error
))))
2210 (assert (raises-error?
(funcall fun1 fun1
)))
2211 (assert (raises-error?
(funcall fun2 fun2
)))
2212 (assert (eq (funcall fun2
#'print-object
) #'print-object
)))
2214 ;;; LET* + VALUES declaration: while the declaration is a non-standard
2215 ;;; and possibly a non-conforming extension, as long as we do support
2216 ;;; it, we might as well get it right.
2218 ;;; Bug reported by Kaersten Poeck on sbcl-devel 20061023.
2219 (compile nil
'(lambda () (let* () (declare (values list
)))))
2222 ;;; test for some problems with too large immediates in x86-64 modular
2224 (compile nil
'(lambda (x) (declare (fixnum x
))
2225 (logand most-positive-fixnum
(logxor x most-positive-fixnum
))))
2227 (compile nil
'(lambda (x) (declare (fixnum x
))
2228 (logand most-positive-fixnum
(+ x most-positive-fixnum
))))
2230 (compile nil
'(lambda (x) (declare (fixnum x
))
2231 (logand most-positive-fixnum
(* x most-positive-fixnum
))))
2234 (assert (let (warned-p)
2235 (handler-bind ((warning (lambda (w) (setf warned-p t
))))
2238 (list (let ((y (the real x
)))
2239 (unless (floatp y
) (error ""))
2241 (integer-length x
)))))
2244 ;; Dead / in safe code
2245 (with-test (:name
:safe-dead-
/)
2248 (funcall (compile nil
2250 (declare (optimize (safety 3)))
2255 (division-by-zero ()
2258 ;;; Dead unbound variable (bug 412)
2259 (with-test (:name
:dead-unbound
)
2262 (funcall (compile nil
2266 (unbound-variable ()
2269 ;;; No compiler notes from compiling SUBSEQ SIMPLE-VECTOR.
2270 (handler-bind ((sb-ext:compiler-note
'error
))
2273 (funcall (compile nil
`(lambda (s p e
)
2274 (declare (optimize speed
)
2281 ;;; No compiler notes from compiling COPY-SEQ SIMPLE-VECTOR.
2282 (handler-bind ((sb-ext:compiler-note
'error
))
2285 (funcall (compile nil
`(lambda (s)
2286 (declare (optimize speed
)
2289 (vector 1 2 3 4)))))
2291 ;;; bug in adding DATA-VECTOR-REF-WITH-OFFSET to x86-64
2292 (assert (not (mismatch #(1.0f0
2.0f0
) (make-array 2 :element-type
'single-float
:initial-contents
(list 1.0f0
2.0f0
)))))
2294 ;;; bug in interval-arithmetic used by the compiler: needless attempt to coerce too
2295 ;;; large bignums to floats
2296 (dolist (op '(* / + -
))
2300 (declare (type (integer 0 #.
(* 2 (truncate most-positive-double-float
))) x
))
2303 do
(let ((arg (random (truncate most-positive-double-float
))))
2304 (assert (eql (funcall fun arg
)
2305 (funcall op
0.0d0 arg
)))))))
2307 (with-test (:name
:high-debug-known-function-inlining
)
2308 (let ((fun (compile nil
2310 (declare (optimize (debug 3)) (inline append
))
2311 (let ((fun (lambda (body)
2316 '((foo (bar)))))))))
2319 (with-test (:name
:high-debug-known-function-transform-with-optional-arguments
)
2320 (compile nil
'(lambda (x y
)
2321 (declare (optimize sb-c
::preserve-single-use-debug-variables
))
2323 (some-unknown-function
2325 (return (member x y
))))
2330 ;;; Compiling W-P-O when the pinned objects are known to be fixnums
2332 (compile nil
'(lambda (x y
)
2333 (declare (fixnum y
) (character x
))
2334 (sb-sys:with-pinned-objects
(x y
)
2335 (some-random-function))))
2337 ;;; *CHECK-CONSISTENCY* and TRULY-THE
2339 (with-test (:name
:bug-423
)
2340 (let ((sb-c::*check-consistency
* t
))
2341 (handler-bind ((warning #'error
))
2342 (flet ((make-lambda (type)
2346 (let ((q (truly-the list z
)))
2349 (let ((q (truly-the vector z
)))
2353 (compile nil
(make-lambda 'list
))
2354 (compile nil
(make-lambda 'vector
))))))
2356 ;;; this caused a momentary regression when an ill-adviced fix to
2357 ;;; bug 427 made ANY-REG suitable for primitive-type T:
2359 ;;; no :MOVE-ARG VOP defined to move #<SB-C:TN t1> (SC SB-VM::SINGLE-REG) to #<SB-C:TN t2> (SC SB-VM::ANY-REG)
2360 ;;; [Condition of type SIMPLE-ERROR]
2367 (setf (sb-alien:deref
(sb-alien:cast
(sb-alien:sap-alien
(unknown1) (* unsigned-char
))
2368 (* double-float
))) frob
))
2370 (%zig
(the (values (single-float (0.0
) 1.0) &optional
) (unknown2)))
2374 ;;; non-required arguments in HANDLER-BIND
2375 (assert (eq :oops
(car (funcall (compile nil
2378 (handler-bind ((error (lambda (&rest args
) (return (cons :oops args
)))))
2382 ;;; NIL is a legal function name
2383 (assert (eq 'a
(flet ((nil () 'a
)) (nil))))
2386 (assert (null (let* ((x 296.3066f0
)
2388 (form `(lambda (r p2
)
2389 (declare (optimize speed
(safety 1))
2390 (type (simple-array single-float nil
) r
)
2391 (type (integer -
9369756340 22717335) p2
))
2392 (setf (aref r
) (* ,x
(the (eql 22717067) p2
)))
2394 (r (make-array nil
:element-type
'single-float
))
2396 (funcall (compile nil form
) r y
)
2397 (let ((actual (aref r
)))
2398 (unless (eql expected actual
)
2399 (list expected actual
))))))
2401 (assert (null (let* ((x -
2367.3296f0
)
2403 (form `(lambda (r p2
)
2404 (declare (optimize speed
(safety 1))
2405 (type (simple-array single-float nil
) r
)
2406 (type (eql 46790178) p2
))
2407 (setf (aref r
) (+ ,x
(the (integer 45893897) p2
)))
2409 (r (make-array nil
:element-type
'single-float
))
2411 (funcall (compile nil form
) r y
)
2412 (let ((actual (aref r
)))
2413 (unless (eql expected actual
)
2414 (list expected actual
))))))
2419 (compile nil
'(lambda (p1 p2
)
2421 (optimize (speed 1) (safety 0)
2422 (debug 0) (space 0))
2423 (type (member 8174.8604) p1
)
2424 (type (member -
95195347) p2
))
2426 8174.8604 -
95195347)))
2434 (declare (optimize (speed 3) (safety 0) (debug 3) (space 1))
2435 (type (member -
94430.086f0
) p1
))
2436 (floor (the single-float p1
) 19311235)))
2445 (declare (optimize (speed 1) (safety 2)
2446 (debug 2) (space 3))
2447 (type (eql -
39466.56f0
) p1
))
2448 (ffloor p1
305598613)))
2457 (declare (optimize (speed 1) (safety 1) (debug 1) (space 2))
2458 (type (eql -
83232.09f0
) p1
))
2459 (ceiling p1 -
83381228)))
2468 (declare (optimize (speed 1) (safety 1)
2469 (debug 1) (space 0))
2470 (type (member -
66414.414f0
) p1
))
2471 (ceiling p1 -
63019173f0
)))
2480 (declare (optimize (speed 0) (safety 1)
2481 (debug 0) (space 1))
2482 (type (eql 20851.398f0
) p1
))
2483 (fceiling p1
80839863)))
2489 (compile nil
'(lambda (x)
2490 (declare (type (eql -
5067.2056) x
))
2497 (compile nil
'(lambda (x) (declare (type (eql -
1.0) x
))
2503 (assert (plusp (funcall
2507 (declare (optimize (speed 0) (safety 1) (debug 1) (space 1))
2508 (type (eql -
39887.645) p1
))
2509 (mod p1
382352925)))
2513 (assert (let ((result (funcall
2517 (declare (optimize (speed 0) (safety 3) (debug 1) (space 0))
2518 (type (eql 33558541) p2
))
2521 (typep result
'single-float
)))
2525 (let* ((form '(lambda (p2)
2526 (declare (optimize (speed 0) (safety 1)
2527 (debug 2) (space 2))
2528 (type (member -
19261719) p2
))
2529 (ceiling -
46022.094 p2
))))
2530 (values (funcall (compile nil form
) -
19261719)))))
2533 (assert (let* ((x 26899.875)
2535 (declare (optimize (speed 3) (safety 1) (debug 3) (space 1))
2536 (type (member ,x
#:g5437 char-code
#:g5438
) p2
))
2538 (floatp (funcall (compile nil form
) x
))))
2546 (declare (optimize (speed 3) (safety 2) (debug 3) (space 0))
2548 (+ 81535869 (the (member 17549.955 #:g35917
) p2
))))
2550 (+ 81535869 17549.955)))
2554 (let ((form '(lambda (p2)
2555 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2556 (type (member integer eql
) p2
))
2558 (funcall (compile nil form
) 'integer
))))
2562 (let ((form '(lambda (p2)
2563 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2564 (type (member integer mod
) p2
))
2566 (funcall (compile nil form
) 'integer
))))
2570 (let ((form '(lambda (p2)
2571 (declare (optimize (speed 0) (safety 2) (debug 0) (space 2))
2572 (type (member integer values
) p2
))
2574 (funcall (compile nil form
) 'integer
))))
2576 (with-test (:name
:string-aref-type
)
2577 (assert (eq 'character
2578 (funcall (compile nil
2580 (ctu:compiler-derived-type
(aref (the string s
) 0))))
2583 (with-test (:name
:base-string-aref-type
)
2584 (assert (eq #+sb-unicode
'base-char
2585 #-sb-unicode
'character
2586 (funcall (compile nil
2588 (ctu:compiler-derived-type
(aref (the base-string s
) 0))))
2589 (coerce "foo" 'base-string
)))))
2591 (with-test (:name
:dolist-constant-type-derivation
)
2592 (assert (equal '(integer 1 3)
2593 (funcall (compile nil
2595 (dolist (y '(1 2 3))
2597 (return (ctu:compiler-derived-type y
))))))
2600 (with-test (:name
:dolist-simple-list-type-derivation
)
2601 (assert (equal '(integer 1 3)
2602 (funcall (compile nil
2604 (dolist (y (list 1 2 3))
2606 (return (ctu:compiler-derived-type y
))))))
2609 (with-test (:name
:dolist-dotted-constant-list-type-derivation
)
2611 (fun (handler-bind ((style-warning (lambda (c) (push c warned
))))
2614 (dolist (y '(1 2 3 .
4) :foo
)
2616 (return (ctu:compiler-derived-type y
)))))))))
2617 (assert (equal '(integer 1 3) (funcall fun t
)))
2618 (assert (= 1 (length warned
)))
2619 (multiple-value-bind (res err
) (ignore-errors (funcall fun nil
))
2621 (assert (typep err
'type-error
)))))
2623 (with-test (:name
:constant-list-destructuring
)
2624 (handler-bind ((sb-ext:compiler-note
#'error
))
2630 (destructuring-bind (a (b c
) d
) '(1 (2 3) 4)
2637 (destructuring-bind (a (b c
) d
) '(1 "foo" 4)
2641 ;;; Functions with non-required arguments used to end up with
2642 ;;; (&OPTIONAL-DISPATCH ...) as their names.
2643 (with-test (:name
:hairy-function-name
)
2644 (assert (eq 'read-line
(nth-value 2 (function-lambda-expression #'read-line
))))
2645 (assert (equal "#<FUNCTION READ-LINE>" (princ-to-string #'read-line
))))
2647 ;;; PROGV + RESTRICT-COMPILER-POLICY
2648 (with-test (:name
:progv-and-restrict-compiler-policy
)
2649 (let ((sb-c::*policy-restrictions
* sb-c
::*policy-restrictions
*))
2650 (restrict-compiler-policy 'debug
3)
2651 (let ((fun (compile nil
'(lambda (x)
2653 (declare (special i
))
2655 (progv '(i) (list (+ i
1))
2658 (assert (equal '(1 2 1) (funcall fun
1))))))
2660 ;;; It used to be possible to confuse the compiler into
2661 ;;; IR2-converting such a call to CONS
2662 (with-test (:name
:late-bound-primitive
)
2663 (compile nil
`(lambda ()
2664 (funcall 'cons
1))))
2666 (with-test (:name
:hairy-array-element-type-derivation
)
2667 (compile nil
'(lambda (x)
2668 (declare (type (and simple-string
(satisfies array-has-fill-pointer-p
)) x
))
2669 (array-element-type x
))))
2671 (with-test (:name
:rest-list-type-derivation
)
2672 (multiple-value-bind (type derivedp
)
2673 (funcall (compile nil
`(lambda (&rest args
)
2674 (ctu:compiler-derived-type args
)))
2676 (assert (eq 'list type
))
2679 (with-test (:name
:base-char-typep-elimination
)
2680 (assert (eq (funcall (lambda (ch)
2681 (declare (type base-char ch
) (optimize (speed 3) (safety 0)))
2682 (typep ch
'base-char
))
2686 (with-test (:name
:regression-1.0
.24.37)
2687 (compile nil
'(lambda (&key
(test (constantly t
)))
2688 (when (funcall test
)
2691 ;;; Attempt to test a decent cross section of conditions
2692 ;;; and values types to move conditionally.
2694 ((test-comparison (comparator type x y
)
2696 ,@(loop for
(result-type a b
)
2702 (nil #c
(1.0
1.0) #c
(2.0
2.0))
2706 ((unsigned-byte #.sb-vm
:n-word-bits
)
2707 (1+ most-positive-fixnum
)
2708 (+ 2 most-positive-fixnum
))
2709 ((signed-byte #.sb-vm
:n-word-bits
)
2710 -
1 (* 2 most-negative-fixnum
))
2711 (single-float 0.0 1.0)
2712 (double-float 0d0
1d0
))
2713 for lambda
= (if result-type
2715 (declare (,type x y
)
2717 (if (,comparator x y
)
2720 (declare (,type x y
))
2721 (if (,comparator x y
)
2723 for args
= `(,x
,y
,@(and result-type
2727 (eql (funcall (compile nil
',lambda
)
2729 (eval '(,lambda
,@args
))))))))
2730 (sb-vm::with-float-traps-masked
2731 (:divide-by-zero
:overflow
:inexact
:invalid
)
2732 (let ((sb-ext:*evaluator-mode
* :interpret
))
2733 (declare (sb-ext:muffle-conditions style-warning
))
2734 (test-comparison eql t t nil
)
2735 (test-comparison eql t t t
)
2737 (test-comparison = t
1 0)
2738 (test-comparison = t
1 1)
2739 (test-comparison = t
(1+ most-positive-fixnum
) (+ 2 most-positive-fixnum
))
2740 (test-comparison = fixnum
1 0)
2741 (test-comparison = fixnum
0 0)
2742 (test-comparison = (unsigned-byte #.sb-vm
:n-word-bits
) 1 0)
2743 (test-comparison = (unsigned-byte #.sb-vm
:n-word-bits
) 0 0)
2744 (test-comparison = (signed-byte #.sb-vm
:n-word-bits
) 1 0)
2745 (test-comparison = (signed-byte #.sb-vm
:n-word-bits
) 1 1)
2747 (test-comparison = single-float
0.0 1.0)
2748 (test-comparison = single-float
1.0 1.0)
2749 (test-comparison = single-float
(/ 1.0 0.0) (/ 1.0 0.0))
2750 (test-comparison = single-float
(/ 1.0 0.0) 1.0)
2751 (test-comparison = single-float
(/ 0.0 0.0) (/ 0.0 0.0))
2752 (test-comparison = single-float
(/ 0.0 0.0) 0.0)
2754 (test-comparison = double-float
0d0
1d0
)
2755 (test-comparison = double-float
1d0
1d0
)
2756 (test-comparison = double-float
(/ 1d0
0d0
) (/ 1d0
0d0
))
2757 (test-comparison = double-float
(/ 1d0
0d0
) 1d0
)
2758 (test-comparison = double-float
(/ 0d0
0d0
) (/ 0d0
0d0
))
2759 (test-comparison = double-float
(/ 0d0
0d0
) 0d0
)
2761 (test-comparison < t
1 0)
2762 (test-comparison < t
0 1)
2763 (test-comparison < t
1 1)
2764 (test-comparison < t
(1+ most-positive-fixnum
) (+ 2 most-positive-fixnum
))
2765 (test-comparison < t
(+ 2 most-positive-fixnum
) (1+ most-positive-fixnum
))
2766 (test-comparison < fixnum
1 0)
2767 (test-comparison < fixnum
0 1)
2768 (test-comparison < fixnum
0 0)
2769 (test-comparison < (unsigned-byte #.sb-vm
:n-word-bits
) 1 0)
2770 (test-comparison < (unsigned-byte #.sb-vm
:n-word-bits
) 0 1)
2771 (test-comparison < (unsigned-byte #.sb-vm
:n-word-bits
) 0 0)
2772 (test-comparison < (signed-byte #.sb-vm
:n-word-bits
) 1 0)
2773 (test-comparison < (signed-byte #.sb-vm
:n-word-bits
) 0 1)
2774 (test-comparison < (signed-byte #.sb-vm
:n-word-bits
) 1 1)
2776 (test-comparison < single-float
0.0 1.0)
2777 (test-comparison < single-float
1.0 0.0)
2778 (test-comparison < single-float
1.0 1.0)
2779 (test-comparison < single-float
(/ 1.0 0.0) (/ 1.0 0.0))
2780 (test-comparison < single-float
(/ 1.0 0.0) 1.0)
2781 (test-comparison < single-float
1.0 (/ 1.0 0.0))
2782 (test-comparison < single-float
(/ 0.0 0.0) (/ 0.0 0.0))
2783 (test-comparison < single-float
(/ 0.0 0.0) 0.0)
2785 (test-comparison < double-float
0d0
1d0
)
2786 (test-comparison < double-float
1d0
0d0
)
2787 (test-comparison < double-float
1d0
1d0
)
2788 (test-comparison < double-float
(/ 1d0
0d0
) (/ 1d0
0d0
))
2789 (test-comparison < double-float
(/ 1d0
0d0
) 1d0
)
2790 (test-comparison < double-float
1d0
(/ 1d0
0d0
))
2791 (test-comparison < double-float
(/ 0d0
0d0
) (/ 0d0
0d0
))
2792 (test-comparison < double-float
(/ 0d0
0d0
) 0d0
)
2793 (test-comparison < double-float
0d0
(/ 0d0
0d0
))
2795 (test-comparison > t
1 0)
2796 (test-comparison > t
0 1)
2797 (test-comparison > t
1 1)
2798 (test-comparison > t
(1+ most-positive-fixnum
) (+ 2 most-positive-fixnum
))
2799 (test-comparison > t
(+ 2 most-positive-fixnum
) (1+ most-positive-fixnum
))
2800 (test-comparison > fixnum
1 0)
2801 (test-comparison > fixnum
0 1)
2802 (test-comparison > fixnum
0 0)
2803 (test-comparison > (unsigned-byte #.sb-vm
:n-word-bits
) 1 0)
2804 (test-comparison > (unsigned-byte #.sb-vm
:n-word-bits
) 0 1)
2805 (test-comparison > (unsigned-byte #.sb-vm
:n-word-bits
) 0 0)
2806 (test-comparison > (signed-byte #.sb-vm
:n-word-bits
) 1 0)
2807 (test-comparison > (signed-byte #.sb-vm
:n-word-bits
) 0 1)
2808 (test-comparison > (signed-byte #.sb-vm
:n-word-bits
) 1 1)
2810 (test-comparison > single-float
0.0 1.0)
2811 (test-comparison > single-float
1.0 0.0)
2812 (test-comparison > single-float
1.0 1.0)
2813 (test-comparison > single-float
(/ 1.0 0.0) (/ 1.0 0.0))
2814 (test-comparison > single-float
(/ 1.0 0.0) 1.0)
2815 (test-comparison > single-float
1.0 (/ 1.0 0.0))
2816 (test-comparison > single-float
(/ 0.0 0.0) (/ 0.0 0.0))
2817 (test-comparison > single-float
(/ 0.0 0.0) 0.0)
2819 (test-comparison > double-float
0d0
1d0
)
2820 (test-comparison > double-float
1d0
0d0
)
2821 (test-comparison > double-float
1d0
1d0
)
2822 (test-comparison > double-float
(/ 1d0
0d0
) (/ 1d0
0d0
))
2823 (test-comparison > double-float
(/ 1d0
0d0
) 1d0
)
2824 (test-comparison > double-float
1d0
(/ 1d0
0d0
))
2825 (test-comparison > double-float
(/ 0d0
0d0
) (/ 0d0
0d0
))
2826 (test-comparison > double-float
(/ 0d0
0d0
) 0d0
)
2827 (test-comparison > double-float
0d0
(/ 0d0
0d0
)))))
2829 (with-test (:name
:car-and-cdr-type-derivation-conservative
)
2830 (let ((f1 (compile nil
2832 (declare (optimize speed
))
2833 (let ((x (the (cons fixnum fixnum
) (cons 1 2))))
2834 (declare (type (cons t fixnum
) x
))
2836 (+ (car x
) (cdr x
))))))
2839 (declare (optimize speed
))
2840 (let ((x (the (cons fixnum fixnum
) (cons 1 2))))
2842 (+ (car x
) (cdr x
)))))))
2843 (flet ((test-error (e value
)
2844 (assert (typep e
'type-error
))
2845 (assert (eq 'number
(type-error-expected-type e
)))
2846 (assert (eq value
(type-error-datum e
)))))
2849 (multiple-value-bind (res err
) (ignore-errors (funcall f1 v1
))
2851 (test-error err v1
))
2852 (multiple-value-bind (res err
) (ignore-errors (funcall f2 v2
))
2854 (test-error err v2
))))))
2856 (with-test (:name
:array-dimension-derivation-conservative
)
2857 (let ((f (compile nil
2859 (declare (optimize speed
))
2860 (declare (type (array * (4 4)) x
))
2862 (setq x
(make-array '(4 4)))
2863 (adjust-array y
'(3 5))
2864 (array-dimension y
0))))))
2865 (assert (= 3 (funcall f
(make-array '(4 4) :adjustable t
))))))
2867 (with-test (:name
:with-timeout-code-deletion-note
)
2868 (handler-bind ((sb-ext:code-deletion-note
#'error
))
2869 (compile nil
`(lambda ()
2870 (sb-ext:with-timeout
0
2873 (with-test (:name
:full-warning-for-undefined-type-in-cl
)
2876 (compile nil
`(lambda (x) (the replace x
)))
2882 (with-test (:name
:single-warning-for-single-undefined-type
)
2884 (handler-bind ((warning (lambda (c)
2885 (declare (ignore c
))
2887 (compile nil
`(lambda (x) (the #:no-type x
)))
2889 (compile nil
`(lambda (x) (the 'fixnum x
)))
2892 (with-test (:name
:complex-subtype-dumping-in-xc
)
2894 (= sb-vm
:complex-single-float-widetag
2895 (sb-kernel:widetag-of
2896 (sb-vm:saetp-initial-element-default
(sb-c::find-saetp
'(complex single-float
))))))
2898 (= sb-vm
:complex-double-float-widetag
2899 (sb-kernel:widetag-of
2900 (sb-vm:saetp-initial-element-default
(sb-c::find-saetp
'(complex double-float
)))))))
2902 (with-test (:name
:complex-single-float-fill
)
2903 (assert (every (lambda (x) (= #c
(1.0
2.0) x
))
2907 (make-array (list n
)
2908 :element-type
'(complex single-float
)
2909 :initial-element x
)))
2913 (with-test (:name
:regression-1.0
.28.21)
2914 (let ((fun (compile nil
`(lambda (x) (typep x
'(simple-array * 1))))))
2915 (assert (funcall fun
(vector 1 2 3)))
2916 (assert (funcall fun
"abc"))
2917 (assert (not (funcall fun
(make-array '(2 2)))))))
2919 (with-test (:name
:no-silly-compiler-notes-from-character-function
)
2921 (handler-bind ((compiler-note (lambda (e) (error "~S: ~A" current e
))))
2922 (dolist (name '(char-code char-int character char-name standard-char-p
2923 graphic-char-p alpha-char-p upper-case-p lower-case-p
2924 both-case-p digit-char-p alphanumericp digit-char-p
))
2926 (compile nil
`(lambda (x)
2927 (declare (character x
) (optimize speed
))
2929 (dolist (name '(char= char
/= char
< char
> char
<= char
>= char-equal
2930 char-not-equal char-lessp char-greaterp char-not-greaterp
2933 (compile nil
`(lambda (x y
)
2934 (declare (character x y
) (optimize speed
))
2937 ;;; optimizing make-array
2938 (with-test (:name
(make-array :open-code-initial-contents
))
2939 (assert (not (ctu:find-named-callees
2942 (make-array '(3) :initial-contents
(list x y z
)))))))
2943 (assert (not (ctu:find-named-callees
2946 (make-array '3 :initial-contents
(vector x y z
)))))))
2947 (assert (not (ctu:find-named-callees
2950 (make-array '3 :initial-contents
`(,x
,y
,z
))))))))
2952 ;;; optimizing array-in-bounds-p
2953 (with-test (:name
:optimize-array-in-bounds-p
)
2955 (macrolet ((find-callees (&body body
)
2956 `(ctu:find-named-callees
2960 :name
'array-in-bounds-p
))
2961 (must-optimize (&body exprs
)
2963 ,@(loop for expr in exprs
2964 collect
`(assert (not (find-callees
2966 (must-not-optimize (&body exprs
)
2968 ,@(loop for expr in exprs
2969 collect
`(assert (find-callees
2973 (let ((a (make-array '(1))))
2974 (array-in-bounds-p a
0))
2975 ;; exceeds upper bound (constant)
2976 (let ((a (make-array '(1))))
2977 (array-in-bounds-p a
1))
2978 ;; exceeds upper bound (interval)
2979 (let ((a (make-array '(1))))
2980 (array-in-bounds-p a
(+ 1 (random 2))))
2981 ;; negative lower bound (constant)
2982 (let ((a (make-array '(1))))
2983 (array-in-bounds-p a -
1))
2984 ;; negative lower bound (interval)
2985 (let ((a (make-array 3))
2986 (i (- (random 1) 20)))
2987 (array-in-bounds-p a i
))
2988 ;; multiple known dimensions
2989 (let ((a (make-array '(1 1))))
2990 (array-in-bounds-p a
0 0))
2992 (let ((s (the (simple-string 10) (eval "0123456789"))))
2993 (array-in-bounds-p s
9)))
2995 ;; don't trust non-simple array length in safety=1
2996 (let ((a (the (array * (10)) (make-array 10 :adjustable t
))))
2997 (eval `(adjust-array ,a
0))
2998 (array-in-bounds-p a
9))
2999 ;; same for a union type
3000 (let ((s (the (string 10) (make-array 10
3001 :element-type
'character
3003 (eval `(adjust-array ,s
0))
3004 (array-in-bounds-p s
9))
3005 ;; single unknown dimension
3006 (let ((a (make-array (random 20))))
3007 (array-in-bounds-p a
10))
3008 ;; multiple unknown dimensions
3009 (let ((a (make-array (list (random 20) (random 5)))))
3010 (array-in-bounds-p a
5 2))
3011 ;; some other known dimensions
3012 (let ((a (make-array (list 1 (random 5)))))
3013 (array-in-bounds-p a
0 2))
3014 ;; subscript might be negative
3015 (let ((a (make-array 5)))
3016 (array-in-bounds-p a
(- (random 3) 2)))
3017 ;; subscript might be too large
3018 (let ((a (make-array 5)))
3019 (array-in-bounds-p a
(random 6)))
3020 ;; unknown upper bound
3021 (let ((a (make-array 5)))
3022 (array-in-bounds-p a
(get-universal-time)))
3023 ;; unknown lower bound
3024 (let ((a (make-array 5)))
3025 (array-in-bounds-p a
(- (get-universal-time))))
3026 ;; in theory we should be able to optimize
3027 ;; the following but the current implementation
3028 ;; doesn't cut it because the array type's
3029 ;; dimensions get reported as (* *).
3030 (let ((a (make-array (list (random 20) 1))))
3031 (array-in-bounds-p a
5 2))))))
3033 ;;; optimizing (EXPT -1 INTEGER)
3034 (test-util:with-test
(:name
(expt minus-one integer
))
3035 (dolist (x '(-1 -
1.0 -
1.0d0
))
3036 (let ((fun (compile nil
`(lambda (x) (expt ,x
(the fixnum x
))))))
3037 (assert (not (ctu:find-named-callees fun
)))
3040 (assert (eql x
(funcall fun i
)))
3041 (assert (eql (- x
) (funcall fun i
))))))))
3043 (with-test (:name
(load-time-value :type-derivation
))
3044 (flet ((test (type form value-cell-p
)
3045 (let ((derived (funcall (compile
3048 (ctu:compiler-derived-type
3049 (load-time-value ,form
)))))))
3050 (unless (equal type derived
)
3051 (error "wanted ~S, got ~S" type derived
)))))
3053 (test '(integer 11 11) '(+ * 1) nil
))
3055 (test '(integer 4 4) '(length *) t
))))
3057 (with-test (:name
:float-division-using-exact-reciprocal
)
3058 (flet ((test (lambda-form arg res
&key
(check-insts t
))
3059 (let* ((fun (compile nil lambda-form
))
3060 (disassembly (with-output-to-string (s)
3061 (disassemble fun
:stream s
))))
3062 ;; Let's make sure there is no division at runtime: for x86 and
3063 ;; x86-64 that implies an FDIV, DIVSS, or DIVSD instruction, so
3064 ;; look for DIV in the disassembly. It's a terrible KLUDGE, but
3068 (assert (not (search "DIV" disassembly
))))
3069 ;; No generic arithmetic!
3070 (assert (not (search "GENERIC" disassembly
)))
3071 (assert (eql res
(funcall fun arg
))))))
3072 (dolist (c '(128 64 32 16 8 4 2 1 1/2 1/4 1/8 1/16 1/32 1/64))
3073 (dolist (type '(single-float double-float
))
3074 (let* ((cf (coerce c type
))
3075 (arg (- (random (* 2 cf
)) cf
))
3076 (r1 (eval `(/ ,arg
,cf
)))
3077 (r2 (eval `(/ ,arg
,(- cf
)))))
3078 (test `(lambda (x) (declare (,type x
)) (/ x
,cf
)) arg r1
)
3079 (test `(lambda (x) (declare (,type x
)) (/ x
,(- cf
))) arg r2
)
3080 ;; rational args should get optimized as well
3081 (test `(lambda (x) (declare (,type x
)) (/ x
,c
)) arg r1
)
3082 (test `(lambda (x) (declare (,type x
)) (/ x
,(- c
))) arg r2
))))
3083 ;; Also check that inexact reciprocals (1) are not used by default (2) are
3084 ;; used with FLOAT-ACCURACY=0.
3085 (dolist (type '(single-float double-float
))
3086 (let ((trey (coerce 3 type
))
3087 (one (coerce 1 type
)))
3088 (test `(lambda (x) (declare (,type x
)) (/ x
3)) trey one
3092 (optimize (sb-c::float-accuracy
0)))
3094 trey
(eval `(* ,trey
(/ ,trey
))))))))
3096 (with-test (:name
:float-multiplication-by-one
)
3097 (flet ((test (lambda-form arg
&optional
(result arg
))
3098 (let* ((fun1 (compile nil lambda-form
))
3099 (fun2 (funcall (compile nil
`(lambda ()
3100 (declare (optimize (sb-c::float-accuracy
0)))
3102 (disassembly1 (with-output-to-string (s)
3103 (disassemble fun1
:stream s
)))
3104 (disassembly2 (with-output-to-string (s)
3105 (disassemble fun2
:stream s
))))
3106 ;; Multiplication at runtime should be eliminated only with
3107 ;; FLOAT-ACCURACY=0. (To catch SNaNs.)
3109 (assert (and (search "MUL" disassembly1
)
3110 (not (search "MUL" disassembly2
))))
3111 ;; Not generic arithmetic, please!
3112 (assert (and (not (search "GENERIC" disassembly1
))
3113 (not (search "GENERIC" disassembly2
))))
3114 (assert (eql result
(funcall fun1 arg
)))
3115 (assert (eql result
(funcall fun2 arg
))))))
3116 (dolist (type '(single-float double-float
))
3117 (let* ((one (coerce 1 type
))
3118 (arg (random (* 2 one
)))
3120 (test `(lambda (x) (declare (,type x
)) (* x
1)) arg
)
3121 (test `(lambda (x) (declare (,type x
)) (* x -
1)) arg -r
)
3122 (test `(lambda (x) (declare (,type x
)) (* x
,one
)) arg
)
3123 (test `(lambda (x) (declare (,type x
)) (* x
,(- one
))) arg -r
)))))
3125 (with-test (:name
:float-addition-of-zero
)
3126 (flet ((test (lambda-form arg
&optional
(result arg
))
3127 (let* ((fun1 (compile nil lambda-form
))
3128 (fun2 (funcall (compile nil
`(lambda ()
3129 (declare (optimize (sb-c::float-accuracy
0)))
3131 (disassembly1 (with-output-to-string (s)
3132 (disassemble fun1
:stream s
)))
3133 (disassembly2 (with-output-to-string (s)
3134 (disassemble fun2
:stream s
))))
3135 ;; Let's make sure there is no addition at runtime: for x86 and
3136 ;; x86-64 that implies an FADD, ADDSS, or ADDSD instruction, so
3137 ;; look for the ADDs in the disassembly. It's a terrible KLUDGE,
3138 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3139 ;; addition in to catch SNaNs.
3141 (assert (and (search "FADD" disassembly1
)
3142 (not (search "FADD" disassembly2
))))
3144 (let ((inst (if (typep result
'double-float
)
3146 (assert (and (search inst disassembly1
)
3147 (not (search inst disassembly2
)))))
3148 (assert (eql result
(funcall fun1 arg
)))
3149 (assert (eql result
(funcall fun2 arg
))))))
3150 (test `(lambda (x) (declare (single-float x
)) (+ x
0)) 123.45)
3151 (test `(lambda (x) (declare (single-float x
)) (+ x
0.0)) 543.21)
3152 (test `(lambda (x) (declare (single-float x
)) (+ x
0.0d0
)) 42.00 42.d0
)
3153 (test `(lambda (x) (declare (double-float x
)) (+ x
0)) 123.45d0
)
3154 (test `(lambda (x) (declare (double-float x
)) (+ x
0.0)) 543.21d0
)
3155 (test `(lambda (x) (declare (double-float x
)) (+ x
0.0d0
)) 42.d0
)))
3157 (with-test (:name
:float-substraction-of-zero
)
3158 (flet ((test (lambda-form arg
&optional
(result arg
))
3159 (let* ((fun1 (compile nil lambda-form
))
3160 (fun2 (funcall (compile nil
`(lambda ()
3161 (declare (optimize (sb-c::float-accuracy
0)))
3163 (disassembly1 (with-output-to-string (s)
3164 (disassemble fun1
:stream s
)))
3165 (disassembly2 (with-output-to-string (s)
3166 (disassemble fun2
:stream s
))))
3167 ;; Let's make sure there is no substraction at runtime: for x86
3168 ;; and x86-64 that implies an FSUB, SUBSS, or SUBSD instruction,
3169 ;; so look for SUB in the disassembly. It's a terrible KLUDGE,
3170 ;; but it works. Unless FLOAT-ACCURACY is zero, we leave the
3171 ;; substraction in in to catch SNaNs.
3173 (assert (and (search "FSUB" disassembly1
)
3174 (not (search "FSUB" disassembly2
))))
3176 (let ((inst (if (typep result
'double-float
)
3178 (assert (and (search inst disassembly1
)
3179 (not (search inst disassembly2
)))))
3180 (assert (eql result
(funcall fun1 arg
)))
3181 (assert (eql result
(funcall fun2 arg
))))))
3182 (test `(lambda (x) (declare (single-float x
)) (- x
0)) 123.45)
3183 (test `(lambda (x) (declare (single-float x
)) (- x
0.0)) 543.21)
3184 (test `(lambda (x) (declare (single-float x
)) (- x
0.0d0
)) 42.00 42.d0
)
3185 (test `(lambda (x) (declare (double-float x
)) (- x
0)) 123.45d0
)
3186 (test `(lambda (x) (declare (double-float x
)) (- x
0.0)) 543.21d0
)
3187 (test `(lambda (x) (declare (double-float x
)) (- x
0.0d0
)) 42.d0
)))
3189 (with-test (:name
:float-multiplication-by-two
)
3190 (flet ((test (lambda-form arg
&optional
(result arg
))
3191 (let* ((fun1 (compile nil lambda-form
))
3192 (fun2 (funcall (compile nil
`(lambda ()
3193 (declare (optimize (sb-c::float-accuracy
0)))
3195 (disassembly1 (with-output-to-string (s)
3196 (disassemble fun1
:stream s
)))
3197 (disassembly2 (with-output-to-string (s)
3198 (disassemble fun2
:stream s
))))
3199 ;; Let's make sure there is no multiplication at runtime: for x86
3200 ;; and x86-64 that implies an FMUL, MULSS, or MULSD instruction,
3201 ;; so look for MUL in the disassembly. It's a terrible KLUDGE,
3204 (assert (and (not (search "MUL" disassembly1
))
3205 (not (search "MUL" disassembly2
))))
3206 (assert (eql result
(funcall fun1 arg
)))
3207 (assert (eql result
(funcall fun2 arg
))))))
3208 (test `(lambda (x) (declare (single-float x
)) (* x
2)) 123.45 246.9)
3209 (test `(lambda (x) (declare (single-float x
)) (* x
2.0)) 543.21 1086.42)
3210 (test `(lambda (x) (declare (single-float x
)) (* x
2.0d0
)) 42.00 84.d0
)
3211 (test `(lambda (x) (declare (double-float x
)) (* x
2)) 123.45d0
246.9d0
)
3212 (test `(lambda (x) (declare (double-float x
)) (* x
2.0)) 543.21d0
1086.42d0
)
3213 (test `(lambda (x) (declare (double-float x
)) (* x
2.0d0
)) 42.0d0
84.0d0
)))
3215 (with-test (:name
:bug-392203
)
3216 ;; Used to hit an AVER in COMVERT-MV-CALL.
3221 (flet ((k (&rest x
) (declare (ignore x
)) 0))
3222 (multiple-value-call #'k
#'k
))))))))
3224 (with-test (:name
:allocate-closures-failing-aver
)
3225 (let ((f (compile nil
`(lambda ()
3226 (labels ((k (&optional x
) #'k
)))))))
3227 (assert (null (funcall f
)))))
3229 (with-test (:name
:flush-vector-creation
)
3230 (let ((f (compile nil
`(lambda ()
3234 (ctu:assert-no-consing
(funcall f
))))
3236 (with-test (:name
:array-type-predicates
)
3237 (dolist (et sb-kernel
::*specialized-array-element-types
*)
3239 (let* ((v (make-array 3 :element-type et
))
3240 (fun (compile nil
`(lambda ()
3242 (if (typep ,v
'(simple-array ,et
(*)))
3245 (if (typep (elt ,v
0) '(simple-array ,et
(*)))
3248 (assert (equal '(:good
:good
) (funcall fun
)))))))
3250 (with-test (:name
:truncate-float
)
3251 (let ((s (compile nil
`(lambda (x)
3252 (declare (single-float x
))
3254 (d (compile nil
`(lambda (x)
3255 (declare (double-float x
))
3257 ;; Check that there is no generic arithmetic
3258 (assert (not (search "GENERIC"
3259 (with-output-to-string (out)
3260 (disassemble s
:stream out
)))))
3261 (assert (not (search "GENERIC"
3262 (with-output-to-string (out)
3263 (disassemble d
:stream out
)))))))
3265 (with-test (:name
:make-array-unnamed-dimension-leaf
)
3266 (let ((fun (compile nil
`(lambda (stuff)
3267 (make-array (map 'list
'length stuff
))))))
3268 (assert (equalp #2A
((0 0 0) (0 0 0))
3269 (funcall fun
'((1 2) (1 2 3)))))))
3271 (with-test (:name
:fp-decoding-funs-not-flushable-in-safe-code
)
3272 (dolist (name '(float-sign float-radix float-digits float-precision decode-float
3273 integer-decode-float
))
3274 (let ((fun (compile nil
`(lambda (x)
3275 (declare (optimize safety
))
3283 (error "(~S ~S) did not error"
3289 (when (member name
'(decode-float integer-decode-float
))
3290 (test sb-ext
:single-float-positive-infinity
))))))
3292 (with-test (:name
:sap-ref-16
)
3293 (let* ((fun (compile nil
`(lambda (x y
)
3294 (declare (type sb-sys
:system-area-pointer x
)
3295 (type (integer 0 100) y
))
3296 (sb-sys:sap-ref-16 x
(+ 4 y
)))))
3297 (vector (coerce '(0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15)
3298 '(simple-array (unsigned-byte 8) (*))))
3299 (sap (sb-sys:vector-sap vector
))
3300 (ret (funcall fun sap
0)))
3301 ;; test for either endianness
3302 (assert (or (= ret
(+ (* 5 256) 4)) (= ret
(+ (* 4 256) 5))))))
3304 (with-test (:name
:coerce-type-warning
)
3305 (dolist (type '(t (unsigned-byte 8) (unsigned-byte 16) (unsigned-byte 32)
3306 (signed-byte 8) (signed-byte 16) (signed-byte 32)))
3307 (multiple-value-bind (fun warningsp failurep
)
3308 (compile nil
`(lambda (x)
3309 (declare (type simple-vector x
))
3310 (coerce x
'(vector ,type
))))
3311 (assert (null warningsp
))
3312 (assert (null failurep
))
3313 (assert (typep (funcall fun
#(1)) `(simple-array ,type
(*)))))))