;;;; 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)
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)
(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)
(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)
: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)
(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-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)))
(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"))
(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)))
-
\f
;;; Bugs found by Paul F. Dietz
(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)
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)))))))
(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)))))))