X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdynamic-extent.impure.lisp;h=0d1992d44bfa980a4e191afbc6d8bdd3b88fe243;hb=fd79e33e6b6dacdc52cf6668a5bb7adf75aad6c1;hp=aba5a18773894ededded95b84919c2cdd74f0874;hpb=1785d1e18c4fe5ede6c4b2a0b6893733c9139725;p=sbcl.git diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index aba5a18..0d1992d 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -147,12 +147,55 @@ ;;; MAKE-ARRAY -(defun-with-dx make-array-on-stack () +(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)) + +;;; 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)) + (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)) @@ -475,23 +518,36 @@ (assert-no-consing (test-let-var-subst2 17)) (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 (make-foo1-on-stack 123)) - (assert-no-consing (nested-good 42)) + ;; Only for platforms with DX FIXED-ALLOC + #+(or hppa mips x86 x86-64) + (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))) + ;; Only for platforms with DX ALLOCATE-VECTOR + #+(or hppa mips x86 x86-64) + (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)) + #+nil + (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 @@ -538,7 +594,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)) @@ -576,7 +635,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 @@ -646,4 +707,45 @@ (array-total-size array))) (with-test (:name :length-and-words-packed-in-same-tn) (assert (= 1 (length-and-words-packed-in-same-tn -3)))) + +(with-test (:name :handler-case-bogus-compiler-note) + (handler-bind ((compiler-note #'error)) + ;; Taken from SWANK, used to signal a bogus stack allocation + ;; failure note. + (compile nil + `(lambda (files fasl-dir load) + (let ((needs-recompile nil)) + (dolist (src files) + (let ((dest (binary-pathname src fasl-dir))) + (handler-case + (progn + (when (or needs-recompile + (not (probe-file dest)) + (file-newer-p src dest)) + (setq needs-recompile t) + (ensure-directories-exist dest) + (compile-file src :output-file dest :print nil :verbose t)) + (when load + (load dest :verbose t))) + (serious-condition (c) + (handle-loadtime-error c dest)))))))))) + +(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)))))