X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdynamic-extent.impure.lisp;h=521e0a419b826e98dc0876aa734acccd28810308;hb=024389e7e3db268f535e36d883b4efc9d7ea0f65;hp=4c183bbc614736891e42fb719baa996c1e3e66cb;hpb=e840f481796d191997a47421d60cd039cd260613;p=sbcl.git diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 4c183bb..521e0a4 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -181,9 +181,6 @@ (true v) nil)) -;;; Unfortunately VECTOR-FILL* conses right now, so this one -;;; doesn't pass yet. -#+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)) @@ -506,42 +503,47 @@ (defvar *a-cons* (cons nil nil)) -#+(or x86 x86-64 alpha ppc sparc mips hppa) (progn + #+stack-allocatable-closures (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)) - (assert-no-consing (test-nip-values)) - (assert-no-consing (test-let-var-subst1 17)) - (assert-no-consing (test-let-var-subst2 17)) - (assert-no-consing (test-lvar-subst 11)) + #+stack-allocatable-lists + (progn + (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-subst1 17)) + (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))) (assert-no-consing (dx-value-cell 13)) - (assert-no-consing (cons-on-stack 42)) - (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)) - #+nil - (assert-no-consing (make-array-on-stack-5)) - (assert-no-consing (vector-on-stack :x :y)) - (assert-no-consing (make-foo1-on-stack 123)) - (assert-no-consing (nested-good 42)) + #+stack-allocatable-fixed-objects + (progn + (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 + (progn + (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 assert-no-consing #-raw-instance-init-vops progn (make-foo2-on-stack 1.24 1.23d0)) (#+raw-instance-init-vops assert-no-consing #-raw-instance-init-vops progn (make-foo3-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)) - (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 @@ -588,7 +590,10 @@ (let ((a (make-array 11 :initial-element 0))) (declare (dynamic-extent a)) (assert (every (lambda (x) (eql x 0)) a)))) -(assert-no-consing (bdowning-2005-iv-16)) +(with-test (:name :bdowning-2005-iv-16) + #+(or hppa mips x86 x86-64) + (assert-no-consing (bdowning-2005-iv-16)) + (bdowning-2005-iv-16)) (defun-with-dx let-converted-vars-dx-allocated-bug (x y z) (let* ((a (list x y z)) @@ -626,7 +631,9 @@ (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))))) + #+(or hppa mips x86 x86-64) + (assert-no-consing (assert (eql n (funcall fun nil)))) + (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 @@ -719,22 +726,72 @@ (serious-condition (c) (handle-loadtime-error c dest)))))))))) +(declaim (inline foovector barvector)) +(defun foovector (x y z) + (let ((v (make-array 3))) + (setf (aref v 0) x + (aref v 1) y + (aref v 2) z) + v)) +(defun barvector (x y z) + (make-array 3 :initial-contents (list x y z))) (with-test (:name :dx-compiler-notes) - (let ((n 0)) - (handler-bind ((compiler-note (lambda (c) - (declare (ignore cc)) - (incf n)))) - (compile nil `(lambda (x) - (let ((v (make-array x))) - (declare (dynamic-extent v)) - (length v)))) - (assert (= 1 n)) - (compile nil `(lambda (x) - (let ((y (if (plusp x) - (true x) - (true (- x))))) - (declare (dynamic-extent y)) - (print y) - nil))) - (assert (= 3 n))))) + (flet ((assert-notes (j lambda) + (let ((n 0)) + (handler-bind ((compiler-note (lambda (c) + (declare (ignore cc)) + (incf n)))) + (compile nil lambda) + (unless (= j n) + (error "Wanted ~S notes, got ~S for~% ~S" + j n lambda)))))) + ;; These ones should complain. + (assert-notes 1 `(lambda (x) + (let ((v (make-array x))) + (declare (dynamic-extent v)) + (length v)))) + (assert-notes 2 `(lambda (x) + (let ((y (if (plusp x) + (true x) + (true (- x))))) + (declare (dynamic-extent y)) + (print y) + nil))) + (assert-notes 1 `(lambda (x) + (let ((y (foovector x x x))) + (declare (sb-int:truly-dynamic-extent y)) + (print y) + nil))) + ;; These ones should not complain. + (assert-notes 0 `(lambda (name) + (with-alien + ((posix-getenv (function c-string c-string) + :EXTERN "getenv")) + (values + (alien-funcall posix-getenv name))))) + (assert-notes 0 `(lambda (x) + (let ((y (barvector x x x))) + (declare (dynamic-extent y)) + (print y) + nil))) + (assert-notes 0 `(lambda (list) + (declare (optimize (space 0))) + (sort list #'<))) + (assert-notes 0 `(lambda (other) + #'(lambda (s c n) + (ignore-errors (funcall other s c n))))))) + +;;; Stack allocating a value cell in HANDLER-CASE would blow up stack +;;; in an unfortunate loop. +(defun handler-case-eating-stack () + (let ((sp nil)) + (do ((n 0 (logand most-positive-fixnum (1+ n)))) + ((>= n 1024)) + (multiple-value-bind (value error) (ignore-errors) + (when (and value error) nil)) + (if sp + (assert (= sp (sb-c::%primitive sb-c:current-stack-pointer))) + (setf sp (sb-c::%primitive sb-c:current-stack-pointer)))))) +(with-test (:name :handler-case-eating-stack) + (assert-no-consing (handler-case-eating-stack)))