X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdynamic-extent.impure.lisp;h=7867bae61a559b3a7097ea23d0757602adb2b59a;hb=007bcd5aac2f3a1e714563bd39f7a2db2d0bf7c2;hp=10677accfb27ed2066a8e3abc455ffa1a2083246;hpb=96bb2dc76dddb1a21b3886fa7522796879e9ed9d;p=sbcl.git diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 10677ac..7867bae 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -14,13 +14,12 @@ (when (eq sb-ext:*evaluator-mode* :interpret) (sb-ext:quit :unix-status 104)) -(setq sb-c::*check-consistency* t) +(setq sb-c::*check-consistency* t + sb-ext:*stack-allocate-dynamic-extent* t) (defmacro defun-with-dx (name arglist &body body) - `(locally - (declare (optimize sb-c::stack-allocate-dynamic-extent)) - (defun ,name ,arglist - ,@body))) + `(defun ,name ,arglist + ,@body)) (declaim (notinline opaque-identity)) (defun opaque-identity (x) @@ -129,11 +128,10 @@ ;;; 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) + #+(or x86 x86-64 mips hppa) (let ((cell x)) - (declare (dynamic-extent cell)) + (declare (sb-int:truly-dynamic-extent cell)) (flet ((f () (incf cell))) (declare (dynamic-extent #'f)) @@ -372,6 +370,29 @@ (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 () @@ -382,7 +403,23 @@ (true dx) nil)) -;;; with-spinlock should use DX and not cons +;;; 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)) + (:no-error (res) + (1- res)))))) + +;;; with-spinlock and with-mutex should use DX and not cons (defvar *slock* (sb-thread::make-spinlock :name "slocklock")) @@ -390,6 +427,12 @@ (sb-thread::with-spinlock (*slock*) (true *slock*))) +(defvar *mutex* (sb-thread::make-mutex :name "mutexlock")) + +(defun test-mutex () + (sb-thread:with-mutex (*mutex*) + (true *mutex*))) + ;;; not really DX, but GETHASH and (SETF GETHASH) should not cons (defvar *table* (make-hash-table)) @@ -420,7 +463,7 @@ (defvar *a-cons* (cons nil nil)) -#+(or x86 x86-64 alpha ppc sparc mips) +#+(or x86 x86-64 alpha ppc sparc mips hppa) (progn (assert-no-consing (dxclosure 42)) (assert-no-consing (dxlength 1 2 3)) @@ -435,6 +478,7 @@ (assert-no-consing (cons-on-stack 42)) (assert-no-consing (make-array-on-stack)) (assert-no-consing (make-foo1-on-stack 123)) + (assert-no-consing (nested-good 42)) (#+raw-instance-init-vops assert-no-consing #-raw-instance-init-vops progn (make-foo2-on-stack 1.24 1.23d0)) @@ -446,10 +490,14 @@ (assert-consing (nested-dx-not-used *a-cons*)) (assert-no-consing (nested-evil-dx-used *a-cons*)) (assert-no-consing (multiple-dx-uses)) + (assert-no-consing (dx-handler-bind 2)) + (assert-no-consing (dx-handler-case 2)) ;; Not strictly DX.. (assert-no-consing (test-hash-table)) #+sb-thread - (assert-no-consing (test-spinlock))) + (progn + (assert-no-consing (test-spinlock)) + (assert-no-consing (test-mutex)))) ;;; Bugs found by Paul F. Dietz @@ -492,16 +540,17 @@ (assert (every (lambda (x) (eql x 0)) a)))) (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))))) + +(with-test (:name :let-converted-vars-dx-allocated-bug) + (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. @@ -517,4 +566,72 @@ (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))) + +;;; Multiple DX arguments in a local function call +(defun test-dx-flet-test (fun n f1 f2 f3) + (let ((res (with-output-to-string (s) + (assert (eql n (ignore-errors (funcall fun s))))))) + (multiple-value-bind (x pos) (read-from-string res nil) + (assert (equalp f1 x)) + (multiple-value-bind (y pos2) (read-from-string res nil nil :start pos) + (assert (equalp f2 y)) + (assert (equalp f3 (read-from-string res nil nil :start pos2)))))) + (assert-no-consing (assert (eql n (funcall fun nil))))) +(macrolet ((def (n f1 f2 f3) + (let ((name (sb-pcl::format-symbol :cl-user "DX-FLET-TEST.~A" n))) + `(progn + (defun-with-dx ,name (s) + (flet ((f (x) + (declare (dynamic-extent x)) + (when s + (print x s) + (finish-output s)) + nil)) + (f ,f1) + (f ,f2) + (f ,f3) + ,n)) + (test-dx-flet-test #',name ,n ,f1 ,f2 ,f3))))) + (def 0 (list :one) (list :two) (list :three)) + (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list)) + (def 2 (list 1) (list 2 3) (list 4 5 6 7))) + +;;; Test that unknown-values coming after a DX value won't mess up the stack analysis +(defun test-update-uvl-live-sets (x y z) + (declare (optimize speed (safety 0))) + (flet ((bar (a b) + (declare (dynamic-extent a)) + (eval `(list (length ',a) ',b)))) + (list (bar x y) + (bar (list x y z) ; dx push + (list + (multiple-value-call 'list + (eval '(values 1 2 3)) ; uv push + (max y z) + ) ; uv pop + 14) + )))) +(assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5))) + +(with-test (:name :regression-1.0.23.38) + (compile nil '(lambda () + (flet ((make (x y) + (let ((res (cons x x))) + (setf (cdr res) y) + res))) + (declaim (inline make)) + (let ((z (make 1 2))) + (declare (dynamic-extent z)) + (print z) + t)))) + (compile nil '(lambda () + (flet ((make (x y) + (let ((res (cons x x))) + (setf (cdr res) y) + (if x res y)))) + (declaim (inline make)) + (let ((z (make 1 2))) + (declare (dynamic-extent z)) + (print z) + t)))))