(when (eq sb-ext:*evaluator-mode* :interpret)
(sb-ext:quit :unix-status 104))
-(setq sb-c::*check-consistency* t)
+(setq sb-c::*check-consistency* t
+ sb-ext:*stack-allocate-dynamic-extent* t)
(defmacro defun-with-dx (name arglist &body body)
- `(locally
- (declare (optimize sb-c::stack-allocate-dynamic-extent))
- (defun ,name ,arglist
- ,@body)))
+ `(defun ,name ,arglist
+ ,@body))
(declaim (notinline opaque-identity))
(defun opaque-identity (x)
(defun-with-dx dx-value-cell (x)
;; Not implemented everywhere, yet.
- #+(or x86 x86-64 mips)
+ #+(or x86 x86-64 mips hppa)
(let ((cell x))
- (declare (dynamic-extent cell))
+ (declare (sb-int:truly-dynamic-extent cell))
(flet ((f ()
(incf cell)))
(declare (dynamic-extent #'f))
(true cons)
nil))
+;;; MAKE-ARRAY
+
+(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))
+
+(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))
+(defstruct fp-struct-1
+ (s 0.0 :type single-float)
+ (d 0.0d0 :type double-float))
+
+(defun-with-dx test-fp-struct-1.1 (s d)
+ (let ((fp (make-fp-struct-1 :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql 0.0d0 (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.2 (s d)
+ (let ((fp (make-fp-struct-1 :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql 0.0 (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.3 (s d)
+ (let ((fp (make-fp-struct-1 :d d :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(defun-with-dx test-fp-struct-1.4 (s d)
+ (let ((fp (make-fp-struct-1 :s s :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-1-s fp)))
+ (assert (eql d (fp-struct-1-d fp)))))
+
+(test-fp-struct-1.1 123.456 876.243d0)
+(test-fp-struct-1.2 123.456 876.243d0)
+(test-fp-struct-1.3 123.456 876.243d0)
+(test-fp-struct-1.4 123.456 876.243d0)
+
+(declaim (inline make-fp-struct-2))
+(defstruct fp-struct-2
+ (d 0.0d0 :type double-float)
+ (s 0.0 :type single-float))
+
+(defun-with-dx test-fp-struct-2.1 (s d)
+ (let ((fp (make-fp-struct-2 :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql 0.0d0 (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.2 (s d)
+ (let ((fp (make-fp-struct-2 :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql 0.0 (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.3 (s d)
+ (let ((fp (make-fp-struct-2 :d d :s s)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(defun-with-dx test-fp-struct-2.4 (s d)
+ (let ((fp (make-fp-struct-2 :s s :d d)))
+ (declare (dynamic-extent fp))
+ (assert (eql s (fp-struct-2-s fp)))
+ (assert (eql d (fp-struct-2-d fp)))))
+
+(test-fp-struct-2.1 123.456 876.243d0)
+(test-fp-struct-2.2 123.456 876.243d0)
+(test-fp-struct-2.3 123.456 876.243d0)
+(test-fp-struct-2.4 123.456 876.243d0)
+
+(declaim (inline make-cfp-struct-1))
+(defstruct cfp-struct-1
+ (s (complex 0.0) :type (complex single-float))
+ (d (complex 0.0d0) :type (complex double-float)))
+
+(defun-with-dx test-cfp-struct-1.1 (s d)
+ (let ((cfp (make-cfp-struct-1 :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql (complex 0.0d0) (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.2 (s d)
+ (let ((cfp (make-cfp-struct-1 :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql (complex 0.0) (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.3 (s d)
+ (let ((cfp (make-cfp-struct-1 :d d :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(defun-with-dx test-cfp-struct-1.4 (s d)
+ (let ((cfp (make-cfp-struct-1 :s s :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-1-s cfp)))
+ (assert (eql d (cfp-struct-1-d cfp)))))
+
+(test-cfp-struct-1.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-1.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-1.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-1.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+
+(declaim (inline make-cfp-struct-2))
+(defstruct cfp-struct-2
+ (d (complex 0.0d0) :type (complex double-float))
+ (s (complex 0.0) :type (complex single-float)))
+
+(defun-with-dx test-cfp-struct-2.1 (s d)
+ (let ((cfp (make-cfp-struct-2 :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql (complex 0.0d0) (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.2 (s d)
+ (let ((cfp (make-cfp-struct-2 :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql (complex 0.0) (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.3 (s d)
+ (let ((cfp (make-cfp-struct-2 :d d :s s)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(defun-with-dx test-cfp-struct-2.4 (s d)
+ (let ((cfp (make-cfp-struct-2 :s s :d d)))
+ (declare (dynamic-extent cfp))
+ (assert (eql s (cfp-struct-2-s cfp)))
+ (assert (eql d (cfp-struct-2-d cfp)))))
+
+(test-cfp-struct-2.1 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-2.2 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-2.3 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+(test-cfp-struct-2.4 (complex 0.123 123.456) (complex 908132.41d0 876.243d0))
+
+(declaim (inline make-foo1 make-foo2 make-foo3))
+(defstruct foo1 x)
+
+(defun-with-dx make-foo1-on-stack (x)
+ (let ((foo (make-foo1 :x x)))
+ (declare (dynamic-extent foo))
+ (assert (eql x (foo1-x foo)))))
+
+(defstruct foo2
+ (x 0.0 :type single-float)
+ (y 0.0d0 :type double-float)
+ a
+ b
+ c)
+
+(defmacro assert-eql (expected got)
+ `(let ((exp ,expected)
+ (got ,got))
+ (unless (eql exp got)
+ (error "Expected ~S, got ~S!" exp got))))
+
+(defun-with-dx make-foo2-on-stack (x y)
+ (let ((foo (make-foo2 :y y :c 'c)))
+ (declare (dynamic-extent foo))
+ (assert-eql 0.0 (foo2-x foo))
+ (assert-eql y (foo2-y foo))
+ (assert-eql 'c (foo2-c foo))
+ (assert-eql nil (foo2-b foo))))
+
+;;; Check that constants work out as argument for all relevant
+;;; slot types.
+(defstruct foo3
+ (a 0 :type t)
+ (b 1 :type fixnum)
+ (c 2 :type sb-vm:word)
+ (d 3.0 :type single-float)
+ (e 4.0d0 :type double-float))
+(defun-with-dx make-foo3-on-stack ()
+ (let ((foo (make-foo3)))
+ (declare (dynamic-extent foo))
+ (assert (eql 0 (foo3-a foo)))
+ (assert (eql 1 (foo3-b foo)))
+ (assert (eql 2 (foo3-c foo)))
+ (assert (eql 3.0 (foo3-d foo)))
+ (assert (eql 4.0d0 (foo3-e foo)))))
+
;;; Nested DX
(defun-with-dx nested-dx-lists ()
(true dx)
nil))
-;;; with-spinlock should use DX and not cons
+(defun-with-dx nested-dx-not-used (x)
+ (declare (list x))
+ (let ((l (setf (car x) (list x x x))))
+ (declare (dynamic-extent l))
+ (true l)
+ (true (length l))
+ nil))
+
+(defun-with-dx nested-evil-dx-used (x)
+ (declare (list x))
+ (let ((l (list x x x)))
+ (declare (dynamic-extent l))
+ (unwind-protect
+ (progn
+ (setf (car x) l)
+ (true l))
+ (setf (car x) nil))
+ nil))
+
+(defparameter *bar* nil)
+(declaim (inline make-nested-bad make-nested-good))
+(defstruct (nested (:constructor make-nested-bad (&key bar &aux (bar (setf *bar* bar))))
+ (:constructor make-nested-good (&key bar)))
+ bar)
+
+(defun-with-dx nested-good (y)
+ (let ((x (list (list (make-nested-good :bar (list (list (make-nested-good :bar (list y)))))))))
+ (declare (dynamic-extent x))
+ (true x)))
+
+(defun-with-dx nested-bad (y)
+ (let ((x (list (list (make-nested-bad :bar (list (list (make-nested-bad :bar (list y)))))))))
+ (declare (dynamic-extent x))
+ (unless (equalp (caar x) (make-nested-good :bar *bar*))
+ (error "got ~S, wanted ~S" (caar x) (make-nested-good :bar *bar*)))
+ (caar x)))
+
+(with-test (:name :conservative-nested-dx)
+ ;; NESTED-BAD should not stack-allocate :BAR due to the SETF.
+ (assert (equalp (nested-bad 42) (make-nested-good :bar *bar*)))
+ (assert (equalp *bar* (list (list (make-nested-bad :bar (list 42)))))))
+
+;;; multiple uses for dx lvar
+
+(defun-with-dx multiple-dx-uses ()
+ (let ((dx (if (true t)
+ (list 1 2 3)
+ (list 2 3 4))))
+ (declare (dynamic-extent dx))
+ (true dx)
+ nil))
+
+;;; handler-case and handler-bind should use DX internally
+
+(defun dx-handler-bind (x)
+ (handler-bind ((error
+ (lambda (c) (break "OOPS: ~S caused ~S" x c)))
+ ((and serious-condition (not error))
+ #'(lambda (c) (break "OOPS2: ~S did ~S" x c))))
+ (/ 2 x)))
+
+(defun dx-handler-case (x)
+ (assert (zerop (handler-case (/ 2 x)
+ (error (c)
+ (break "OOPS: ~S caused ~S" x c))
+ (:no-error (res)
+ (1- res))))))
+
+;;; with-spinlock and with-mutex should use DX and not cons
(defvar *slock* (sb-thread::make-spinlock :name "slocklock"))
(sb-thread::with-spinlock (*slock*)
(true *slock*)))
+(defvar *mutex* (sb-thread::make-mutex :name "mutexlock"))
+
+(defun test-mutex ()
+ (sb-thread:with-mutex (*mutex*)
+ (true *mutex*)))
+
;;; not really DX, but GETHASH and (SETF GETHASH) should not cons
(defvar *table* (make-hash-table))
(funcall thunk))
(assert (< (- (get-bytes-consed) before) times))))
-#+(or x86 x86-64 alpha ppc sparc mips)
+(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))
+
(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-subst1 17))
+ (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))
- (assert-no-consing (cons-on-stack 42))
- (assert-no-consing (nested-dx-conses))
- (assert-no-consing (nested-dx-lists))
+ #+stack-allocatable-fixed-objects
+ (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)))
+ #+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))
+ (assert-no-consing (make-array-on-stack-5))
+ (assert-no-consing (vector-on-stack :x :y)))
+ (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))
;; Not strictly DX..
(assert-no-consing (test-hash-table))
#+sb-thread
- (assert-no-consing (test-spinlock)))
+ (progn
+ (assert-no-consing (test-spinlock))
+ (assert-no-consing (test-mutex))))
\f
;;; Bugs found by Paul F. Dietz
(let ((a (make-array 11 :initial-element 0)))
(declare (dynamic-extent a))
(assert (every (lambda (x) (eql x 0)) a))))
-(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))
+ (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)
+ (equal i (list 1 2 3))))))
+
+;;; workaround for bug 419 -- real issue remains, but check that the
+;;; bandaid holds.
+(defun-with-dx bug419 (x)
+ (multiple-value-call #'list
+ (eval '(values 1 2 3))
+ (let ((x x))
+ (declare (dynamic-extent x))
+ (flet ((mget (y)
+ (+ x y))
+ (mset (z)
+ (incf x z)))
+ (declare (dynamic-extent #'mget #'mset))
+ ((lambda (f g) (eval `(progn ,f ,g (values 4 5 6)))) #'mget #'mset)))))
+(assert (equal (bug419 42) '(1 2 3 4 5 6)))
+
+;;; Multiple DX arguments in a local function call
+(defun test-dx-flet-test (fun n f1 f2 f3)
+ (let ((res (with-output-to-string (s)
+ (assert (eql n (ignore-errors (funcall fun s)))))))
+ (multiple-value-bind (x pos) (read-from-string res nil)
+ (assert (equalp f1 x))
+ (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))))))
+ #+(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
+ (defun-with-dx ,name (s)
+ (flet ((f (x)
+ (declare (dynamic-extent x))
+ (when s
+ (print x s)
+ (finish-output s))
+ nil))
+ (f ,f1)
+ (f ,f2)
+ (f ,f3)
+ ,n))
+ (test-dx-flet-test #',name ,n ,f1 ,f2 ,f3)))))
+ (def 0 (list :one) (list :two) (list :three))
+ (def 1 (make-array 128) (list 1 2 3 4 5 6 7 8) (list 'list))
+ (def 2 (list 1) (list 2 3) (list 4 5 6 7)))
+
+;;; Test that unknown-values coming after a DX value won't mess up the stack analysis
+(defun test-update-uvl-live-sets (x y z)
+ (declare (optimize speed (safety 0)))
+ (flet ((bar (a b)
+ (declare (dynamic-extent a))
+ (eval `(list (length ',a) ',b))))
+ (list (bar x y)
+ (bar (list x y z) ; dx push
+ (list
+ (multiple-value-call 'list
+ (eval '(values 1 2 3)) ; uv push
+ (max y z)
+ ) ; uv pop
+ 14)
+ ))))
+(assert (equal '((0 4) (3 ((1 2 3 5) 14))) (test-update-uvl-live-sets #() 4 5)))
+
+(with-test (:name :regression-1.0.23.38)
+ (compile nil '(lambda ()
+ (flet ((make (x y)
+ (let ((res (cons x x)))
+ (setf (cdr res) y)
+ res)))
+ (declaim (inline make))
+ (let ((z (make 1 2)))
+ (declare (dynamic-extent z))
+ (print z)
+ t))))
+ (compile nil '(lambda ()
+ (flet ((make (x y)
+ (let ((res (cons x x)))
+ (setf (cdr res) y)
+ (if x res y))))
+ (declaim (inline make))
+ (let ((z (make 1 2)))
+ (declare (dynamic-extent z))
+ (print z)
+ t)))))
+
+;;; On x86 and x86-64 upto 1.0.28.16 LENGTH and WORDS argument
+;;; tns to ALLOCATE-VECTOR-ON-STACK could be packed in the same
+;;; location, leading to all manner of badness. ...reproducing this
+;;; reliably is hard, but this it at least used to break on x86-64.
+(defun length-and-words-packed-in-same-tn (m)
+ (declare (optimize speed (safety 0) (debug 0) (space 0)))
+ (let ((array (make-array (max 1 m) :element-type 'fixnum)))
+ (declare (dynamic-extent array))
+ (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))))))))))
+
+(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)
+ (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)))
\f
projects / sbcl.git / blobdiff