+(with-test (:name (:dx-&rest :pass-down-to-callee :tail-call))
+ (assert (= (dxcaller 1 2 3 4 5 6 7) 22)))
+
+(defun-with-dx dxcaller-align-1 (x &rest rest)
+ (declare (dynamic-extent rest))
+ (+ x (callee rest)))
+
+(with-test (:name (:dx-&rest :pass-down-to-callee :non-tail-call))
+ (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7) 39))
+ (assert (= (dxcaller-align-1 17 1 2 3 4 5 6 7 8) 40)))
+
+;;; %NIP-VALUES
+
+(defun-with-dx test-nip-values ()
+ (flet ((bar (x &rest y)
+ (declare (dynamic-extent y))
+ (if (> x 0)
+ (values x (length y))
+ (values (car y)))))
+ (multiple-value-call #'values
+ (bar 1 2 3 4 5 6)
+ (bar -1 'a 'b))))
+
+(with-test (:name (:nip-values))
+ (assert (equal (multiple-value-list (test-nip-values)) '(1 5 a))))
+
+;;; LET-variable substitution
+
+(defun-with-dx test-let-var-subst1 (x)
+ (let ((y (list x (1- x))))
+ (opaque-identity :foo)
+ (let ((z (the list y)))
+ (declare (dynamic-extent z))
+ (length z))))
+
+(with-test (:name (:let-variable-substitution))
+ (assert (eql (test-let-var-subst1 17) 2)))
+
+(defun-with-dx test-let-var-subst2 (x)
+ (let ((y (list x (1- x))))
+ (declare (dynamic-extent y))
+ (opaque-identity :foo)
+ (let ((z (the list y)))
+ (length z))))
+
+(with-test (:name (:let-variable-substitution-2))
+ (assert (eql (test-let-var-subst2 17) 2)))
+
+
+;;; DX propagation through LET-return.
+
+(defun-with-dx test-lvar-subst (x)
+ (let ((y (list x (1- x))))
+ (declare (dynamic-extent y))
+ (second (let ((z (the list y)))
+ (opaque-identity :foo)
+ z))))
+
+(with-test (:name (:dx-propagation-through-let-return))
+ (assert (eql (test-lvar-subst 11) 10)))
+
+;;; this code is incorrect, but the compiler should not fail
+(defun-with-dx test-let-var-subst-incorrect (x)
+ (let ((y (list x (1- x))))
+ (opaque-identity :foo)
+ (let ((z (the list y)))
+ (declare (dynamic-extent z))
+ (opaque-identity :bar)
+ z)))
+\f
+;;; alignment
+
+(defvar *x*)
+(defun-with-dx test-alignment-dx-list (form)
+ (multiple-value-prog1 (eval form)
+ (let ((l (list 1 2 3 4)))
+ (declare (dynamic-extent l))
+ (setq *x* (copy-list l)))))
+
+(with-test (:name (:dx-list :alignment))
+ (dotimes (n 64)
+ (let* ((res (loop for i below n collect i))
+ (form `(values ,@res)))
+ (assert (equal (multiple-value-list (test-alignment-dx-list form)) res))
+ (assert (equal *x* '(1 2 3 4))))))
+
+;;; closure
+
+(declaim (notinline true))
+(defun true (x)
+ (declare (ignore x))
+ t)
+
+(defun-with-dx dxclosure (x)
+ (flet ((f (y)
+ (+ y x)))
+ (declare (dynamic-extent #'f))
+ (true #'f)))
+
+(with-test (:name (:dx-closure))
+ (assert (eq t (dxclosure 13))))
+
+;;; value-cells
+
+(defun-with-dx dx-value-cell (x)
+ ;; Not implemented everywhere, yet.
+ #+(or x86 x86-64 mips hppa)
+ (let ((cell x))
+ (declare (sb-int:truly-dynamic-extent cell))
+ (flet ((f ()
+ (incf cell)))
+ (declare (dynamic-extent #'f))
+ (true #'f))))
+
+;;; CONS
+
+(defun-with-dx cons-on-stack (x)
+ (let ((cons (cons x x)))
+ (declare (dynamic-extent cons))
+ (true cons)
+ nil))
+
+;;; MAKE-ARRAY
+
+(defun force-make-array-on-stack (n)
+ (declare (optimize safety))
+ (let ((v (make-array (min n 1))))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-1 ()
+ (let ((v (make-array '(42) :element-type 'single-float)))
+ (declare (dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-2 (n x)
+ (declare (integer n))
+ (let ((v (make-array n :initial-contents x)))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-3 (x y z)
+ (let ((v (make-array 3
+ :element-type 'fixnum :initial-contents (list x y z)
+ :element-type t :initial-contents x)))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-4 ()
+ (let ((v (make-array 3 :initial-contents '(1 2 3))))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-5 ()
+ (let ((v (make-array 3 :initial-element 12 :element-type t)))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-6 ()
+ (let ((v (make-array 3 :initial-element 12 :element-type '(unsigned-byte 8))))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-7 ()
+ (let ((v (make-array 3 :initial-element 12 :element-type '(signed-byte 8))))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-8 ()
+ (let ((v (make-array 3 :initial-element 12 :element-type 'word)))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-9 ()
+ (let ((v (make-array 3 :initial-element 12.0 :element-type 'single-float)))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-10 ()
+ (let ((v (make-array 3 :initial-element 12.0d0 :element-type 'double-float)))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx make-array-on-stack-11 ()
+ (let ((v (make-array (the integer (opaque-identity 3)) :initial-element 12.0d0 :element-type 'double-float)))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ (true v)
+ nil))
+
+(defun-with-dx vector-on-stack (x y)
+ (let ((v (vector 1 x 2 y 3)))
+ (declare (sb-int:truly-dynamic-extent v))
+ (true v)
+ nil))
+
+;;; MAKE-STRUCTURE
+
+(declaim (inline make-fp-struct-1))
+(defstruct fp-struct-1
+ (s 0.0 :type single-float)
+ (d 0.0d0 :type double-float))
+
+(defun-with-dx test-fp-struct-1.1 (s d)
+ (let ((fp (make-fp-struct-1 :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql 0.0d0 (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.2 (s d)
+ (let ((fp (make-fp-struct-1 :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql 0.0 (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.3 (s d)
+ (let ((fp (make-fp-struct-1 :d d :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.4 (s d)
+ (let ((fp (make-fp-struct-1 :s s :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(with-test (:name (:test-fp-struct-1.1))
+ (test-fp-struct-1.1 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-1.2))
+ (test-fp-struct-1.2 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-1.3))
+ (test-fp-struct-1.3 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-1.4))
+ (test-fp-struct-1.4 123.456 876.243d0))
+
+(declaim (inline make-fp-struct-2))
+(defstruct fp-struct-2
+ (d 0.0d0 :type double-float)
+ (s 0.0 :type single-float))
+
+(defun-with-dx test-fp-struct-2.1 (s d)
+ (let ((fp (make-fp-struct-2 :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql 0.0d0 (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.2 (s d)
+ (let ((fp (make-fp-struct-2 :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql 0.0 (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.3 (s d)
+ (let ((fp (make-fp-struct-2 :d d :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.4 (s d)
+ (let ((fp (make-fp-struct-2 :s s :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(with-test (:name (:test-fp-struct-2.1))
+ (test-fp-struct-2.1 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-2.2))
+ (test-fp-struct-2.2 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-2.3))
+ (test-fp-struct-2.3 123.456 876.243d0))
+(with-test (:name (:test-fp-struct-2.4))
+ (test-fp-struct-2.4 123.456 876.243d0))
+
+(declaim (inline make-cfp-struct-1))
+(defstruct cfp-struct-1
+ (s (complex 0.0) :type (complex single-float))
+ (d (complex 0.0d0) :type (complex double-float)))
+
+(defun-with-dx test-cfp-struct-1.1 (s d)
+ (let ((cfp (make-cfp-struct-1 :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql (complex 0.0d0) (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.2 (s d)
+ (let ((cfp (make-cfp-struct-1 :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql (complex 0.0) (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.3 (s d)
+ (let ((cfp (make-cfp-struct-1 :d d :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.4 (s d)
+ (let ((cfp (make-cfp-struct-1 :s s :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(with-test (:name (:test-cfp-struct-1.1))
+ (test-cfp-struct-1.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-1.2))
+ (test-cfp-struct-1.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-1.3))
+ (test-cfp-struct-1.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-1.4))
+ (test-cfp-struct-1.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+
+(declaim (inline make-cfp-struct-2))
+(defstruct cfp-struct-2
+ (d (complex 0.0d0) :type (complex double-float))
+ (s (complex 0.0) :type (complex single-float)))
+
+(defun-with-dx test-cfp-struct-2.1 (s d)
+ (let ((cfp (make-cfp-struct-2 :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql (complex 0.0d0) (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.2 (s d)
+ (let ((cfp (make-cfp-struct-2 :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql (complex 0.0) (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.3 (s d)
+ (let ((cfp (make-cfp-struct-2 :d d :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.4 (s d)
+ (let ((cfp (make-cfp-struct-2 :s s :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(with-test (:name (:test-cfp-struct-2.1))
+ (test-cfp-struct-2.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-2.2))
+ (test-cfp-struct-2.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-2.3))
+ (test-cfp-struct-2.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+(with-test (:name (:test-cfp-struct-2.4))
+ (test-cfp-struct-2.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0)))
+
+(declaim (inline make-foo1 make-foo2 make-foo3))
+(defstruct foo1 x)
+
+(defun-with-dx make-foo1-on-stack (x)
+ (let ((foo (make-foo1 :x x)))
+ (declare (dynamic-extent foo))
+ (assert (eql x (foo1-x foo)))))
+
+(defstruct foo2
+ (x 0.0 :type single-float)
+ (y 0.0d0 :type double-float)
+ a
+ b
+ c)
+
+(defun-with-dx make-foo2-on-stack (x y)
+ (let ((foo (make-foo2 :y y :c 'c)))
+ (declare (dynamic-extent foo))
+ (assert (eql 0.0 (foo2-x foo)))
+ (assert (eql y (foo2-y foo)))
+ (assert (eql 'c (foo2-c foo)))
+ (assert (eql nil (foo2-b foo)))))
+
+;;; Check that constants work out as argument for all relevant
+;;; slot types.
+(defstruct foo3
+ (a 0 :type t)
+ (b 1 :type fixnum)
+ (c 2 :type sb-vm:word)
+ (d 3.0 :type single-float)
+ (e 4.0d0 :type double-float))
+
+(defun-with-dx make-foo3-on-stack ()
+ (let ((foo (make-foo3)))
+ (declare (dynamic-extent foo))
+ (assert (eql 0 (foo3-a foo)))
+ (assert (eql 1 (foo3-b foo)))
+ (assert (eql 2 (foo3-c foo)))
+ (assert (eql 3.0 (foo3-d foo)))
+ (assert (eql 4.0d0 (foo3-e foo)))))
+
+;;; Nested DX
+
+(defun-with-dx nested-dx-lists ()
+ (let ((dx (list (list 1 2) (list 3 4))))
+ (declare (dynamic-extent dx))
+ (true dx)
+ nil))
+
+(defun-with-dx nested-dx-conses ()
+ (let ((dx (cons 1 (cons 2 (cons 3 (cons (cons t t) nil))))))
+ (declare (dynamic-extent dx))
+ (true dx)
+ nil))
+
+(defun-with-dx nested-dx-not-used (x)
+ (declare (list x))
+ (let ((l (setf (car x) (list x x x))))
+ (declare (dynamic-extent l))
+ (true l)
+ (true (length l))
+ nil))
+
+(defun-with-dx nested-evil-dx-used (x)
+ (declare (list x))
+ (let ((l (list x x x)))
+ (declare (dynamic-extent l))
+ (unwind-protect
+ (progn
+ (setf (car x) l)
+ (true l))
+ (setf (car x) nil))
+ nil))
+
+(defparameter *bar* nil)
+(declaim (inline make-nested-bad make-nested-good))
+(defstruct (nested (:constructor make-nested-bad (&key bar &aux (bar (setf *bar* bar))))
+ (:constructor make-nested-good (&key bar)))
+ bar)
+
+(defun-with-dx nested-good (y)
+ (let ((x (list (list (make-nested-good :bar (list (list (make-nested-good :bar (list y)))))))))
+ (declare (dynamic-extent x))
+ (true x)))
+
+(defun-with-dx nested-bad (y)
+ (let ((x (list (list (make-nested-bad :bar (list (list (make-nested-bad :bar (list y)))))))))
+ (declare (dynamic-extent x))
+ (unless (equalp (caar x) (make-nested-good :bar *bar*))
+ (error "got ~S, wanted ~S" (caar x) (make-nested-good :bar *bar*)))
+ (caar x)))
+
+(with-test (:name :conservative-nested-dx)
+ ;; NESTED-BAD should not stack-allocate :BAR due to the SETF.
+ (assert (equalp (nested-bad 42) (make-nested-good :bar *bar*)))
+ (assert (equalp *bar* (list (list (make-nested-bad :bar (list 42)))))))
+
+;;; multiple uses for dx lvar
+
+(defun-with-dx multiple-dx-uses ()
+ (let ((dx (if (true t)
+ (list 1 2 3)
+ (list 2 3 4))))
+ (declare (dynamic-extent dx))
+ (true dx)
+ nil))
+
+;;; handler-case and handler-bind should use DX internally
+
+(defun dx-handler-bind (x)
+ (handler-bind ((error
+ #'(lambda (c)
+ (break "OOPS: ~S caused ~S" x c)))
+ ((and serious-condition (not error))
+ #'(lambda (c)
+ (break "OOPS2: ~S did ~S" x c))))
+ (/ 2 x)))
+
+(defun dx-handler-case (x)
+ (assert (zerop (handler-case (/ 2 x)
+ (error (c)
+ (break "OOPS: ~S caused ~S" x c)
+ -1)
+ (:no-error (res)
+ (1- res))))))
+
+(defvar *a-cons* (cons nil nil))
+
+(with-test (:name (:no-consing :dx-closures) :skipped-on '(not :stack-allocatable-closures))
+ (assert-no-consing (dxclosure 42)))
+
+(with-test (:name (:no-consing :dx-lists) :skipped-on '(not :stack-allocatable-lists))
+ (assert-no-consing (dxlength 1 2 3))
+ (assert-no-consing (dxlength t t t t t t))
+ (assert-no-consing (dxlength))
+ (assert-no-consing (dxcaller 1 2 3 4 5 6 7))
+ (assert-no-consing (test-nip-values))
+ (assert-no-consing (test-let-var-subst2 17))
+ (assert-no-consing (test-lvar-subst 11))
+ (assert-no-consing (nested-dx-lists))
+ (assert-consing (nested-dx-not-used *a-cons*))
+ (assert-no-consing (nested-evil-dx-used *a-cons*))
+ (assert-no-consing (multiple-dx-uses)))
+
+(with-test (:name (:no-consing :dx-value-cell))
+ (assert-no-consing (dx-value-cell 13)))
+
+(with-test (:name (:no-consing :dx-fixed-objects) :skipped-on '(not :stack-allocatable-fixed-objects))
+ (assert-no-consing (cons-on-stack 42))
+ (assert-no-consing (make-foo1-on-stack 123))
+ (assert-no-consing (nested-good 42))
+ (assert-no-consing (nested-dx-conses))
+ (assert-no-consing (dx-handler-bind 2))
+ (assert-no-consing (dx-handler-case 2)))
+
+(with-test (:name (:no-consing :dx-vectors) :skipped-on '(not :stack-allocatable-vectors))
+ (assert-no-consing (force-make-array-on-stack 128))
+ (assert-no-consing (make-array-on-stack-1))
+ (assert-no-consing (make-array-on-stack-2 5 '(1 2.0 3 4.0 5)))
+ (assert-no-consing (make-array-on-stack-3 9 8 7))
+ (assert-no-consing (make-array-on-stack-4))
+ (assert-no-consing (make-array-on-stack-5))
+ (assert-no-consing (vector-on-stack :x :y)))
+
+(with-test (:name (:no-consing :specialized-dx-vectors)
+ :fails-on :x86
+ :skipped-on `(not (and :stack-allocatable-vectors
+ :c-stack-is-control-stack)))
+ (assert-no-consing (make-array-on-stack-6))
+ (assert-no-consing (make-array-on-stack-7))
+ (assert-no-consing (make-array-on-stack-8))
+ (assert-no-consing (make-array-on-stack-9))
+ (assert-no-consing (make-array-on-stack-10))
+ (assert-no-consing (make-array-on-stack-11)))
+
+(with-test (:name (:no-consing :dx-raw-instances) :skipped-on '(or (not :raw-instance-init-vops)
+ (not (and :gencgc :c-stack-is-control-stack))))
+ (let (a b)
+ (setf a 1.24 b 1.23d0)
+ (assert-no-consing (make-foo2-on-stack a b)))
+ (assert-no-consing (make-foo3-on-stack)))
+
+;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
+
+(defvar *table* (make-hash-table))
+
+(defun test-hash-table ()
+ (setf (gethash 5 *table*) 13)
+ (gethash 5 *table*))
+
+;; This fails on threaded PPC because the hash-table implementation
+;; uses recursive system locks, which cons (see below for test
+;; (:no-consing :lock), which also fails on threaded PPC).
+;;
+;; -- That may have been the situation in 2010 when the above comment
+;; was written, but AFAICT now, hash tables use WITH-PINNED-OBJECTS,
+;; which conses on PPC and SPARC when GENCGC is enabled. So neither is
+;; this actually about threading, nor about PPC. Yet since we are
+;; failing most of this file on SPARC anyway (for some tests even on
+;; cheneygc), I won't bother to mark this particular test as failing.
+;; It would be nice if someone could go through this file and figure it
+;; all out... --DFL
+(with-test (:name (:no-consing :hash-tables) :fails-on '(and :ppc :sb-thread))
+ (assert-no-consing (test-hash-table)))
+
+;;; with-mutex should use DX and not cons
+
+(defvar *mutex* (sb-thread::make-mutex :name "mutexlock"))
+
+(defun test-mutex ()
+ (sb-thread:with-mutex (*mutex*)
+ (true *mutex*)))
+
+(with-test (:name (:no-consing :mutex) :fails-on :ppc :skipped-on '(not :sb-thread))
+ (assert-no-consing (test-mutex)))