+;;; 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)
+ nil))
+
+(defun-with-dx make-array-on-stack-1 ()
+ (let ((v (make-array '(42) :element-type 'single-float)))
+ (declare (dynamic-extent 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)
+ 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)
+ 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)
+ 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)
+ 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))
+
+#+stack-allocatable-closures
+(with-test (:name (:no-consing :dx-closures))
+ (assert-no-consing (dxclosure 42)))
+
+#+stack-allocatable-lists
+(with-test (:name (:no-consing :dx-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)))
+
+#+stack-allocatable-fixed-objects
+(with-test (:name (:no-consing :dx-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)))
+
+#+stack-allocatable-vectors
+(with-test (:name (:no-consing :dx-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)))
+
+#+raw-instance-init-vops
+(with-test (:name (:no-consing :dx-raw-instances))
+ (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*))
+
+(with-test (:name (:no-consing :hash-tables))
+ (assert-no-consing (test-hash-table)))
+
+;;; with-spinlock and with-mutex should use DX and not cons