X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdynamic-extent.impure.lisp;h=e27f5aeb2f6b5a340fa9c6d2b3867bc9835df8a4;hb=23a229276c2447a658b7a30217ec774067c27d5e;hp=3c0d247bdcf5d6509ff074760ed58e615f3bf4e7;hpb=08b0e98910af7154f2afe68f2f16618754f74461;p=sbcl.git diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 3c0d247..e27f5ae 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -6,11 +6,14 @@ ;;;; While most of SBCL is derived from the CMU CL system, the test ;;;; files (like this one) were written from scratch after the fork ;;;; from CMU CL. -;;;; +;;;; ;;;; This software is in the public domain and is provided with ;;;; absolutely no warranty. See the COPYING and CREDITS files for ;;;; more information. +(when (eq sb-ext:*evaluator-mode* :interpret) + (sb-ext:quit :unix-status 104)) + (setq sb-c::*check-consistency* t) (defmacro defun-with-dx (name arglist &body body) @@ -108,11 +111,111 @@ (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))) + +(assert (eq t (dxclosure 13))) + +;;; 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)) + (declare (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-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 () + (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)) +;;; 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")) + +(defun test-spinlock () + (sb-thread::with-spinlock (*slock*) + (true *slock*))) + +;;; 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*)) (defmacro assert-no-consing (form &optional times) - `(%assert-no-consing (lambda () ,form ,times))) + `(%assert-no-consing (lambda () ,form) ,times)) (defun %assert-no-consing (thunk &optional times) (let ((before (get-bytes-consed)) (times (or times 10000))) @@ -121,20 +224,41 @@ (funcall thunk)) (assert (< (- (get-bytes-consed) before) times)))) -#+(or x86 x86-64 alpha ppc) +(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 (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)) - #-ppc (assert-no-consing (test-nip-values)) - #-ppc (assert-no-consing (test-let-var-subst1 17)) - #-ppc (assert-no-consing (test-let-var-subst2 17)) - #-ppc - (assert-no-consing (test-lvar-subst 11))) + (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 + (assert-no-consing (test-spinlock))) ;;; Bugs found by Paul F. Dietz @@ -175,7 +299,31 @@ (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))) -(sb-ext:quit :unix-status 104)