From 7c43a308982c0a834db1727239b4ddf576b39fb0 Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Wed, 1 Sep 2010 11:53:16 +0000
Subject: [PATCH] 1.0.42.11: reinline nested LIST and VECTOR calls in
 MAKE-ARRAY initial-contents

 * Fixes lp#586105.

 * The source transform for MAKE-ARRAY makes LIST and VECTOR notinline
   so that the deftransforms can pick initial-contents and dimensions
   apart.

   However, when a list or vector in initial-contents is not part of
   the initialization structure but an actual initialization value,
   then notinline loses both performance in general, and foils nested
   DX in particular.

   So, walk the initial-contents and restore inlining for the actual
   initialization values.
---
 NEWS                             |    2 ++
 src/compiler/array-tran.lisp     |   51 +++++++++++++++++++++++++++++---------
 tests/dynamic-extent.impure.lisp |    7 ++++++
 version.lisp-expr                |    2 +-
 4 files changed, 49 insertions(+), 13 deletions(-)

diff --git a/NEWS b/NEWS
index ee7c8d0..d0c7f2a 100644
--- a/NEWS
+++ b/NEWS
@@ -19,6 +19,8 @@ changes relative to sbcl-1.0.42
     without adding DEFTYPEs for them works. (lp#618387)
   * bug fix: timetravel by getrusage() no longer causes type-errors during GC.
     (lp#544421)
+  * bug fix: legally dynamic-extent lists and vectors used as
+    initialization arguments to MAKE-ARRAY can be stack allocated. (lp#586105)
 
 changes in sbcl-1.0.42 relative to sbcl-1.0.41
   * build changes
diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 91ca4c6..a3cea57 100644
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -333,21 +333,48 @@
                        ,@(when initial-element
                            '(:initial-element initial-element)))))
 
-;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments,
-;;; so that we can pick them apart.
-(define-source-transform make-array (&whole form dimensions &rest keyargs
-                                     &environment env)
+(defun rewrite-initial-contents (rank initial-contents env)
+  (if (plusp rank)
+      (if (and (consp initial-contents)
+               (member (car initial-contents) '(list vector sb!impl::backq-list)))
+          `(list ,@(mapcar (lambda (dim)
+                             (rewrite-initial-contents (1- rank) dim env))
+                           (cdr initial-contents)))
+          initial-contents)
+      ;; This is the important bit: once we are past the level of
+      ;; :INITIAL-CONTENTS that relates to the array structure, reinline LIST
+      ;; and VECTOR so that nested DX isn't screwed up.
+      `(locally (declare (inline list vector))
+         ,initial-contents)))
+
+;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments, so that we
+;;; can pick them apart in the DEFTRANSFORMS, and transform '(3) style
+;;; dimensions to integer args directly.
+(define-source-transform make-array (dimensions &rest keyargs &environment env)
   (if (and (fun-lexically-notinline-p 'list)
            (fun-lexically-notinline-p 'vector))
       (values nil t)
-      `(locally (declare (notinline list vector))
-         ;; Transform '(3) style dimensions to integer args directly.
-         ,(if (sb!xc:constantp dimensions env)
-              (let ((dims (constant-form-value dimensions env)))
-                (if (and (listp dims) (= 1 (length dims)))
-                    `(make-array ',(car dims) ,@keyargs)
-                    form))
-              form))))
+      (multiple-value-bind (new-dimensions rank)
+          (flet ((constant-dims (dimensions)
+                   (let* ((dims (constant-form-value dimensions env))
+                          (canon (if (listp dims) dims (list dims)))
+                          (rank (length canon)))
+                     (values (if (= rank 1)
+                                 (list 'quote (car canon))
+                                 (list 'quote canon))
+                             rank))))
+            (cond ((sb!xc:constantp dimensions env)
+                   (constant-dims dimensions))
+                  ((and (consp dimensions) (eq 'list dimensions))
+                   (values dimensions (length (cdr dimensions))))
+                  (t
+                   (values dimensions nil))))
+        (let ((initial-contents (getf keyargs :initial-contents)))
+          (when (and initial-contents rank)
+            (setf (getf keyargs :initial-contents)
+                  (rewrite-initial-contents rank initial-contents env))))
+        `(locally (declare (notinline list vector))
+           (make-array ,new-dimensions ,@keyargs)))))
 
 ;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY
 ;;; call which creates a vector with a known element type -- and tries
diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 93493d4..be5ddbc 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -894,4 +894,11 @@
              (flet ((bar () t))
                (cons #'bar (lambda () (declare (dynamic-extent #'bar))))))
           'sb-ext:compiler-note)))
+
+(with-test (:name :bug-586105)
+  (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))))
 
diff --git a/version.lisp-expr b/version.lisp-expr
index e692acf..e96a42d 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.42.11"
+"1.0.42.12"
-- 
1.7.10.4