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-with-dx make-array-on-stack ()
151 (let ((v (make-array '(42) :element-type 'single-float)))
152 (declare (dynamic-extent v))
156 (defun force-make-array-on-stack (n)
157 (declare (optimize safety))
158 (let ((v (make-array (min n 1))))
159 (declare (sb-int:truly-dynamic-extent v))
165 (declaim (inline make-fp-struct-1))
166 (defstruct fp-struct-1
167 (s 0.0 :type single-float)
168 (d 0.0d0 :type double-float))
170 (defun-with-dx test-fp-struct-1.1 (s d)
171 (let ((fp (make-fp-struct-1 :s s)))
172 (declare (dynamic-extent fp))
173 (assert (eql s (fp-struct-1-s fp)))
174 (assert (eql 0.0d0 (fp-struct-1-d fp)))))
176 (defun-with-dx test-fp-struct-1.2 (s d)
177 (let ((fp (make-fp-struct-1 :d d)))
178 (declare (dynamic-extent fp))
179 (assert (eql 0.0 (fp-struct-1-s fp)))
180 (assert (eql d (fp-struct-1-d fp)))))
182 (defun-with-dx test-fp-struct-1.3 (s d)
183 (let ((fp (make-fp-struct-1 :d d :s s)))
184 (declare (dynamic-extent fp))
185 (assert (eql s (fp-struct-1-s fp)))
186 (assert (eql d (fp-struct-1-d fp)))))
188 (defun-with-dx test-fp-struct-1.4 (s d)
189 (let ((fp (make-fp-struct-1 :s s :d d)))
190 (declare (dynamic-extent fp))
191 (assert (eql s (fp-struct-1-s fp)))
192 (assert (eql d (fp-struct-1-d fp)))))
194 (test-fp-struct-1.1 123.456 876.243d0)
195 (test-fp-struct-1.2 123.456 876.243d0)
196 (test-fp-struct-1.3 123.456 876.243d0)
197 (test-fp-struct-1.4 123.456 876.243d0)
199 (declaim (inline make-fp-struct-2))
200 (defstruct fp-struct-2
201 (d 0.0d0 :type double-float)
202 (s 0.0 :type single-float))
204 (defun-with-dx test-fp-struct-2.1 (s d)
205 (let ((fp (make-fp-struct-2 :s s)))
206 (declare (dynamic-extent fp))
207 (assert (eql s (fp-struct-2-s fp)))
208 (assert (eql 0.0d0 (fp-struct-2-d fp)))))
210 (defun-with-dx test-fp-struct-2.2 (s d)
211 (let ((fp (make-fp-struct-2 :d d)))
212 (declare (dynamic-extent fp))
213 (assert (eql 0.0 (fp-struct-2-s fp)))
214 (assert (eql d (fp-struct-2-d fp)))))
216 (defun-with-dx test-fp-struct-2.3 (s d)
217 (let ((fp (make-fp-struct-2 :d d :s s)))
218 (declare (dynamic-extent fp))
219 (assert (eql s (fp-struct-2-s fp)))
220 (assert (eql d (fp-struct-2-d fp)))))
222 (defun-with-dx test-fp-struct-2.4 (s d)
223 (let ((fp (make-fp-struct-2 :s s :d d)))
224 (declare (dynamic-extent fp))
225 (assert (eql s (fp-struct-2-s fp)))
226 (assert (eql d (fp-struct-2-d fp)))))
228 (test-fp-struct-2.1 123.456 876.243d0)
229 (test-fp-struct-2.2 123.456 876.243d0)
230 (test-fp-struct-2.3 123.456 876.243d0)
231 (test-fp-struct-2.4 123.456 876.243d0)
233 (declaim (inline make-cfp-struct-1))
234 (defstruct cfp-struct-1
235 (s (complex 0.0) :type (complex single-float))
236 (d (complex 0.0d0) :type (complex double-float)))
238 (defun-with-dx test-cfp-struct-1.1 (s d)
239 (let ((cfp (make-cfp-struct-1 :s s)))
240 (declare (dynamic-extent cfp))
241 (assert (eql s (cfp-struct-1-s cfp)))
242 (assert (eql (complex 0.0d0) (cfp-struct-1-d cfp)))))
244 (defun-with-dx test-cfp-struct-1.2 (s d)
245 (let ((cfp (make-cfp-struct-1 :d d)))
246 (declare (dynamic-extent cfp))
247 (assert (eql (complex 0.0) (cfp-struct-1-s cfp)))
248 (assert (eql d (cfp-struct-1-d cfp)))))
250 (defun-with-dx test-cfp-struct-1.3 (s d)
251 (let ((cfp (make-cfp-struct-1 :d d :s s)))
252 (declare (dynamic-extent cfp))
253 (assert (eql s (cfp-struct-1-s cfp)))
254 (assert (eql d (cfp-struct-1-d cfp)))))
256 (defun-with-dx test-cfp-struct-1.4 (s d)
257 (let ((cfp (make-cfp-struct-1 :s s :d d)))
258 (declare (dynamic-extent cfp))
259 (assert (eql s (cfp-struct-1-s cfp)))
260 (assert (eql d (cfp-struct-1-d cfp)))))
262 (test-cfp-struct-1.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
263 (test-cfp-struct-1.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
264 (test-cfp-struct-1.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
265 (test-cfp-struct-1.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
267 (declaim (inline make-cfp-struct-2))
268 (defstruct cfp-struct-2
269 (d (complex 0.0d0) :type (complex double-float))
270 (s (complex 0.0) :type (complex single-float)))
272 (defun-with-dx test-cfp-struct-2.1 (s d)
273 (let ((cfp (make-cfp-struct-2 :s s)))
274 (declare (dynamic-extent cfp))
275 (assert (eql s (cfp-struct-2-s cfp)))
276 (assert (eql (complex 0.0d0) (cfp-struct-2-d cfp)))))
278 (defun-with-dx test-cfp-struct-2.2 (s d)
279 (let ((cfp (make-cfp-struct-2 :d d)))
280 (declare (dynamic-extent cfp))
281 (assert (eql (complex 0.0) (cfp-struct-2-s cfp)))
282 (assert (eql d (cfp-struct-2-d cfp)))))
284 (defun-with-dx test-cfp-struct-2.3 (s d)
285 (let ((cfp (make-cfp-struct-2 :d d :s s)))
286 (declare (dynamic-extent cfp))
287 (assert (eql s (cfp-struct-2-s cfp)))
288 (assert (eql d (cfp-struct-2-d cfp)))))
290 (defun-with-dx test-cfp-struct-2.4 (s d)
291 (let ((cfp (make-cfp-struct-2 :s s :d d)))
292 (declare (dynamic-extent cfp))
293 (assert (eql s (cfp-struct-2-s cfp)))
294 (assert (eql d (cfp-struct-2-d cfp)))))
296 (test-cfp-struct-2.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
297 (test-cfp-struct-2.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
298 (test-cfp-struct-2.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
299 (test-cfp-struct-2.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
301 (declaim (inline make-foo1 make-foo2 make-foo3))
304 (defun-with-dx make-foo1-on-stack (x)
305 (let ((foo (make-foo1 :x x)))
306 (declare (dynamic-extent foo))
307 (assert (eql x (foo1-x foo)))))
310 (x 0.0 :type single-float)
311 (y 0.0d0 :type double-float)
316 (defmacro assert-eql (expected got)
317 `(let ((exp ,expected)
319 (unless (eql exp got)
320 (error "Expected ~S, got ~S!" exp got))))
322 (defun-with-dx make-foo2-on-stack (x y)
323 (let ((foo (make-foo2 :y y :c 'c)))
324 (declare (dynamic-extent foo))
325 (assert-eql 0.0 (foo2-x foo))
326 (assert-eql y (foo2-y foo))
327 (assert-eql 'c (foo2-c foo))
328 (assert-eql nil (foo2-b foo))))
330 ;;; Check that constants work out as argument for all relevant
335 (c 2 :type sb-vm:word)
336 (d 3.0 :type single-float)
337 (e 4.0d0 :type double-float))
338 (defun-with-dx make-foo3-on-stack ()
339 (let ((foo (make-foo3)))
340 (declare (dynamic-extent foo))
341 (assert (eql 0 (foo3-a foo)))
342 (assert (eql 1 (foo3-b foo)))
343 (assert (eql 2 (foo3-c foo)))
344 (assert (eql 3.0 (foo3-d foo)))
345 (assert (eql 4.0d0 (foo3-e foo)))))
349 (defun-with-dx nested-dx-lists ()
350 (let ((dx (list (list 1 2) (list 3 4))))
351 (declare (dynamic-extent dx))
355 (defun-with-dx nested-dx-conses ()
356 (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
357 (declare (dynamic-extent dx))
361 (defun-with-dx nested-dx-not-used (x)
363 (let ((l (setf (car x) (list x x x))))
364 (declare (dynamic-extent l))
369 (defun-with-dx nested-evil-dx-used (x)
371 (let ((l (list x x x)))
372 (declare (dynamic-extent l))
380 (defparameter *bar* nil)
381 (declaim (inline make-nested-bad make-nested-good))
382 (defstruct (nested (:constructor make-nested-bad (&key bar &aux (bar (setf *bar* bar))))
383 (:constructor make-nested-good (&key bar)))
386 (defun-with-dx nested-good (y)
387 (let ((x (list (list (make-nested-good :bar (list (list (make-nested-good :bar (list y)))))))))
388 (declare (dynamic-extent x))
391 (defun-with-dx nested-bad (y)
392 (let ((x (list (list (make-nested-bad :bar (list (list (make-nested-bad :bar (list y)))))))))
393 (declare (dynamic-extent x))
394 (unless (equalp (caar x) (make-nested-good :bar *bar*))
395 (error "got ~S, wanted ~S" (caar x) (make-nested-good :bar *bar*)))
398 (with-test (:name :conservative-nested-dx)
399 ;; NESTED-BAD should not stack-allocate :BAR due to the SETF.
400 (assert (equalp (nested-bad 42) (make-nested-good :bar *bar*)))
401 (assert (equalp *bar* (list (list (make-nested-bad :bar (list 42)))))))
403 ;;; multiple uses for dx lvar
405 (defun-with-dx multiple-dx-uses ()
406 (let ((dx (if (true t)
409 (declare (dynamic-extent dx))
413 ;;; handler-case and handler-bind should use DX internally
415 (defun dx-handler-bind (x)
416 (handler-bind ((error
417 (lambda (c) (break "OOPS: ~S caused ~S" x c)))
418 ((and serious-condition (not error))
419 #'(lambda (c) (break "OOPS2: ~S did ~S" x c))))
422 (defun dx-handler-case (x)
423 (assert (zerop (handler-case (/ 2 x)
425 (break "OOPS: ~S caused ~S" x c))
429 ;;; with-spinlock and with-mutex should use DX and not cons
431 (defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
433 (defun test-spinlock ()
434 (sb-thread::with-spinlock (*slock*)
437 (defvar *mutex* (sb-thread::make-mutex :name "mutexlock"))
440 (sb-thread:with-mutex (*mutex*)
443 ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
445 (defvar *table* (make-hash-table))
447 (defun test-hash-table ()
448 (setf (gethash 5 *table*) 13)
451 (defmacro assert-no-consing (form &optional times)
452 `(%assert-no-consing (lambda () ,form) ,times))
453 (defun %assert-no-consing (thunk &optional times)
454 (let ((before (get-bytes-consed))
455 (times (or times 10000)))
456 (declare (type (integer 1 *) times))
459 (assert (< (- (get-bytes-consed) before) times))))
461 (defmacro assert-consing (form &optional times)
462 `(%assert-consing (lambda () ,form) ,times))
463 (defun %assert-consing (thunk &optional times)
464 (let ((before (get-bytes-consed))
465 (times (or times 10000)))
466 (declare (type (integer 1 *) times))
469 (assert (not (< (- (get-bytes-consed) before) times)))))
471 (defvar *a-cons* (cons nil nil))
473 #+(or x86 x86-64 alpha ppc sparc mips hppa)
475 (assert-no-consing (dxclosure 42))
476 (assert-no-consing (dxlength 1 2 3))
477 (assert-no-consing (dxlength t t t t t t))
478 (assert-no-consing (dxlength))
479 (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
480 (assert-no-consing (test-nip-values))
481 (assert-no-consing (test-let-var-subst1 17))
482 (assert-no-consing (test-let-var-subst2 17))
483 (assert-no-consing (test-lvar-subst 11))
484 (assert-no-consing (dx-value-cell 13))
485 (assert-no-consing (cons-on-stack 42))
486 (assert-no-consing (make-array-on-stack))
487 (assert-no-consing (force-make-array-on-stack 128))
488 (assert-no-consing (make-foo1-on-stack 123))
489 (assert-no-consing (nested-good 42))
490 (#+raw-instance-init-vops assert-no-consing
491 #-raw-instance-init-vops progn
492 (make-foo2-on-stack 1.24 1.23d0))
493 (#+raw-instance-init-vops assert-no-consing
494 #-raw-instance-init-vops progn
495 (make-foo3-on-stack))
496 (assert-no-consing (nested-dx-conses))
497 (assert-no-consing (nested-dx-lists))
498 (assert-consing (nested-dx-not-used *a-cons*))
499 (assert-no-consing (nested-evil-dx-used *a-cons*))
500 (assert-no-consing (multiple-dx-uses))
501 (assert-no-consing (dx-handler-bind 2))
502 (assert-no-consing (dx-handler-case 2))
504 (assert-no-consing (test-hash-table))
507 (assert-no-consing (test-spinlock))
508 (assert-no-consing (test-mutex))))
511 ;;; Bugs found by Paul F. Dietz
518 (declare (optimize (speed 2) (space 0) (safety 0)
519 (debug 1) (compilation-speed 3)))
520 (let* ((v5 (cons b b)))
521 (declare (dynamic-extent v5))
529 ;;; bug reported by Svein Ove Aas
530 (defun svein-2005-ii-07 (x y)
531 (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
532 (let ((args (list* y 1 2 x)))
533 (declare (dynamic-extent args))
534 (apply #'aref args)))
538 #3A(((1 1 1) (1 1 1) (1 1 1))
539 ((1 1 1) (1 1 1) (4 1 1))
540 ((1 1 1) (1 1 1) (1 1 1))))
543 ;;; bug reported by Brian Downing: stack-allocated arrays were not
544 ;;; filled with zeroes.
545 (defun-with-dx bdowning-2005-iv-16 ()
546 (let ((a (make-array 11 :initial-element 0)))
547 (declare (dynamic-extent a))
548 (assert (every (lambda (x) (eql x 0)) a))))
549 (assert-no-consing (bdowning-2005-iv-16))
551 (defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
552 (let* ((a (list x y z))
555 (declare (dynamic-extent c))
556 (values (first c) (second c))))
558 (with-test (:name :let-converted-vars-dx-allocated-bug)
559 (multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
560 (assert (and (equal i j)
561 (equal i (list 1 2 3))))))
563 ;;; workaround for bug 419 -- real issue remains, but check that the
565 (defun-with-dx bug419 (x)
566 (multiple-value-call #'list
567 (eval '(values 1 2 3))
569 (declare (dynamic-extent x))
574 (declare (dynamic-extent #'mget #'mset))
575 ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
576 (assert (equal (bug419 42) '(1 2 3 4 5 6)))
578 ;;; Multiple DX arguments in a local function call
579 (defun test-dx-flet-test (fun n f1 f2 f3)
580 (let ((res (with-output-to-string (s)
581 (assert (eql n (ignore-errors (funcall fun s)))))))
582 (multiple-value-bind (x pos) (read-from-string res nil)
583 (assert (equalp f1 x))
584 (multiple-value-bind (y pos2) (read-from-string res nil nil :start pos)
585 (assert (equalp f2 y))
586 (assert (equalp f3 (read-from-string res nil nil :start pos2))))))
587 (assert-no-consing (assert (eql n (funcall fun nil)))))
588 (macrolet ((def (n f1 f2 f3)
589 (let ((name (sb-pcl::format-symbol :cl-user "DX-FLET-TEST.~A" n)))
591 (defun-with-dx ,name (s)
593 (declare (dynamic-extent x))
602 (test-dx-flet-test #',name ,n ,f1 ,f2 ,f3)))))
603 (def 0 (list :one) (list :two) (list :three))
604 (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list))
605 (def 2 (list 1) (list 2 3) (list 4 5 6 7)))
607 ;;; Test that unknown-values coming after a DX value won't mess up the stack analysis
608 (defun test-update-uvl-live-sets (x y z)
609 (declare (optimize speed (safety 0)))
611 (declare (dynamic-extent a))
612 (eval `(list (length ',a) ',b))))
614 (bar (list x y z) ; dx push
616 (multiple-value-call 'list
617 (eval '(values 1 2 3)) ; uv push
622 (assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))
624 (with-test (:name :regression-1.0.23.38)
625 (compile nil '(lambda ()
627 (let ((res (cons x x)))
630 (declaim (inline make))
631 (let ((z (make 1 2)))
632 (declare (dynamic-extent z))
635 (compile nil '(lambda ()
637 (let ((res (cons x x)))
640 (declaim (inline make))
641 (let ((z (make 1 2)))
642 (declare (dynamic-extent z))
646 ;;; On x86 and x86-64 upto 1.0.28.16 LENGTH and WORDS argument
647 ;;; tns to ALLOCATE-VECTOR-ON-STACK could be packed in the same
648 ;;; location, leading to all manner of badness. ...reproducing this
649 ;;; reliably is hard, but this it at least used to break on x86-64.
650 (defun length-and-words-packed-in-same-tn (m)
651 (declare (optimize speed (safety 0) (debug 0) (space 0)))
652 (let ((array (make-array (max 1 m) :element-type 'fixnum)))
653 (declare (dynamic-extent array))
654 (array-total-size array)))
655 (with-test (:name :length-and-words-packed-in-same-tn)
656 (assert (= 1 (length-and-words-packed-in-same-tn -3))))
658 (with-test (:name :handler-case-bogus-compiler-note)
659 (handler-bind ((compiler-note #'error))
660 ;; Taken from SWANK, used to signal a bogus stack allocation
663 `(lambda (files fasl-dir load)
664 (let ((needs-recompile nil))
666 (let ((dest (binary-pathname src fasl-dir)))
669 (when (or needs-recompile
670 (not (probe-file dest))
671 (file-newer-p src dest))
672 (setq needs-recompile t)
673 (ensure-directories-exist dest)
674 (compile-file src :output-file dest :print nil :verbose t))
676 (load dest :verbose t)))
677 (serious-condition (c)
678 (handle-loadtime-error c dest))))))))))
680 (with-test (:name :dx-compiler-notes)
682 (handler-bind ((compiler-note (lambda (c)
683 (declare (ignore cc))
685 (compile nil `(lambda (x)
686 (let ((v (make-array x)))
687 (declare (dynamic-extent v))
690 (compile nil `(lambda (x)
691 (let ((y (if (plusp x)
694 (declare (dynamic-extent y))