stack-allocatable fill-initialized specialized arrays, take 2

  Really fix lp#902537.

  Turns out multiple references to the stack allocated vector complicate
  things /just/ sufficiently the that DX machinery can't keep up. (I because
  the code that allocates and initializes the vector isn't substituted at the
  use-site due to multiple references.)

  While it would be nice to make it smart enough to deal with
  non-let-converted WITH-ARRAY-DATA, that looks a bit tricky... so instead
  simplify things in the FILL transform when the vector is a simple-array.

diff --git a/src/compiler/seqtran.lisp b/src/compiler/seqtran.lisp
index 24cce71..f5f7483 100644 (file)
--- a/src/compiler/seqtran.lisp
+++ b/src/compiler/seqtran.lisp
@@ -643,15 +643,28 @@
                                                            (logior res (ash bits (truly-the (integer 0 ,(- sb!vm:n-word-bits n-bits)) i))))))))
                            res)))))
              (values
-              `(with-array-data ((data seq)
-                                 (start start)
-                                 (end end)
-                                 :check-fill-pointer t)
-                 (declare (type (simple-array ,element-type 1) data))
-                 (declare (type index start end))
-                 (declare (optimize (safety 0) (speed 3)))
-                 (,basher ,bash-value data start (- end start))
-                 seq)
+              ;; KLUDGE: WITH-ARRAY data in its full glory is going to mess up
+              ;; dynamic-extent for MAKE-ARRAY :INITIAL-ELEMENT initialization.
+              (if (csubtypep (lvar-type seq) (specifier-type '(simple-array * (*))))
+                  `(let* ((len (length seq))
+                          (end (or end len))
+                          (bound (1+ end)))
+                     ;; Minor abuse %CHECK-BOUND for bounds checking.
+                     ;; (- END START) may still end up negative, but
+                     ;; the basher handle that.
+                     (,basher ,bash-value seq
+                              (%check-bound seq bound start)
+                              (- (if end (%check-bound seq bound end) len)
+                                 start)))
+               `(with-array-data ((data seq)
+                                  (start start)
+                                  (end end)
+                                  :check-fill-pointer t)
+                  (declare (type (simple-array ,element-type 1) data))
+                  (declare (type index start end))
+                  (declare (optimize (safety 0) (speed 3)))
+                  (,basher ,bash-value data start (- end start))
+                  seq))
               `((declare (type ,element-type item))))))
           ((policy node (> speed space))
            (values

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 00c3b7e..291a80b 100644 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -176,12 +176,14 @@
   (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)
@@ -189,6 +191,7 @@
   (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)
@@ -197,48 +200,56 @@
                        :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 vector-on-stack (x y)