X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=tests%2Fdynamic-extent.impure.lisp;h=5111404907d01ff0601542af8ab249f74f08c0e7;hb=5cb51577bd59c36822e90fb814564bb7d59ee37e;hp=16aa5e94403273e5d3052667dec1b9f60fc955f6;hpb=e8011f7c83587a9dc1b13281d0cc974bb0b054be;p=sbcl.git diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp index 16aa5e9..5111404 100644 --- a/tests/dynamic-extent.impure.lisp +++ b/tests/dynamic-extent.impure.lisp @@ -12,7 +12,7 @@ ;;;; more information. (when (eq sb-ext:*evaluator-mode* :interpret) - (sb-ext:quit :unix-status 104)) + (sb-ext:exit :code 104)) (load "compiler-test-util.lisp") (use-package :ctu) @@ -21,8 +21,17 @@ sb-ext:*stack-allocate-dynamic-extent* t) (defmacro defun-with-dx (name arglist &body body) - `(defun ,name ,arglist - ,@body)) + (let ((debug-name (sb-int:symbolicate name "-HIGH-DEBUG")) + (default-name (sb-int:symbolicate name "-DEFAULT"))) + `(progn + (defun ,debug-name ,arglist + (declare (optimize debug)) + ,@body) + (defun ,default-name ,arglist + ,@body) + (defun ,name (&rest args) + (apply #',debug-name args) + (apply #',default-name args))))) (declaim (notinline opaque-identity)) (defun opaque-identity (x) @@ -176,12 +185,14 @@ (let ((v (make-array (min n 1)))) (declare (sb-int:truly-dynamic-extent v)) (true 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) + (true v) nil)) (defun-with-dx make-array-on-stack-2 (n x) @@ -189,6 +200,7 @@ (let ((v (make-array n :initial-contents x))) (declare (sb-int:truly-dynamic-extent v)) (true v) + (true v) nil)) (defun-with-dx make-array-on-stack-3 (x y z) @@ -197,18 +209,63 @@ :element-type t :initial-contents x))) (declare (sb-int:truly-dynamic-extent v)) (true 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) + (true v) 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) + (true v) + nil)) + +(defun-with-dx make-array-on-stack-6 () + (let ((v (make-array 3 :initial-element 12 :element-type '(unsigned-byte 8)))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + (true v) + nil)) + +(defun-with-dx make-array-on-stack-7 () + (let ((v (make-array 3 :initial-element 12 :element-type '(signed-byte 8)))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + (true v) + nil)) + +(defun-with-dx make-array-on-stack-8 () + (let ((v (make-array 3 :initial-element 12 :element-type 'word))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + (true v) + nil)) + +(defun-with-dx make-array-on-stack-9 () + (let ((v (make-array 3 :initial-element 12.0 :element-type 'single-float))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + (true v) + nil)) + +(defun-with-dx make-array-on-stack-10 () + (let ((v (make-array 3 :initial-element 12.0d0 :element-type 'double-float))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + (true v) + nil)) + +(defun-with-dx make-array-on-stack-11 () + (let ((v (make-array (the integer (opaque-identity 3)) :initial-element 12.0d0 :element-type 'double-float))) + (declare (sb-int:truly-dynamic-extent v)) + (true v) + (true v) nil)) (defun-with-dx vector-on-stack (x y) @@ -499,12 +556,10 @@ (defvar *a-cons* (cons nil nil)) -#+stack-allocatable-closures -(with-test (:name (:no-consing :dx-closures)) +(with-test (:name (:no-consing :dx-closures) :skipped-on '(not :stack-allocatable-closures)) (assert-no-consing (dxclosure 42))) -#+stack-allocatable-lists -(with-test (:name (:no-consing :dx-lists)) +(with-test (:name (:no-consing :dx-lists) :skipped-on '(not :stack-allocatable-lists)) (assert-no-consing (dxlength 1 2 3)) (assert-no-consing (dxlength t t t t t t)) (assert-no-consing (dxlength)) @@ -520,8 +575,7 @@ (with-test (:name (:no-consing :dx-value-cell)) (assert-no-consing (dx-value-cell 13))) -#+stack-allocatable-fixed-objects -(with-test (:name (:no-consing :dx-fixed-objects)) +(with-test (:name (:no-consing :dx-fixed-objects) :skipped-on '(not :stack-allocatable-fixed-objects)) (assert-no-consing (cons-on-stack 42)) (assert-no-consing (make-foo1-on-stack 123)) (assert-no-consing (nested-good 42)) @@ -529,18 +583,28 @@ (assert-no-consing (dx-handler-bind 2)) (assert-no-consing (dx-handler-case 2))) -#+stack-allocatable-vectors -(with-test (:name (:no-consing :dx-vectors)) +(with-test (:name (:no-consing :dx-vectors) :skipped-on '(not :stack-allocatable-vectors)) (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 -(with-test (:name (:no-consing :dx-raw-instances) :fails-on :ppc) +(with-test (:name (:no-consing :specialized-dx-vectors) + :fails-on :x86 + :skipped-on `(not (and :stack-allocatable-vectors + :c-stack-is-control-stack))) + (assert-no-consing (make-array-on-stack-1)) + (assert-no-consing (make-array-on-stack-6)) + (assert-no-consing (make-array-on-stack-7)) + (assert-no-consing (make-array-on-stack-8)) + (assert-no-consing (make-array-on-stack-9)) + (assert-no-consing (make-array-on-stack-10)) + (assert-no-consing (make-array-on-stack-11))) + +(with-test (:name (:no-consing :dx-raw-instances) :skipped-on '(or (not :raw-instance-init-vops) + (not (and :gencgc :c-stack-is-control-stack)))) (let (a b) (setf a 1.24 b 1.23d0) (assert-no-consing (make-foo2-on-stack a b))) @@ -555,18 +619,36 @@ (gethash 5 *table*)) ;; This fails on threaded PPC because the hash-table implementation -;; uses recursive system spinlocks, which cons (see below for test -;; (:no-consing :spinlock), which also fails on threaded PPC). +;; uses recursive system locks, which cons (see below for test +;; (:no-consing :lock), which also fails on threaded PPC). +;; +;; -- That may have been the situation in 2010 when the above comment +;; was written, but AFAICT now, hash tables use WITH-PINNED-OBJECTS, +;; which conses on PPC and SPARC when GENCGC is enabled. So neither is +;; this actually about threading, nor about PPC. Yet since we are +;; failing most of this file on SPARC anyway (for some tests even on +;; cheneygc), I won't bother to mark this particular test as failing. +;; It would be nice if someone could go through this file and figure it +;; all out... --DFL (with-test (:name (:no-consing :hash-tables) :fails-on '(and :ppc :sb-thread)) (assert-no-consing (test-hash-table))) -;;; with-spinlock and with-mutex should use DX and not cons +;;; Both with-pinned-objects and without-gcing should not cons + +(defun call-without-gcing (fun) + (sb-sys:without-gcing (funcall fun))) -(defvar *slock* (sb-thread::make-spinlock :name "slocklock")) +(defun call-with-pinned-object (fun obj) + (sb-sys:with-pinned-objects (obj) + (funcall fun obj))) -(defun test-spinlock () - (sb-thread::with-spinlock (*slock*) - (true *slock*))) +(with-test (:name (:no-consing :without-gcing)) + (assert-no-consing (call-without-gcing (lambda ())))) + +(with-test (:name (:no-consing :with-pinned-objects)) + (assert-no-consing (call-with-pinned-object #'identity 42))) + +;;; with-mutex should use DX and not cons (defvar *mutex* (sb-thread::make-mutex :name "mutexlock")) @@ -574,14 +656,8 @@ (sb-thread:with-mutex (*mutex*) (true *mutex*))) -#+sb-thread -(with-test (:name (:no-consing :mutex) :fails-on :ppc) +(with-test (:name (:no-consing :mutex) :fails-on :ppc :skipped-on '(not :sb-thread)) (assert-no-consing (test-mutex))) - -#+sb-thread -(with-test (:name (:no-consing :spinlock) :fails-on :ppc) - (assert-no-consing (test-spinlock))) - ;;; Bugs found by Paul F. Dietz @@ -630,7 +706,7 @@ (bdowning-2005-iv-16)) (declaim (inline my-nconc)) -(defun-with-dx my-nconc (&rest lists) +(defun my-nconc (&rest lists) (declare (dynamic-extent lists)) (apply #'nconc lists)) (defun-with-dx my-nconc-caller (a b c) @@ -833,7 +909,9 @@ nil))) (assert-notes 0 `(lambda (list) (declare (optimize (space 0))) - (sort list #'<))) + (sort list (lambda (x y) ; shut unrelated notes up + (< (truly-the fixnum x) + (truly-the fixnum y)))))) (assert-notes 0 `(lambda (other) #'(lambda (s c n) (ignore-errors (funcall other s c n))))))) @@ -1000,3 +1078,46 @@ (assert (eql a 1)) (assert (eql b 2)) (assert (eql c 3))))) + +(defun opaque-funcall (function &rest arguments) + (apply function arguments)) + +(with-test (:name :implicit-value-cells) + (flet ((test-it (type input output) + (let ((f (compile nil `(lambda (x) + (declare (type ,type x)) + (flet ((inc () + (incf x))) + (declare (dynamic-extent #'inc)) + (list (opaque-funcall #'inc) x)))))) + (assert (equal (funcall f input) + (list output output)))))) + (let ((width sb-vm:n-word-bits)) + (test-it t (1- most-positive-fixnum) most-positive-fixnum) + (test-it `(unsigned-byte ,(1- width)) (ash 1 (- width 2)) (1+ (ash 1 (- width 2)))) + (test-it `(signed-byte ,width) (ash -1 (- width 2)) (1+ (ash -1 (- width 2)))) + (test-it `(unsigned-byte ,width) (ash 1 (1- width)) (1+ (ash 1 (1- width)))) + (test-it 'single-float 3f0 4f0) + (test-it 'double-float 3d0 4d0) + (test-it '(complex single-float) #c(3f0 4f0) #c(4f0 4f0)) + (test-it '(complex double-float) #c(3d0 4d0) #c(4d0 4d0))))) + +(with-test (:name :sap-implicit-value-cells) + (let ((f (compile nil `(lambda (x) + (declare (type system-area-pointer x)) + (flet ((inc () + (setf x (sb-sys:sap+ x 16)))) + (declare (dynamic-extent #'inc)) + (list (opaque-funcall #'inc) x))))) + (width sb-vm:n-machine-word-bits)) + (assert (every (lambda (x) + (sb-sys:sap= x (sb-sys:int-sap (+ 16 (ash 1 (1- width)))))) + (funcall f (sb-sys:int-sap (ash 1 (1- width)))))))) + +(with-test (:name :&more-bounds) + ;; lp#1154946 + (assert (not (funcall (compile nil '(lambda (&rest args) (car args)))))) + (assert (not (funcall (compile nil '(lambda (&rest args) (nth 6 args)))))) + (assert (not (funcall (compile nil '(lambda (&rest args) (elt args 10)))))) + (assert (not (funcall (compile nil '(lambda (&rest args) (cadr args)))))) + (assert (not (funcall (compile nil '(lambda (&rest args) (third args)))))))