(when (eq sb-ext:*evaluator-mode* :interpret)
(sb-ext:quit :unix-status 104))
+(load "compiler-test-util.lisp")
+(use-package :ctu)
+
(setq sb-c::*check-consistency* t
sb-ext:*stack-allocate-dynamic-extent* t)
(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))
(setf (gethash 5 *table*) 13)
(gethash 5 *table*))
\f
-(defmacro assert-no-consing (form &optional times)
- `(%assert-no-consing (lambda () ,form) ,times))
-(defun %assert-no-consing (thunk &optional times)
- (let ((before (get-bytes-consed))
- (times (or times 10000)))
- (declare (type (integer 1 *) times))
- (dotimes (i times)
- (funcall thunk))
- (assert (< (- (get-bytes-consed) before) times))))
-
-(defmacro assert-consing (form &optional times)
- `(%assert-consing (lambda () ,form) ,times))
-(defun %assert-consing (thunk &optional times)
- (let ((before (get-bytes-consed))
- (times (or times 10000)))
- (declare (type (integer 1 *) times))
- (dotimes (i times)
- (funcall thunk))
- (assert (not (< (- (get-bytes-consed) before) times)))))
-
(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-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))
- ;; Only for platforms with DX FIXED-ALLOC
- #+(or hppa mips x86 x86-64)
+ #+stack-allocatable-fixed-objects
(progn
(assert-no-consing (cons-on-stack 42))
(assert-no-consing (make-foo1-on-stack 123))
(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)
+ #+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))
- #+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))
+ (let (a b)
+ (setf a 1.24 b 1.23d0)
+ (#+raw-instance-init-vops assert-no-consing
+ #-raw-instance-init-vops progn
+ (make-foo2-on-stack a b)))
(#+raw-instance-init-vops assert-no-consing
#-raw-instance-init-vops progn
(make-foo3-on-stack))
- (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))
;; Not strictly DX..
(assert-no-consing (test-hash-table))
#+sb-thread
(assert-no-consing (bdowning-2005-iv-16))
(bdowning-2005-iv-16))
+(declaim (inline my-nconc))
+(defun-with-dx my-nconc (&rest lists)
+ (declare (dynamic-extent lists))
+ (apply #'nconc lists))
+(defun-with-dx my-nconc-caller (a b c)
+ (let ((l1 (list a b c))
+ (l2 (list a b c)))
+ (my-nconc l1 l2)))
+(with-test (:name :rest-stops-the-buck)
+ (let ((list1 (my-nconc-caller 1 2 3))
+ (list2 (my-nconc-caller 9 8 7)))
+ (assert (equal list1 '(1 2 3 1 2 3)))
+ (assert (equal list2 '(9 8 7 9 8 7)))))
+
(defun-with-dx let-converted-vars-dx-allocated-bug (x y z)
(let* ((a (list x y z))
(b (list x y z))
(c (list a b)))
(declare (dynamic-extent c))
(values (first c) (second c))))
-
(with-test (:name :let-converted-vars-dx-allocated-bug)
(multiple-value-bind (i j) (let-converted-vars-dx-allocated-bug 1 2 3)
(assert (and (equal i j)
(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)))
+
+;;; A nasty bug where RECHECK-DYNAMIC-EXTENT-LVARS thought something was going
+;;; to be stack allocated when it was not, leading to a bogus %NIP-VALUES.
+;;; Fixed by making RECHECK-DYNAMIC-EXTENT-LVARS deal properly with nested DX.
+(deftype vec ()
+ `(simple-array single-float (3)))
+(declaim (ftype (function (t t t) vec) vec))
+(declaim (inline vec))
+(defun vec (a b c)
+ (make-array 3 :element-type 'single-float :initial-contents (list a b c)))
+(defun bad-boy (vec)
+ (declare (type vec vec))
+ (lambda (fun)
+ (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)
+ (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))))
+ (let ((bad-boy (bad-boy (vec 2.0 3.0 4.0))))
+ (assert-no-consing (funcall bad-boy #'foo)))))
\f
projects / sbcl.git / blobdiff