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
)
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-with-dx make-array-on-stack
()
151 (let ((v (make-array '(42) :element-type
'single-float
)))
152 (declare (dynamic-extent v
))
158 (declaim (inline make-fp-struct-1
))
159 (defstruct fp-struct-1
160 (s 0.0 :type single-float
)
161 (d 0.0d0
:type double-float
))
163 (defun-with-dx test-fp-struct-1.1
(s d
)
164 (let ((fp (make-fp-struct-1 :s s
)))
165 (declare (dynamic-extent fp
))
166 (assert (eql s
(fp-struct-1-s fp
)))
167 (assert (eql 0.0d0
(fp-struct-1-d fp
)))))
169 (defun-with-dx test-fp-struct-1.2
(s d
)
170 (let ((fp (make-fp-struct-1 :d d
)))
171 (declare (dynamic-extent fp
))
172 (assert (eql 0.0 (fp-struct-1-s fp
)))
173 (assert (eql d
(fp-struct-1-d fp
)))))
175 (defun-with-dx test-fp-struct-1.3
(s d
)
176 (let ((fp (make-fp-struct-1 :d d
:s s
)))
177 (declare (dynamic-extent fp
))
178 (assert (eql s
(fp-struct-1-s fp
)))
179 (assert (eql d
(fp-struct-1-d fp
)))))
181 (defun-with-dx test-fp-struct-1.4
(s d
)
182 (let ((fp (make-fp-struct-1 :s s
:d d
)))
183 (declare (dynamic-extent fp
))
184 (assert (eql s
(fp-struct-1-s fp
)))
185 (assert (eql d
(fp-struct-1-d fp
)))))
187 (test-fp-struct-1.1
123.456 876.243d0
)
188 (test-fp-struct-1.2
123.456 876.243d0
)
189 (test-fp-struct-1.3
123.456 876.243d0
)
190 (test-fp-struct-1.4
123.456 876.243d0
)
192 (declaim (inline make-fp-struct-2
))
193 (defstruct fp-struct-2
194 (d 0.0d0
:type double-float
)
195 (s 0.0 :type single-float
))
197 (defun-with-dx test-fp-struct-2.1
(s d
)
198 (let ((fp (make-fp-struct-2 :s s
)))
199 (declare (dynamic-extent fp
))
200 (assert (eql s
(fp-struct-2-s fp
)))
201 (assert (eql 0.0d0
(fp-struct-2-d fp
)))))
203 (defun-with-dx test-fp-struct-2.2
(s d
)
204 (let ((fp (make-fp-struct-2 :d d
)))
205 (declare (dynamic-extent fp
))
206 (assert (eql 0.0 (fp-struct-2-s fp
)))
207 (assert (eql d
(fp-struct-2-d fp
)))))
209 (defun-with-dx test-fp-struct-2.3
(s d
)
210 (let ((fp (make-fp-struct-2 :d d
:s s
)))
211 (declare (dynamic-extent fp
))
212 (assert (eql s
(fp-struct-2-s fp
)))
213 (assert (eql d
(fp-struct-2-d fp
)))))
215 (defun-with-dx test-fp-struct-2.4
(s d
)
216 (let ((fp (make-fp-struct-2 :s s
:d d
)))
217 (declare (dynamic-extent fp
))
218 (assert (eql s
(fp-struct-2-s fp
)))
219 (assert (eql d
(fp-struct-2-d fp
)))))
221 (test-fp-struct-2.1
123.456 876.243d0
)
222 (test-fp-struct-2.2
123.456 876.243d0
)
223 (test-fp-struct-2.3
123.456 876.243d0
)
224 (test-fp-struct-2.4
123.456 876.243d0
)
226 (declaim (inline make-cfp-struct-1
))
227 (defstruct cfp-struct-1
228 (s (complex 0.0) :type
(complex single-float
))
229 (d (complex 0.0d0
) :type
(complex double-float
)))
231 (defun-with-dx test-cfp-struct-1.1
(s d
)
232 (let ((cfp (make-cfp-struct-1 :s s
)))
233 (declare (dynamic-extent cfp
))
234 (assert (eql s
(cfp-struct-1-s cfp
)))
235 (assert (eql (complex 0.0d0
) (cfp-struct-1-d cfp
)))))
237 (defun-with-dx test-cfp-struct-1.2
(s d
)
238 (let ((cfp (make-cfp-struct-1 :d d
)))
239 (declare (dynamic-extent cfp
))
240 (assert (eql (complex 0.0) (cfp-struct-1-s cfp
)))
241 (assert (eql d
(cfp-struct-1-d cfp
)))))
243 (defun-with-dx test-cfp-struct-1.3
(s d
)
244 (let ((cfp (make-cfp-struct-1 :d d
:s s
)))
245 (declare (dynamic-extent cfp
))
246 (assert (eql s
(cfp-struct-1-s cfp
)))
247 (assert (eql d
(cfp-struct-1-d cfp
)))))
249 (defun-with-dx test-cfp-struct-1.4
(s d
)
250 (let ((cfp (make-cfp-struct-1 :s s
:d d
)))
251 (declare (dynamic-extent cfp
))
252 (assert (eql s
(cfp-struct-1-s cfp
)))
253 (assert (eql d
(cfp-struct-1-d cfp
)))))
255 (test-cfp-struct-1.1
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
256 (test-cfp-struct-1.2
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
257 (test-cfp-struct-1.3
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
258 (test-cfp-struct-1.4
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
260 (declaim (inline make-cfp-struct-2
))
261 (defstruct cfp-struct-2
262 (d (complex 0.0d0
) :type
(complex double-float
))
263 (s (complex 0.0) :type
(complex single-float
)))
265 (defun-with-dx test-cfp-struct-2.1
(s d
)
266 (let ((cfp (make-cfp-struct-2 :s s
)))
267 (declare (dynamic-extent cfp
))
268 (assert (eql s
(cfp-struct-2-s cfp
)))
269 (assert (eql (complex 0.0d0
) (cfp-struct-2-d cfp
)))))
271 (defun-with-dx test-cfp-struct-2.2
(s d
)
272 (let ((cfp (make-cfp-struct-2 :d d
)))
273 (declare (dynamic-extent cfp
))
274 (assert (eql (complex 0.0) (cfp-struct-2-s cfp
)))
275 (assert (eql d
(cfp-struct-2-d cfp
)))))
277 (defun-with-dx test-cfp-struct-2.3
(s d
)
278 (let ((cfp (make-cfp-struct-2 :d d
:s s
)))
279 (declare (dynamic-extent cfp
))
280 (assert (eql s
(cfp-struct-2-s cfp
)))
281 (assert (eql d
(cfp-struct-2-d cfp
)))))
283 (defun-with-dx test-cfp-struct-2.4
(s d
)
284 (let ((cfp (make-cfp-struct-2 :s s
:d d
)))
285 (declare (dynamic-extent cfp
))
286 (assert (eql s
(cfp-struct-2-s cfp
)))
287 (assert (eql d
(cfp-struct-2-d cfp
)))))
289 (test-cfp-struct-2.1
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
290 (test-cfp-struct-2.2
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
291 (test-cfp-struct-2.3
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
292 (test-cfp-struct-2.4
(complex 0.123 123.456) (complex 908132.41d0
876.243d0
))
294 (declaim (inline make-foo1 make-foo2 make-foo3
))
297 (defun-with-dx make-foo1-on-stack
(x)
298 (let ((foo (make-foo1 :x x
)))
299 (declare (dynamic-extent foo
))
300 (assert (eql x
(foo1-x foo
)))))
303 (x 0.0 :type single-float
)
304 (y 0.0d0
:type double-float
)
309 (defmacro assert-eql
(expected got
)
310 `(let ((exp ,expected
)
312 (unless (eql exp got
)
313 (error "Expected ~S, got ~S!" exp got
))))
315 (defun-with-dx make-foo2-on-stack
(x y
)
316 (let ((foo (make-foo2 :y y
:c
'c
)))
317 (declare (dynamic-extent foo
))
318 (assert-eql 0.0 (foo2-x foo
))
319 (assert-eql y
(foo2-y foo
))
320 (assert-eql 'c
(foo2-c foo
))
321 (assert-eql nil
(foo2-b foo
))))
323 ;;; Check that constants work out as argument for all relevant
328 (c 2 :type sb-vm
:word
)
329 (d 3.0 :type single-float
)
330 (e 4.0d0
:type double-float
))
331 (defun-with-dx make-foo3-on-stack
()
332 (let ((foo (make-foo3)))
333 (declare (dynamic-extent foo
))
334 (assert (eql 0 (foo3-a foo
)))
335 (assert (eql 1 (foo3-b foo
)))
336 (assert (eql 2 (foo3-c foo
)))
337 (assert (eql 3.0 (foo3-d foo
)))
338 (assert (eql 4.0d0
(foo3-e foo
)))))
342 (defun-with-dx nested-dx-lists
()
343 (let ((dx (list (list 1 2) (list 3 4))))
344 (declare (dynamic-extent dx
))
348 (defun-with-dx nested-dx-conses
()
349 (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t
) nil
))))))
350 (declare (dynamic-extent dx
))
354 (defun-with-dx nested-dx-not-used
(x)
356 (let ((l (setf (car x
) (list x x x
))))
357 (declare (dynamic-extent l
))
362 (defun-with-dx nested-evil-dx-used
(x)
364 (let ((l (list x x x
)))
365 (declare (dynamic-extent l
))
373 ;;; multiple uses for dx lvar
375 (defun-with-dx multiple-dx-uses
()
376 (let ((dx (if (true t
)
379 (declare (dynamic-extent dx
))
383 ;;; handler-case and handler-bind should use DX internally
385 (defun dx-handler-bind (x)
386 (handler-bind ((error
387 (lambda (c) (break "OOPS: ~S caused ~S" x c
)))
388 ((and serious-condition
(not error
))
389 #'(lambda (c) (break "OOPS2: ~S did ~S" x c
))))
392 (defun dx-handler-case (x)
393 (assert (zerop (handler-case (/ 2 x
)
395 (break "OOPS: ~S caused ~S" x c
))
399 ;;; with-spinlock and with-mutex should use DX and not cons
401 (defvar *slock
* (sb-thread::make-spinlock
:name
"slocklock"))
403 (defun test-spinlock ()
404 (sb-thread::with-spinlock
(*slock
*)
407 (defvar *mutex
* (sb-thread::make-mutex
:name
"mutexlock"))
410 (sb-thread:with-mutex
(*mutex
*)
413 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
415 (defvar *table
* (make-hash-table))
417 (defun test-hash-table ()
418 (setf (gethash 5 *table
*) 13)
421 (defmacro assert-no-consing
(form &optional times
)
422 `(%assert-no-consing
(lambda () ,form
) ,times
))
423 (defun %assert-no-consing
(thunk &optional times
)
424 (let ((before (get-bytes-consed))
425 (times (or times
10000)))
426 (declare (type (integer 1 *) times
))
429 (assert (< (- (get-bytes-consed) before
) times
))))
431 (defmacro assert-consing
(form &optional times
)
432 `(%assert-consing
(lambda () ,form
) ,times
))
433 (defun %assert-consing
(thunk &optional times
)
434 (let ((before (get-bytes-consed))
435 (times (or times
10000)))
436 (declare (type (integer 1 *) times
))
439 (assert (not (< (- (get-bytes-consed) before
) times
)))))
441 (defvar *a-cons
* (cons nil nil
))
443 #+(or x86 x86-64 alpha ppc sparc mips
)
445 (assert-no-consing (dxclosure 42))
446 (assert-no-consing (dxlength 1 2 3))
447 (assert-no-consing (dxlength t t t t t t
))
448 (assert-no-consing (dxlength))
449 (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
450 (assert-no-consing (test-nip-values))
451 (assert-no-consing (test-let-var-subst1 17))
452 (assert-no-consing (test-let-var-subst2 17))
453 (assert-no-consing (test-lvar-subst 11))
454 (assert-no-consing (dx-value-cell 13))
455 (assert-no-consing (cons-on-stack 42))
456 (assert-no-consing (make-array-on-stack))
457 (assert-no-consing (make-foo1-on-stack 123))
458 (#+raw-instance-init-vops assert-no-consing
459 #-raw-instance-init-vops progn
460 (make-foo2-on-stack 1.24 1.23d0
))
461 (#+raw-instance-init-vops assert-no-consing
462 #-raw-instance-init-vops progn
463 (make-foo3-on-stack))
464 (assert-no-consing (nested-dx-conses))
465 (assert-no-consing (nested-dx-lists))
466 (assert-consing (nested-dx-not-used *a-cons
*))
467 (assert-no-consing (nested-evil-dx-used *a-cons
*))
468 (assert-no-consing (multiple-dx-uses))
469 (assert-no-consing (dx-handler-bind 2))
470 (assert-no-consing (dx-handler-case 2))
472 (assert-no-consing (test-hash-table))
475 (assert-no-consing (test-spinlock))
476 (assert-no-consing (test-mutex))))
479 ;;; Bugs found by Paul F. Dietz
486 (declare (optimize (speed 2) (space 0) (safety 0)
487 (debug 1) (compilation-speed 3)))
488 (let* ((v5 (cons b b
)))
489 (declare (dynamic-extent v5
))
497 ;;; bug reported by Svein Ove Aas
498 (defun svein-2005-ii-07 (x y
)
499 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
500 (let ((args (list* y
1 2 x
)))
501 (declare (dynamic-extent args
))
502 (apply #'aref args
)))
506 #3A
(((1 1 1) (1 1 1) (1 1 1))
507 ((1 1 1) (1 1 1) (4 1 1))
508 ((1 1 1) (1 1 1) (1 1 1))))
511 ;;; bug reported by Brian Downing: stack-allocated arrays were not
512 ;;; filled with zeroes.
513 (defun-with-dx bdowning-2005-iv-16
()
514 (let ((a (make-array 11 :initial-element
0)))
515 (declare (dynamic-extent a
))
516 (assert (every (lambda (x) (eql x
0)) a
))))
517 (assert-no-consing (bdowning-2005-iv-16))
520 (defun-with-dx let-converted-vars-dx-allocated-bug
(x y z
)
521 (let* ((a (list x y z
))
524 (declare (dynamic-extent c
))
525 (values (first c
) (second c
))))
526 (multiple-value-bind (i j
) (let-converted-vars-dx-allocated-bug 1 2 3)
527 (assert (and (equal i j
)
528 (equal i
(list 1 2 3)))))
530 ;;; workaround for bug 419 -- real issue remains, but check that the
532 (defun-with-dx bug419
(x)
533 (multiple-value-call #'list
534 (eval '(values 1 2 3))
536 (declare (dynamic-extent x
))
541 (declare (dynamic-extent #'mget
#'mset
))
542 ((lambda (f g
) (eval `(progn ,f
,g
(values 4 5 6)))) #'mget
#'mset
)))))
543 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
545 ;;; Multiple DX arguments in a local function call
546 (defun test-dx-flet-test (fun n f1 f2 f3
)
547 (let ((res (with-output-to-string (s)
548 (assert (eql n
(ignore-errors (funcall fun s
)))))))
549 (multiple-value-bind (x pos
) (read-from-string res nil
)
550 (assert (equalp f1 x
))
551 (multiple-value-bind (y pos2
) (read-from-string res nil nil
:start pos
)
552 (assert (equalp f2 y
))
553 (assert (equalp f3
(read-from-string res nil nil
:start pos2
))))))
554 (assert-no-consing (assert (eql n
(funcall fun nil
)))))
555 (macrolet ((def (n f1 f2 f3
)
556 (let ((name (sb-pcl::format-symbol
:cl-user
"DX-FLET-TEST.~A" n
)))
558 (defun-with-dx ,name
(s)
560 (declare (dynamic-extent x
))
569 (test-dx-flet-test #',name
,n
,f1
,f2
,f3
)))))
570 (def 0 (list :one
) (list :two
) (list :three
))
571 (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list
))
572 (def 2 (list 1) (list 2 3) (list 4 5 6 7)))
574 ;;; Test that unknown-values coming after a DX value won't mess up the stack analysis
575 (defun test-update-uvl-live-sets (x y z
)
576 (declare (optimize speed
(safety 0)))
578 (declare (dynamic-extent a
))
579 (eval `(list (length ',a
) ',b
))))
581 (bar (list x y z
) ; dx push
583 (multiple-value-call 'list
584 (eval '(values 1 2 3)) ; uv push
589 (assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))