;;; value-cells
(defun-with-dx dx-value-cell (x)
+ (declare (optimize sb-c::stack-allocate-value-cells))
;; Not implemented everywhere, yet.
#+(or x86 x86-64 mips)
(let ((cell x))
(true cons)
nil))
+;;; MAKE-ARRAY
+
+(defun-with-dx make-array-on-stack ()
+ (let ((v (make-array '(42) :element-type 'single-float)))
+ (declare (dynamic-extent v))
+ (true v)
+ nil))
+
;;; Nested DX
(defun-with-dx nested-dx-lists ()
(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))
+
+;;; 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))
+
;;; with-spinlock should use DX and not cons
(defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
(funcall thunk))
(assert (< (- (get-bytes-consed) before) times))))
+(defmacro assert-consing (form &optional times)
+ `(%assert-consing (lambda () ,form) ,times))
+(defun %assert-consing (thunk &optional times)
+ (let ((before (get-bytes-consed))
+ (times (or times 10000)))
+ (declare (type (integer 1 *) times))
+ (dotimes (i times)
+ (funcall thunk))
+ (assert (not (< (- (get-bytes-consed) before) times)))))
+
+(defvar *a-cons* (cons nil nil))
+
#+(or x86 x86-64 alpha ppc sparc mips)
(progn
(assert-no-consing (dxclosure 42))
(assert-no-consing (test-lvar-subst 11))
(assert-no-consing (dx-value-cell 13))
(assert-no-consing (cons-on-stack 42))
+ (assert-no-consing (make-array-on-stack))
(assert-no-consing (nested-dx-conses))
(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))
;; Not strictly DX..
(assert-no-consing (test-hash-table))
#+sb-thread
(let ((a (make-array 11 :initial-element 0)))
(declare (dynamic-extent a))
(assert (every (lambda (x) (eql x 0)) a))))
-(bdowning-2005-iv-16)
-
+(assert-no-consing (bdowning-2005-iv-16))
+
+
+(defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
+ (let* ((a (list x y z))
+ (b (list x y z))
+ (c (list a b)))
+ (declare (dynamic-extent c))
+ (values (first c) (second c))))
+(multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
+ (assert (and (equal i j)
+ (equal i (list 1 2 3)))))
+
+;;; workaround for bug 419 -- real issue remains, but check that the
+;;; bandaid holds.
+(defun-with-dx bug419 (x)
+ (multiple-value-call #'list
+ (eval '(values 1 2 3))
+ (let ((x x))
+ (declare (dynamic-extent x))
+ (flet ((mget (y)
+ (+ x y))
+ (mset (z)
+ (incf x z)))
+ (declare (dynamic-extent #'mget #'mset))
+ ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
+(assert (equal (bug419 42) '(1 2 3 4 5 6)))
\f