(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))
(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))
(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-5))
(assert-no-consing (vector-on-stack :x :y)))
-#+raw-instance-init-vops
-(with-test (:name (:no-consing :dx-raw-instances))
+(with-test (:name (:no-consing :dx-raw-instances) :fails-on :ppc :skipped-on '(not :raw-instance-init-vops))
(let (a b)
(setf a 1.24 b 1.23d0)
(assert-no-consing (make-foo2-on-stack a b)))
(setf (gethash 5 *table*) 13)
(gethash 5 *table*))
-(with-test (:name (:no-consing :hash-tables))
+;; This fails on threaded PPC because the hash-table implementation
+;; uses recursive system locks, which cons (see below for test
+;; (:no-consing :lock), which also fails on threaded PPC).
+(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
-
-(defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
-
-(defun test-spinlock ()
- (sb-thread::with-spinlock (*slock*)
- (true *slock*)))
+;;; with-mutex should use DX and not cons
(defvar *mutex* (sb-thread::make-mutex :name "mutexlock"))
(sb-thread:with-mutex (*mutex*)
(true *mutex*)))
-#+sb-thread
-(with-test (:name (:no-consing :mutex))
+(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))
- (assert-no-consing (test-spinlock)))
-
\f
;;; Bugs found by Paul F. Dietz
(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))
+(with-test (:name :handler-case-bogus-compiler-note :fails-on :ppc)
+ (handler-bind
+ ((compiler-note (lambda (note)
+ (error "compiler issued note ~S during test" note))))
;; Taken from SWANK, used to signal a bogus stack allocation
;; failure note.
(compile nil
v))
(defun barvector (x y z)
(make-array 3 :initial-contents (list x y z)))
-(with-test (:name :dx-compiler-notes)
+(with-test (:name :dx-compiler-notes :fails-on :ppc)
(flet ((assert-notes (j lambda)
(let ((n 0))
(handler-bind ((compiler-note (lambda (c)
(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)
+(with-test (:name :handler-case-eating-stack :fails-on :ppc)
(assert-no-consing (handler-case-eating-stack)))
;;; A nasty bug where RECHECK-DYNAMIC-EXTENT-LVARS thought something was going
(let ((vec (vec (aref vec 0) (aref vec 1) (aref vec 2))))
(declare (dynamic-extent vec))
(funcall fun vec))))
-(with-test (:name :recheck-nested-dx-bug)
+(with-test (:name :recheck-nested-dx-bug :fails-on :ppc)
(assert (funcall (bad-boy (vec 1.0 2.0 3.3))
(lambda (vec) (equalp vec (vec 1.0 2.0 3.3)))))
(flet ((foo (x) (declare (ignore x))))
(flet ((bar () t))
(cons #'bar (lambda () (declare (dynamic-extent #'bar))))))
'sb-ext:compiler-note)))
+
+(with-test (:name :bug-586105 :fails-on '(not (and :stack-allocatable-vectors
+ :stack-allocatable-lists)))
+ (flet ((test (x)
+ (let ((vec (make-array 1 :initial-contents (list (list x)))))
+ (declare (dynamic-extent vec))
+ (assert (eql x (car (aref vec 0)))))))
+ (assert-no-consing (test 42))))
\f
+(defun bug-681092 ()
+ (declare (optimize speed))
+ (let ((c 0))
+ (flet ((bar () c))
+ (declare (dynamic-extent #'bar))
+ (do () ((list) (bar))
+ (setf c 10)
+ (return (bar))))))
+(with-test (:name :bug-681092)
+ (assert (= 10 (bug-681092))))
+
+;;;; &REST lists should stop DX propagation -- not required by ANSI,
+;;;; but required by sanity.
+
+(declaim (inline rest-stops-dx))
+(defun-with-dx rest-stops-dx (&rest args)
+ (declare (dynamic-extent args))
+ (apply #'opaque-identity args))
+
+(defun-with-dx rest-stops-dx-ok ()
+ (equal '(:foo) (rest-stops-dx (list :foo))))
+
+(with-test (:name :rest-stops-dynamic-extent)
+ (assert (rest-stops-dx-ok)))
+
+;;;; These tests aren't strictly speaking DX, but rather &REST -> &MORE
+;;;; conversion.
+(with-test (:name :rest-to-more-conversion)
+ (let ((f1 (compile nil `(lambda (f &rest args)
+ (apply f args)))))
+ (assert-no-consing (assert (eql f1 (funcall f1 #'identity f1)))))
+ (let ((f2 (compile nil `(lambda (f1 f2 &rest args)
+ (values (apply f1 args) (apply f2 args))))))
+ (assert-no-consing (multiple-value-bind (a b)
+ (funcall f2 (lambda (x y z) (+ x y z)) (lambda (x y z) (- x y z))
+ 1 2 3)
+ (assert (and (eql 6 a) (eql -4 b))))))
+ (let ((f3 (compile nil `(lambda (f &optional x &rest args)
+ (when x
+ (apply f x args))))))
+ (assert-no-consing (assert (eql 42 (funcall f3
+ (lambda (a b c) (+ a b c))
+ 11
+ 10
+ 21)))))
+ (let ((f4 (compile nil `(lambda (f &optional x &rest args &key y &allow-other-keys)
+ (apply f y x args)))))
+ (assert-no-consing (funcall f4 (lambda (y x yk y2 b c)
+ (assert (eq y 'y))
+ (assert (= x 2))
+ (assert (eq :y yk))
+ (assert (eq y2 'y))
+ (assert (eq b 'b))
+ (assert (eq c 'c)))
+ 2 :y 'y 'b 'c)))
+ (let ((f5 (compile nil `(lambda (a b c &rest args)
+ (apply #'list* a b c args)))))
+ (assert (equal '(1 2 3 4 5 6 7) (funcall f5 1 2 3 4 5 6 '(7)))))
+ (let ((f6 (compile nil `(lambda (x y)
+ (declare (optimize speed))
+ (concatenate 'string x y)))))
+ (assert (equal "foobar" (funcall f6 "foo" "bar"))))
+ (let ((f7 (compile nil `(lambda (&rest args)
+ (lambda (f)
+ (apply f args))))))
+ (assert (equal '(a b c d e f) (funcall (funcall f7 'a 'b 'c 'd 'e 'f) 'list))))
+ (let ((f8 (compile nil `(lambda (&rest args)
+ (flet ((foo (f)
+ (apply f args)))
+ #'foo)))))
+ (assert (equal '(a b c d e f) (funcall (funcall f8 'a 'b 'c 'd 'e 'f) 'list))))
+ (let ((f9 (compile nil `(lambda (f &rest args)
+ (flet ((foo (g)
+ (apply g args)))
+ (declare (dynamic-extent #'foo))
+ (funcall f #'foo))))))
+ (assert (equal '(a b c d e f)
+ (funcall f9 (lambda (f) (funcall f 'list)) 'a 'b 'c 'd 'e 'f))))
+ (let ((f10 (compile nil `(lambda (f &rest args)
+ (flet ((foo (g)
+ (apply g args)))
+ (funcall f #'foo))))))
+ (assert (equal '(a b c d e f)
+ (funcall f10 (lambda (f) (funcall f 'list)) 'a 'b 'c 'd 'e 'f))))
+ (let ((f11 (compile nil `(lambda (x y z)
+ (block out
+ (labels ((foo (x &rest rest)
+ (apply (lambda (&rest rest2)
+ (return-from out (values-list rest2)))
+ x rest)))
+ (if x
+ (foo x y z)
+ (foo y z x))))))))
+ (multiple-value-bind (a b c) (funcall f11 1 2 3)
+ (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))))))))
projects / sbcl.git / blobdiff