X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=tests%2Fdynamic-extent.impure.lisp;h=fec38398a8b779c0e157b9082f26069b1d02a560;hb=1f03c7f326823245708a84af86b31ac72bdb1742;hp=0d1992d44bfa980a4e191afbc6d8bdd3b88fe243;hpb=b1f7d9dcedbd900c3c4d6c171a92f4ae7e075166;p=sbcl.git

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 0d1992d..fec3839 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -14,6 +14,9 @@
 (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)
 
@@ -181,9 +184,6 @@
     (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))
@@ -484,42 +484,26 @@
   (setf (gethash 5 *table*) 13)
   (gethash 5 *table*))
 
-(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))
@@ -527,27 +511,23 @@
     (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
@@ -599,13 +579,26 @@
   (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)
@@ -730,22 +723,94 @@
                         (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)))))