+
+;;; Bugs found by Paul F. Dietz
+
+(with-test (:name (:dx-bug-misc :pfdietz))
+ (assert
+ (eq
+ (funcall
+ (compile
+ nil
+ '(lambda (a b)
+ (declare (optimize (speed 2) (space 0) (safety 0)
+ (debug 1) (compilation-speed 3)))
+ (let* ((v5 (cons b b)))
+ (declare (dynamic-extent v5))
+ a)))
+ 'x 'y)
+ 'x)))
+
+;;; bug reported by Svein Ove Aas
+(defun svein-2005-ii-07 (x y)
+ (declare (optimize (speed 3) (space 2) (safety 0) (debug 0)))
+ (let ((args (list* y 1 2 x)))
+ (declare (dynamic-extent args))
+ (apply #'aref args)))
+
+(with-test (:name (:dx-bugs-misc :svein-2005-ii-07))
+ (assert (eql
+ (svein-2005-ii-07
+ '(0)
+ #3A(((1 1 1) (1 1 1) (1 1 1))
+ ((1 1 1) (1 1 1) (4 1 1))
+ ((1 1 1) (1 1 1) (1 1 1))))
+ 4)))
+
+;;; bug reported by Brian Downing: stack-allocated arrays were not
+;;; filled with zeroes.
+(defun-with-dx bdowning-2005-iv-16 ()
+ (let ((a (make-array 11 :initial-element 0)))
+ (declare (dynamic-extent a))
+ (assert (every (lambda (x) (eql x 0)) a))))
+
+(with-test (:name (:dx-bug-misc :bdowning-2005-iv-16))
+ #+(or hppa mips x86 x86-64)
+ (assert-no-consing (bdowning-2005-iv-16))
+ (bdowning-2005-iv-16))
+
+(declaim (inline my-nconc))
+(defun 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)
+ (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)))))
+
+(with-test (:name (:dx-bug-misc :bug419))
+ (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))
+ (with-test (:name (:dx-flet-test ,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)
+ ))))
+
+(with-test (:name (:update-uvl-live-sets))
+ (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 :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
+ `(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 :fails-on :ppc)
+ (flet ((assert-notes (j lambda)
+ (let ((n 0))
+ (handler-bind ((compiler-note (lambda (c)
+ (declare (ignore c))
+ (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 (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)))))))
+
+;;; 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 :fails-on :ppc)
+ (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 :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))))
+ (let ((bad-boy (bad-boy (vec 2.0 3.0 4.0))))
+ (assert-no-consing (funcall bad-boy #'foo)))))
+
+(with-test (:name :bug-497321)
+ (flet ((test (lambda type)
+ (let ((n 0))
+ (handler-bind ((condition (lambda (c)
+ (incf n)
+ (unless (typep c type)
+ (error "wanted ~S for~% ~S~%got ~S"
+ type lambda (type-of c))))))
+ (compile nil lambda))
+ (assert (= n 1)))))
+ (test `(lambda () (declare (dynamic-extent #'bar)))
+ 'style-warning)
+ (test `(lambda () (declare (dynamic-extent bar)))
+ 'style-warning)
+ (test `(lambda (bar) (cons bar (lambda () (declare (dynamic-extent bar)))))
+ 'sb-ext:compiler-note)
+ (test `(lambda ()
+ (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))))))))
+
+(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)))))))