1 ;;;; tests that dynamic-extent functionality works.
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 (when (eq sb-ext
:*evaluator-mode
* :interpret
)
15 (sb-ext:quit
:unix-status
104))
17 (setq sb-c
::*check-consistency
* t
18 sb-ext
:*stack-allocate-dynamic-extent
* t
)
20 (defmacro defun-with-dx
(name arglist
&body body
)
21 `(defun ,name
,arglist
24 (declaim (notinline opaque-identity
))
25 (defun opaque-identity (x)
29 (defun-with-dx dxlength
(&rest rest
)
30 (declare (dynamic-extent rest
))
33 (assert (= (dxlength 1 2 3) 3))
34 (assert (= (dxlength t t t t t t
) 6))
35 (assert (= (dxlength) 0))
38 (destructuring-bind (a b c d e f
&rest g
) list
39 (+ a b c d e f
(length g
))))
41 (defun-with-dx dxcaller
(&rest rest
)
42 (declare (dynamic-extent rest
))
44 (assert (= (dxcaller 1 2 3 4 5 6 7) 22))
46 (defun-with-dx dxcaller-align-1
(x &rest rest
)
47 (declare (dynamic-extent rest
))
49 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7) 39))
50 (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7 8) 40))
53 (defun-with-dx test-nip-values
()
54 (flet ((bar (x &rest y
)
55 (declare (dynamic-extent y
))
59 (multiple-value-call #'values
63 (assert (equal (multiple-value-list (test-nip-values)) '(1 5 a
)))
65 ;;; LET-variable substitution
66 (defun-with-dx test-let-var-subst1
(x)
67 (let ((y (list x
(1- x
))))
68 (opaque-identity :foo
)
69 (let ((z (the list y
)))
70 (declare (dynamic-extent z
))
72 (assert (eql (test-let-var-subst1 17) 2))
74 (defun-with-dx test-let-var-subst2
(x)
75 (let ((y (list x
(1- x
))))
76 (declare (dynamic-extent y
))
77 (opaque-identity :foo
)
78 (let ((z (the list y
)))
80 (assert (eql (test-let-var-subst2 17) 2))
82 ;;; DX propagation through LET-return.
83 (defun-with-dx test-lvar-subst
(x)
84 (let ((y (list x
(1- x
))))
85 (declare (dynamic-extent y
))
86 (second (let ((z (the list y
)))
87 (opaque-identity :foo
)
89 (assert (eql (test-lvar-subst 11) 10))
91 ;;; this code is incorrect, but the compiler should not fail
92 (defun-with-dx test-let-var-subst-incorrect
(x)
93 (let ((y (list x
(1- x
))))
94 (opaque-identity :foo
)
95 (let ((z (the list y
)))
96 (declare (dynamic-extent z
))
97 (opaque-identity :bar
)
102 (defun-with-dx test-alignment-dx-list
(form)
103 (multiple-value-prog1 (eval form
)
104 (let ((l (list 1 2 3 4)))
105 (declare (dynamic-extent l
))
106 (setq *x
* (copy-list l
)))))
108 (let* ((res (loop for i below n collect i
))
109 (form `(values ,@res
)))
110 (assert (equal (multiple-value-list (test-alignment-dx-list form
)) res
))
111 (assert (equal *x
* '(1 2 3 4)))))
115 (declaim (notinline true
))
120 (defun-with-dx dxclosure
(x)
123 (declare (dynamic-extent #'f
))
126 (assert (eq t
(dxclosure 13)))
130 (defun-with-dx dx-value-cell
(x)
131 ;; Not implemented everywhere, yet.
132 #+(or x86 x86-64 mips hppa
)
134 (declare (sb-int:truly-dynamic-extent cell
))
137 (declare (dynamic-extent #'f
))
142 (defun-with-dx cons-on-stack
(x)
143 (let ((cons (cons x x
)))
144 (declare (dynamic-extent cons
))
150 (defun force-make-array-on-stack (n)
151 (declare (optimize safety
))
152 (let ((v (make-array (min n
1))))
153 (declare (sb-int:truly-dynamic-extent v
))
157 (defun-with-dx make-array-on-stack-1
()
158 (let ((v (make-array '(42) :element-type
'single-float
)))
159 (declare (dynamic-extent v
))
163 (defun-with-dx make-array-on-stack-2
(n x
)
164 (declare (integer n
))
165 (let ((v (make-array n
:initial-contents x
)))
166 (declare (sb-int:truly-dynamic-extent v
))
170 (defun-with-dx make-array-on-stack-3
(x y z
)
171 (let ((v (make-array 3
172 :element-type
'fixnum
:initial-contents
(list x y z
)
173 :element-type t
:initial-contents x
)))
174 (declare (sb-int:truly-dynamic-extent v
))
178 (defun-with-dx make-array-on-stack-4
()
179 (let ((v (make-array 3 :initial-contents
'(1 2 3))))
180 (declare (sb-int:truly-dynamic-extent v
))
184 ;;; Unfortunately VECTOR-FILL* conses right now, so this one
185 ;;; doesn't pass yet.
187 (defun-with-dx make-array-on-stack-5
()
188 (let ((v (make-array 3 :initial-element
12 :element-type t
)))
189 (declare (sb-int:truly-dynamic-extent v
))
193 (defun-with-dx vector-on-stack
(x y
)
194 (let ((v (vector 1 x
2 y
3)))
195 (declare (sb-int:truly-dynamic-extent v
))
201 (declaim (inline make-fp-struct-1
))
202 (defstruct fp-struct-1
203 (s 0.0 :type single-float
)
204 (d 0.0d0
:type double-float
))
206 (defun-with-dx test-fp-struct-1.1
(s d
)
207 (let ((fp (make-fp-struct-1 :s s
)))
208 (declare (dynamic-extent fp
))
209 (assert (eql s
(fp-struct-1-s fp
)))
210 (assert (eql 0.0d0
(fp-struct-1-d fp
)))))
212 (defun-with-dx test-fp-struct-1.2
(s d
)
213 (let ((fp (make-fp-struct-1 :d d
)))
214 (declare (dynamic-extent fp
))
215 (assert (eql 0.0 (fp-struct-1-s fp
)))
216 (assert (eql d
(fp-struct-1-d fp
)))))
218 (defun-with-dx test-fp-struct-1.3
(s d
)
219 (let ((fp (make-fp-struct-1 :d d
:s s
)))
220 (declare (dynamic-extent fp
))
221 (assert (eql s
(fp-struct-1-s fp
)))
222 (assert (eql d
(fp-struct-1-d fp
)))))
224 (defun-with-dx test-fp-struct-1.4
(s d
)
225 (let ((fp (make-fp-struct-1 :s s
:d d
)))
226 (declare (dynamic-extent fp
))
227 (assert (eql s
(fp-struct-1-s fp
)))
228 (assert (eql d
(fp-struct-1-d fp
)))))
230 (test-fp-struct-1.1
123.456 876.243d0
)
231 (test-fp-struct-1.2
123.456 876.243d0
)
232 (test-fp-struct-1.3
123.456 876.243d0
)
233 (test-fp-struct-1.4
123.456 876.243d0
)
235 (declaim (inline make-fp-struct-2
))
236 (defstruct fp-struct-2
237 (d 0.0d0
:type double-float
)
238 (s 0.0 :type single-float
))
240 (defun-with-dx test-fp-struct-2.1
(s d
)
241 (let ((fp (make-fp-struct-2 :s s
)))
242 (declare (dynamic-extent fp
))
243 (assert (eql s
(fp-struct-2-s fp
)))
244 (assert (eql 0.0d0
(fp-struct-2-d fp
)))))
246 (defun-with-dx test-fp-struct-2.2
(s d
)
247 (let ((fp (make-fp-struct-2 :d d
)))
248 (declare (dynamic-extent fp
))
249 (assert (eql 0.0 (fp-struct-2-s fp
)))
250 (assert (eql d
(fp-struct-2-d fp
)))))
252 (defun-with-dx test-fp-struct-2.3
(s d
)
253 (let ((fp (make-fp-struct-2 :d d
:s s
)))
254 (declare (dynamic-extent fp
))
255 (assert (eql s
(fp-struct-2-s fp
)))
256 (assert (eql d
(fp-struct-2-d fp
)))))
258 (defun-with-dx test-fp-struct-2.4
(s d
)
259 (let ((fp (make-fp-struct-2 :s s
:d d
)))
260 (declare (dynamic-extent fp
))
261 (assert (eql s
(fp-struct-2-s fp
)))
262 (assert (eql d
(fp-struct-2-d fp
)))))
264 (test-fp-struct-2.1
123.456 876.243d0
)
265 (test-fp-struct-2.2
123.456 876.243d0
)
266 (test-fp-struct-2.3
123.456 876.243d0
)
267 (test-fp-struct-2.4
123.456 876.243d0
)
269 (declaim (inline make-cfp-struct-1
))
270 (defstruct cfp-struct-1
271 (s (complex 0.0) :type
(complex single-float
))
272 (d (complex 0.0d0
) :type
(complex double-float
)))
274 (defun-with-dx test-cfp-struct-1.1
(s d
)
275 (let ((cfp (make-cfp-struct-1 :s s
)))
276 (declare (dynamic-extent cfp
))
277 (assert (eql s
(cfp-struct-1-s cfp
)))
278 (assert (eql (complex 0.0d0
) (cfp-struct-1-d cfp
)))))
280 (defun-with-dx test-cfp-struct-1.2
(s d
)
281 (let ((cfp (make-cfp-struct-1 :d d
)))
282 (declare (dynamic-extent cfp
))
283 (assert (eql (complex 0.0) (cfp-struct-1-s cfp
)))
284 (assert (eql d
(cfp-struct-1-d cfp
)))))
286 (defun-with-dx test-cfp-struct-1.3
(s d
)
287 (let ((cfp (make-cfp-struct-1 :d d
:s s
)))
288 (declare (dynamic-extent cfp
))
289 (assert (eql s
(cfp-struct-1-s cfp
)))
290 (assert (eql d
(cfp-struct-1-d cfp
)))))
292 (defun-with-dx test-cfp-struct-1.4
(s d
)
293 (let ((cfp (make-cfp-struct-1 :s s
:d d
)))
294 (declare (dynamic-extent cfp
))
295 (assert (eql s
(cfp-struct-1-s cfp
)))
296 (assert (eql d
(cfp-struct-1-d cfp
)))))
298 (test-cfp-struct-1.1
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
299 (test-cfp-struct-1.2
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
300 (test-cfp-struct-1.3
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
301 (test-cfp-struct-1.4
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
303 (declaim (inline make-cfp-struct-2
))
304 (defstruct cfp-struct-2
305 (d (complex 0.0d0
) :type
(complex double-float
))
306 (s (complex 0.0) :type
(complex single-float
)))
308 (defun-with-dx test-cfp-struct-2.1
(s d
)
309 (let ((cfp (make-cfp-struct-2 :s s
)))
310 (declare (dynamic-extent cfp
))
311 (assert (eql s
(cfp-struct-2-s cfp
)))
312 (assert (eql (complex 0.0d0
) (cfp-struct-2-d cfp
)))))
314 (defun-with-dx test-cfp-struct-2.2
(s d
)
315 (let ((cfp (make-cfp-struct-2 :d d
)))
316 (declare (dynamic-extent cfp
))
317 (assert (eql (complex 0.0) (cfp-struct-2-s cfp
)))
318 (assert (eql d
(cfp-struct-2-d cfp
)))))
320 (defun-with-dx test-cfp-struct-2.3
(s d
)
321 (let ((cfp (make-cfp-struct-2 :d d
:s s
)))
322 (declare (dynamic-extent cfp
))
323 (assert (eql s
(cfp-struct-2-s cfp
)))
324 (assert (eql d
(cfp-struct-2-d cfp
)))))
326 (defun-with-dx test-cfp-struct-2.4
(s d
)
327 (let ((cfp (make-cfp-struct-2 :s s
:d d
)))
328 (declare (dynamic-extent cfp
))
329 (assert (eql s
(cfp-struct-2-s cfp
)))
330 (assert (eql d
(cfp-struct-2-d cfp
)))))
332 (test-cfp-struct-2.1
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
333 (test-cfp-struct-2.2
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
334 (test-cfp-struct-2.3
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
335 (test-cfp-struct-2.4
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
337 (declaim (inline make-foo1 make-foo2 make-foo3
))
340 (defun-with-dx make-foo1-on-stack
(x)
341 (let ((foo (make-foo1 :x x
)))
342 (declare (dynamic-extent foo
))
343 (assert (eql x
(foo1-x foo
)))))
346 (x 0.0 :type single-float
)
347 (y 0.0d0
:type double-float
)
352 (defmacro assert-eql
(expected got
)
353 `(let ((exp ,expected
)
355 (unless (eql exp got
)
356 (error "Expected ~S, got ~S!" exp got
))))
358 (defun-with-dx make-foo2-on-stack
(x y
)
359 (let ((foo (make-foo2 :y y
:c
'c
)))
360 (declare (dynamic-extent foo
))
361 (assert-eql 0.0 (foo2-x foo
))
362 (assert-eql y
(foo2-y foo
))
363 (assert-eql 'c
(foo2-c foo
))
364 (assert-eql nil
(foo2-b foo
))))
366 ;;; Check that constants work out as argument for all relevant
371 (c 2 :type sb-vm
:word
)
372 (d 3.0 :type single-float
)
373 (e 4.0d0
:type double-float
))
374 (defun-with-dx make-foo3-on-stack
()
375 (let ((foo (make-foo3)))
376 (declare (dynamic-extent foo
))
377 (assert (eql 0 (foo3-a foo
)))
378 (assert (eql 1 (foo3-b foo
)))
379 (assert (eql 2 (foo3-c foo
)))
380 (assert (eql 3.0 (foo3-d foo
)))
381 (assert (eql 4.0d0
(foo3-e foo
)))))
385 (defun-with-dx nested-dx-lists
()
386 (let ((dx (list (list 1 2) (list 3 4))))
387 (declare (dynamic-extent dx
))
391 (defun-with-dx nested-dx-conses
()
392 (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t
) nil
))))))
393 (declare (dynamic-extent dx
))
397 (defun-with-dx nested-dx-not-used
(x)
399 (let ((l (setf (car x
) (list x x x
))))
400 (declare (dynamic-extent l
))
405 (defun-with-dx nested-evil-dx-used
(x)
407 (let ((l (list x x x
)))
408 (declare (dynamic-extent l
))
416 (defparameter *bar
* nil
)
417 (declaim (inline make-nested-bad make-nested-good
))
418 (defstruct (nested (:constructor make-nested-bad
(&key bar
&aux
(bar (setf *bar
* bar
))))
419 (:constructor make-nested-good
(&key bar
)))
422 (defun-with-dx nested-good
(y)
423 (let ((x (list (list (make-nested-good :bar
(list (list (make-nested-good :bar
(list y
)))))))))
424 (declare (dynamic-extent x
))
427 (defun-with-dx nested-bad
(y)
428 (let ((x (list (list (make-nested-bad :bar
(list (list (make-nested-bad :bar
(list y
)))))))))
429 (declare (dynamic-extent x
))
430 (unless (equalp (caar x
) (make-nested-good :bar
*bar
*))
431 (error "got ~S, wanted ~S" (caar x
) (make-nested-good :bar
*bar
*)))
434 (with-test (:name
:conservative-nested-dx
)
435 ;; NESTED-BAD should not stack-allocate :BAR due to the SETF.
436 (assert (equalp (nested-bad 42) (make-nested-good :bar
*bar
*)))
437 (assert (equalp *bar
* (list (list (make-nested-bad :bar
(list 42)))))))
439 ;;; multiple uses for dx lvar
441 (defun-with-dx multiple-dx-uses
()
442 (let ((dx (if (true t
)
445 (declare (dynamic-extent dx
))
449 ;;; handler-case and handler-bind should use DX internally
451 (defun dx-handler-bind (x)
452 (handler-bind ((error
453 (lambda (c) (break "OOPS: ~S caused ~S" x c
)))
454 ((and serious-condition
(not error
))
455 #'(lambda (c) (break "OOPS2: ~S did ~S" x c
))))
458 (defun dx-handler-case (x)
459 (assert (zerop (handler-case (/ 2 x
)
461 (break "OOPS: ~S caused ~S" x c
))
465 ;;; with-spinlock and with-mutex should use DX and not cons
467 (defvar *slock
* (sb-thread::make-spinlock
:name
"slocklock"))
469 (defun test-spinlock ()
470 (sb-thread::with-spinlock
(*slock
*)
473 (defvar *mutex
* (sb-thread::make-mutex
:name
"mutexlock"))
476 (sb-thread:with-mutex
(*mutex
*)
479 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
481 (defvar *table
* (make-hash-table))
483 (defun test-hash-table ()
484 (setf (gethash 5 *table
*) 13)
487 (defmacro assert-no-consing
(form &optional times
)
488 `(%assert-no-consing
(lambda () ,form
) ,times
))
489 (defun %assert-no-consing
(thunk &optional times
)
490 (let ((before (get-bytes-consed))
491 (times (or times
10000)))
492 (declare (type (integer 1 *) times
))
495 (assert (< (- (get-bytes-consed) before
) times
))))
497 (defmacro assert-consing
(form &optional times
)
498 `(%assert-consing
(lambda () ,form
) ,times
))
499 (defun %assert-consing
(thunk &optional times
)
500 (let ((before (get-bytes-consed))
501 (times (or times
10000)))
502 (declare (type (integer 1 *) times
))
505 (assert (not (< (- (get-bytes-consed) before
) times
)))))
507 (defvar *a-cons
* (cons nil nil
))
509 #+(or x86 x86-64 alpha ppc sparc mips hppa
)
511 (assert-no-consing (dxclosure 42))
512 (assert-no-consing (dxlength 1 2 3))
513 (assert-no-consing (dxlength t t t t t t
))
514 (assert-no-consing (dxlength))
515 (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
516 (assert-no-consing (test-nip-values))
517 (assert-no-consing (test-let-var-subst1 17))
518 (assert-no-consing (test-let-var-subst2 17))
519 (assert-no-consing (test-lvar-subst 11))
520 (assert-no-consing (dx-value-cell 13))
521 ;; Only for platforms with DX FIXED-ALLOC
522 #+(or hppa mips x86 x86-64
)
524 (assert-no-consing (cons-on-stack 42))
525 (assert-no-consing (make-foo1-on-stack 123))
526 (assert-no-consing (nested-good 42))
527 (assert-no-consing (nested-dx-conses))
528 (assert-no-consing (dx-handler-bind 2))
529 (assert-no-consing (dx-handler-case 2)))
530 ;; Only for platforms with DX ALLOCATE-VECTOR
531 #+(or hppa mips x86 x86-64
)
533 (assert-no-consing (force-make-array-on-stack 128))
534 (assert-no-consing (make-array-on-stack-1))
535 (assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
536 (assert-no-consing (make-array-on-stack-3 9 8 7))
537 (assert-no-consing (make-array-on-stack-4))
539 (assert-no-consing (make-array-on-stack-5))
540 (assert-no-consing (vector-on-stack :x
:y
)))
541 (#+raw-instance-init-vops assert-no-consing
542 #-raw-instance-init-vops progn
543 (make-foo2-on-stack 1.24 1.23d0
))
544 (#+raw-instance-init-vops assert-no-consing
545 #-raw-instance-init-vops progn
546 (make-foo3-on-stack))
547 (assert-no-consing (nested-dx-lists))
548 (assert-consing (nested-dx-not-used *a-cons
*))
549 (assert-no-consing (nested-evil-dx-used *a-cons
*))
550 (assert-no-consing (multiple-dx-uses))
552 (assert-no-consing (test-hash-table))
555 (assert-no-consing (test-spinlock))
556 (assert-no-consing (test-mutex))))
559 ;;; Bugs found by Paul F. Dietz
566 (declare (optimize (speed 2) (space 0) (safety 0)
567 (debug 1) (compilation-speed 3)))
568 (let* ((v5 (cons b b
)))
569 (declare (dynamic-extent v5
))
577 ;;; bug reported by Svein Ove Aas
578 (defun svein-2005-ii-07 (x y
)
579 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
580 (let ((args (list* y
1 2 x
)))
581 (declare (dynamic-extent args
))
582 (apply #'aref args
)))
586 #3A
(((1 1 1) (1 1 1) (1 1 1))
587 ((1 1 1) (1 1 1) (4 1 1))
588 ((1 1 1) (1 1 1) (1 1 1))))
591 ;;; bug reported by Brian Downing: stack-allocated arrays were not
592 ;;; filled with zeroes.
593 (defun-with-dx bdowning-2005-iv-16
()
594 (let ((a (make-array 11 :initial-element
0)))
595 (declare (dynamic-extent a
))
596 (assert (every (lambda (x) (eql x
0)) a
))))
597 (with-test (:name
:bdowning-2005-iv-16
)
598 #+(or hppa mips x86 x86-64
)
599 (assert-no-consing (bdowning-2005-iv-16))
600 (bdowning-2005-iv-16))
602 (defun-with-dx let-converted-vars-dx-allocated-bug
(x y z
)
603 (let* ((a (list x y z
))
606 (declare (dynamic-extent c
))
607 (values (first c
) (second c
))))
609 (with-test (:name
:let-converted-vars-dx-allocated-bug
)
610 (multiple-value-bind (i j
) (let-converted-vars-dx-allocated-bug 1 2 3)
611 (assert (and (equal i j
)
612 (equal i
(list 1 2 3))))))
614 ;;; workaround for bug 419 -- real issue remains, but check that the
616 (defun-with-dx bug419
(x)
617 (multiple-value-call #'list
618 (eval '(values 1 2 3))
620 (declare (dynamic-extent x
))
625 (declare (dynamic-extent #'mget
#'mset
))
626 ((lambda (f g
) (eval `(progn ,f
,g
(values 4 5 6)))) #'mget
#'mset
)))))
627 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
629 ;;; Multiple DX arguments in a local function call
630 (defun test-dx-flet-test (fun n f1 f2 f3
)
631 (let ((res (with-output-to-string (s)
632 (assert (eql n
(ignore-errors (funcall fun s
)))))))
633 (multiple-value-bind (x pos
) (read-from-string res nil
)
634 (assert (equalp f1 x
))
635 (multiple-value-bind (y pos2
) (read-from-string res nil nil
:start pos
)
636 (assert (equalp f2 y
))
637 (assert (equalp f3
(read-from-string res nil nil
:start pos2
))))))
638 #+(or hppa mips x86 x86-64
)
639 (assert-no-consing (assert (eql n
(funcall fun nil
))))
640 (assert (eql n
(funcall fun nil
))))
641 (macrolet ((def (n f1 f2 f3
)
642 (let ((name (sb-pcl::format-symbol
:cl-user
"DX-FLET-TEST.~A" n
)))
644 (defun-with-dx ,name
(s)
646 (declare (dynamic-extent x
))
655 (test-dx-flet-test #',name
,n
,f1
,f2
,f3
)))))
656 (def 0 (list :one
) (list :two
) (list :three
))
657 (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list
))
658 (def 2 (list 1) (list 2 3) (list 4 5 6 7)))
660 ;;; Test that unknown-values coming after a DX value won't mess up the stack analysis
661 (defun test-update-uvl-live-sets (x y z
)
662 (declare (optimize speed
(safety 0)))
664 (declare (dynamic-extent a
))
665 (eval `(list (length ',a
) ',b
))))
667 (bar (list x y z
) ; dx push
669 (multiple-value-call 'list
670 (eval '(values 1 2 3)) ; uv push
675 (assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))
677 (with-test (:name
:regression-1.0
.23.38)
678 (compile nil
'(lambda ()
680 (let ((res (cons x x
)))
683 (declaim (inline make
))
684 (let ((z (make 1 2)))
685 (declare (dynamic-extent z
))
688 (compile nil
'(lambda ()
690 (let ((res (cons x x
)))
693 (declaim (inline make
))
694 (let ((z (make 1 2)))
695 (declare (dynamic-extent z
))
699 ;;; On x86 and x86-64 upto 1.0.28.16 LENGTH and WORDS argument
700 ;;; tns to ALLOCATE-VECTOR-ON-STACK could be packed in the same
701 ;;; location, leading to all manner of badness. ...reproducing this
702 ;;; reliably is hard, but this it at least used to break on x86-64.
703 (defun length-and-words-packed-in-same-tn (m)
704 (declare (optimize speed
(safety 0) (debug 0) (space 0)))
705 (let ((array (make-array (max 1 m
) :element-type
'fixnum
)))
706 (declare (dynamic-extent array
))
707 (array-total-size array
)))
708 (with-test (:name
:length-and-words-packed-in-same-tn
)
709 (assert (= 1 (length-and-words-packed-in-same-tn -
3))))
711 (with-test (:name
:handler-case-bogus-compiler-note
)
712 (handler-bind ((compiler-note #'error
))
713 ;; Taken from SWANK, used to signal a bogus stack allocation
716 `(lambda (files fasl-dir load
)
717 (let ((needs-recompile nil
))
719 (let ((dest (binary-pathname src fasl-dir
)))
722 (when (or needs-recompile
723 (not (probe-file dest
))
724 (file-newer-p src dest
))
725 (setq needs-recompile t
)
726 (ensure-directories-exist dest
)
727 (compile-file src
:output-file dest
:print nil
:verbose t
))
729 (load dest
:verbose t
)))
730 (serious-condition (c)
731 (handle-loadtime-error c dest
))))))))))
733 (with-test (:name
:dx-compiler-notes
)
735 (handler-bind ((compiler-note (lambda (c)
736 (declare (ignore cc
))
738 (compile nil
`(lambda (x)
739 (let ((v (make-array x
)))
740 (declare (dynamic-extent v
))
743 (compile nil
`(lambda (x)
744 (let ((y (if (plusp x
)
747 (declare (dynamic-extent y
))