1.0.28.51: better MAKE-ARRAY transforms

 * Add a source transform for MAKE-ARRAY that declaims LIST and VECTOR
   as NOTINLINE, so the the MAKE-ARRAY deftransforms are able to pick
   them apart (for DIMENSIONS and :INITIAL-CONTENTS.)

 * INITIALIZE-VECTOR is a new magic function with a IR2-CONVERT
   transform. It's purpose is to allow open coding :INITIAL-CONTENTS
   initialization without inhibiting stack allocation.

 * Turns out that making stack allocation decisions during locall
   analysis is not enough since optimization iterates: if a transform
   occurs and introduces new LVARs that would be good for DX after
   the locall analysis has run for the combination, the new LVARs
   will not get their share of stacky goodness. Therefore, after
   a transform propagate DX information to the new functional
   explicitly (see MAYBE-PROPAGATE-DYNAMIC-EXTENT.)

 * The new logic is in TRANSFORM-MAKE-ARRAY-VECTOR, which handles
   all the cases of vector allocation with a known element type:

   ** :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and (BACKQ-LIST ...)
      are picked apart when the length matches the vector length,
      and their arguments are spliced into the call.

      Constant :INITIAL-CONTENTS is picked apart as well.

      Initialization is done using INITIALIZE-VECTOR.

   ** Otherwise :INITIAL-CONTENTS is splatted in place using
      REPLACE after we have checked that the length matches.

   ** :INITIAL-ELEMENT not EQL to the default element uses
      FILL.

   ** Otherwise the default initialization is fine.

   Some additional hair here, since MAYBE-PROPAGATE-DYNAMIC-EXTENT
   cannot deal with OPTIONAL-DISPATCH functionals. So to ensure we get
   full benefit of it, make sure the lambdas we transform to have only
   required arguments -- courtesy of new ELIMINATE-KEYWORD-ARGUMENT
   utility. (Note: it might be worth it to do something like this for
   many cases automatically, to reduce the number of lambdas the
   compiler generates. For inline lambdas we could do the whole &key
   handling _before_ the lambda is converted...)

 * Identify the case of (LIST N) as dimensions as being a vector,
   and delegate to TRANSFORM-MAKE-ARRAY-VECTOR.

 * More efficient allocation of simple multidimensional arrays in
   the presence of :INITIAL-CONTENTS (still slow, though) and
   :INITIAL-ELEMENT (not bad.)

 * Fix the source transform for VECTOR so that it too can stack
   allocate.

 * Updates tests and docs.

diff --git a/NEWS b/NEWS
index 3102cf7..64cb027 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -25,8 +25,18 @@
   * optimization: result of (FILL (MAKE-ARRAY ...) ...) and (REPLACE
     (MAKE-ARRAY ...) ...) can be stack allocated if the result of MAKE-ARRAY
     form can be.
+  * optimization: result of call to VECTOR can now be stack allocated.
+  * optimization: MAKE-ARRAY with :INITIAL-CONTENTS is now vastly faster
+    as long as the resulting array is one-dimensional and has a known
+    element type. In particular, :INITIAL-CONTENTS (LIST ...) where the
+    length of the list matches the known length of the vector does not
+    allocate the list as an intermediate step. Ditto for VECTOR and simple
+    backquoted forms.
+  * optimization: MAKE-ARRAY can now stack allocate in the presence of
+    :INITIAL-CONTENTS and :INITIAL-ELEMENT as long as the result has a
+    known element type, and is known to be simple and one dimensional.
   * improvement: SBCL now emits a compiler note where stack allocation was
-    requested but could not be provided.
+    requested but could not be provided (not in all cases, unfortunately)
   * improvement: better MACHINE-VERSION responses. (thanks to Josh Elsasser)
   * improvement: pretty-printing loop has been implemented properly. (thanks
     to Tobias Rittweiler)

diff --git a/OPTIMIZATIONS b/OPTIMIZATIONS
index 55f86c4..581291c 100644 (file)
--- a/OPTIMIZATIONS
+++ b/OPTIMIZATIONS
@@ -209,6 +209,10 @@ enough to eliminate something like ':initial-element 0'.  Such an optimization
 is valid if the vector is being allocated in the heap, but not if it is being
 allocated on the stack.  You could remove this optimization, but that makes
 the heap-allocated case somewhat slower...)
+
+To do this, extend ALLOCATE-VECTOR with ALLOW-JUNK argument, and when
+stack allocating don't zero if it is true -- and probably ALLOW-JUNK iff
+the vector is a specialized one (cannot have pointers.)
 --------------------------------------------------------------------------------
 #28
 a. Accessing raw slots in structure instances is more inefficient than

diff --git a/doc/manual/efficiency.texinfo b/doc/manual/efficiency.texinfo
index c03c733..5c94214 100644 (file)
--- a/doc/manual/efficiency.texinfo
+++ b/doc/manual/efficiency.texinfo
@@ -93,14 +93,14 @@ useful. At present, SBCL implements stack allocation for
 @code{&rest} lists, when these are declared @code{dynamic-extent}.
 
 @item
-@code{cons}, @code{list} and @code{list*}, when the result is bound to
-a variable declared @code{dynamic-extent}.
+@code{cons}, @code{list}, @code{list*}, and @code{vector} when the
+result is bound to a variable declared @code{dynamic-extent}.
 
 @item
 simple forms of @code{make-array}, whose result is bound to a variable
 declared @code{dynamic-extent}: stack allocation is possible only if
-the resulting array is one-dimensional, and the call has no keyword
-arguments with the exception of @code{:element-type}.
+the resulting array is known to be both simple and one-dimensional,
+and has a constant @code{:element-type}.
 
 @strong{Note}: stack space is limited, so allocation of a large vector
 may cause stack overflow. For this reason potentially large vectors,

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 580bda6..c7481e2 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -217,19 +217,9 @@
 \f
 ;;;; constructors
 
-;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the
-;;; elements.
+;;; Convert VECTOR into a MAKE-ARRAY.
 (define-source-transform vector (&rest elements)
-  (let ((len (length elements))
-        (n -1))
-    (once-only ((n-vec `(make-array ,len)))
-      `(progn
-         ,@(mapcar (lambda (el)
-                     (once-only ((n-val el))
-                       `(locally (declare (optimize (safety 0)))
-                          (setf (svref ,n-vec ,(incf n)) ,n-val))))
-                   elements)
-         ,n-vec))))
+  `(make-array ,(length elements) :initial-contents (list ,@elements)))
 
 ;;; Just convert it into a MAKE-ARRAY.
 (deftransform make-string ((length &key
@@ -241,6 +231,240 @@
                        ,@(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 &rest args)
+  (declare (ignore args))
+  (if (and (fun-lexically-notinline-p 'list)
+           (fun-lexically-notinline-p 'vector))
+      (values nil t)
+      `(locally (declare (notinline list vector))
+         ,form)))
+
+;;; 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
+;;; to do a good job with all the different ways it can happen.
+(defun transform-make-array-vector (length element-type initial-element
+                                    initial-contents call)
+  (aver (or (not element-type) (constant-lvar-p element-type)))
+  (let* ((c-length (when (constant-lvar-p length)
+                     (lvar-value length)))
+         (elt-spec (if element-type
+                       (lvar-value element-type)
+                       t))
+         (elt-ctype (ir1-transform-specifier-type elt-spec))
+         (saetp (if (unknown-type-p elt-ctype)
+                    (give-up-ir1-transform "~S is an unknown type: ~S"
+                                           :element-type elt-spec)
+                    (find-saetp-by-ctype elt-ctype)))
+         (default-initial-element (sb!vm:saetp-initial-element-default saetp))
+         (n-bits (sb!vm:saetp-n-bits saetp))
+         (typecode (sb!vm:saetp-typecode saetp))
+         (n-pad-elements (sb!vm:saetp-n-pad-elements saetp))
+         (n-words-form
+          (if c-length
+              (ceiling (* (+ c-length n-pad-elements) n-bits)
+                       sb!vm:n-word-bits)
+              (let ((padded-length-form (if (zerop n-pad-elements)
+                                            'length
+                                            `(+ length ,n-pad-elements))))
+                (cond
+                  ((= n-bits 0) 0)
+                  ((>= n-bits sb!vm:n-word-bits)
+                   `(* ,padded-length-form
+                       ;; i.e., not RATIO
+                       ,(the fixnum (/ n-bits sb!vm:n-word-bits))))
+                  (t
+                   (let ((n-elements-per-word (/ sb!vm:n-word-bits n-bits)))
+                     (declare (type index n-elements-per-word)) ; i.e., not RATIO
+                     `(ceiling ,padded-length-form ,n-elements-per-word)))))))
+         (result-spec
+          `(simple-array ,(sb!vm:saetp-specifier saetp) (,(or c-length '*))))
+         (alloc-form
+          `(truly-the ,result-spec
+                      (allocate-vector ,typecode (the index length) ,n-words-form))))
+    (cond ((and initial-element initial-contents)
+           (abort-ir1-transform "Both ~S and ~S specified."
+                                :initial-contents :initial-element))
+          ;; :INITIAL-CONTENTS (LIST ...), (VECTOR ...) and `(1 1 ,x) with a
+          ;; constant LENGTH.
+          ((and initial-contents c-length
+                (lvar-matches initial-contents
+                              :fun-names '(list vector sb!impl::backq-list)
+                              :arg-count c-length))
+           (let ((parameters (eliminate-keyword-args
+                              call 1 '((:element-type element-type)
+                                       (:initial-contents initial-contents))))
+                 (elt-vars (make-gensym-list c-length))
+                 (lambda-list '(length)))
+             (splice-fun-args initial-contents :any c-length)
+             (dolist (p parameters)
+               (setf lambda-list
+                     (append lambda-list
+                             (if (eq p 'initial-contents)
+                                 elt-vars
+                                 (list p)))))
+             `(lambda ,lambda-list
+                (declare (type ,elt-spec ,@elt-vars)
+                         (ignorable ,@lambda-list))
+                (truly-the ,result-spec
+                 (initialize-vector ,alloc-form ,@elt-vars)))))
+          ;; constant :INITIAL-CONTENTS and LENGTH
+          ((and initial-contents c-length (constant-lvar-p initial-contents))
+           (let ((contents (lvar-value initial-contents)))
+             (unless (= c-length (length contents))
+               (abort-ir1-transform "~S has ~S elements, vector length is ~S."
+                                    :initial-contents (length contents) c-length))
+             (let ((parameters (eliminate-keyword-args
+                                call 1 '((:element-type element-type)
+                                         (:initial-contents initial-contents)))))
+               `(lambda (length ,@parameters)
+                  (declare (ignorable ,@parameters))
+                  (truly-the ,result-spec
+                   (initialize-vector ,alloc-form
+                                      ,@(map 'list (lambda (elt)
+                                                     `(the ,elt-spec ,elt))
+                                             contents)))))))
+          ;; any other :INITIAL-CONTENTS
+          (initial-contents
+           (let ((parameters (eliminate-keyword-args
+                              call 1 '((:element-type element-type)
+                                       (:initial-contents initial-contents)))))
+             `(lambda (length ,@parameters)
+                (declare (ignorable ,@parameters))
+                (unless (= length (length initial-contents))
+                  (error "~S has ~S elements, vector length is ~S."
+                         :initial-contents (length initial-contents) length))
+                (truly-the ,result-spec
+                           (replace ,alloc-form initial-contents)))))
+          ;; :INITIAL-ELEMENT, not EQL to the default
+          ((and initial-element
+                (or (not (constant-lvar-p initial-element))
+                    (not (eql default-initial-element (lvar-value initial-element)))))
+           (let ((parameters (eliminate-keyword-args
+                              call 1 '((:element-type element-type)
+                                       (:initial-element initial-element)))))
+             `(lambda (length ,@parameters)
+                (declare (ignorable ,@parameters))
+                (truly-the ,result-spec
+                           (fill ,alloc-form (the ,elt-spec initial-element))))))
+          ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
+          ;; default
+          (t
+           #-sb-xc-host
+           (unless (ctypep default-initial-element elt-ctype)
+             ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
+             ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
+             ;; INITIAL-ELEMENT is not supplied, the consequences of later
+             ;; reading an uninitialized element of new-array are undefined,"
+             ;; so this could be legal code as long as the user plans to
+             ;; write before he reads, and if he doesn't we're free to do
+             ;; anything we like. But in case the user doesn't know to write
+             ;; elements before he reads elements (or to read manuals before
+             ;; he writes code:-), we'll signal a STYLE-WARNING in case he
+             ;; didn't realize this.
+             (if initial-element
+                 (compiler-warn "~S ~S is not a ~S"
+                                :initial-element default-initial-element
+                                elt-spec)
+                 (compiler-style-warn "The default initial element ~S is not a ~S."
+                                      default-initial-element
+                                      elt-spec)))
+           (let ((parameters (eliminate-keyword-args
+                              call 1 '((:element-type element-type)))))
+             `(lambda (length ,@parameters)
+                (declare (ignorable ,@parameters))
+                ,alloc-form))))))
+
+(deftransform make-array ((dims &key
+                                element-type initial-element initial-contents)
+                          (integer &key
+                                   (:element-type (constant-arg *))
+                                   (:initial-element *)
+                                   (:initial-contents *))
+                          *
+                          :node call)
+  (transform-make-array-vector dims
+                               element-type
+                               initial-element
+                               initial-contents
+                               call))
+
+;;; The list type restriction does not ensure that the result will be a
+;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
+;;; and displaced-to keywords ensures that it will be simple.
+;;;
+;;; FIXME: should we generalize this transform to non-simple (though
+;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
+;;; deal with those? Maybe when the DEFTRANSFORM
+;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
+;;; CSR, 2002-07-01
+(deftransform make-array ((dims &key
+                                element-type initial-element initial-contents)
+                          (list &key
+                                (:element-type (constant-arg *))
+                                (:initial-element *)
+                                (:initial-contents *))
+                          *
+                          :node call)
+  (block make-array
+    (when (lvar-matches dims :fun-names '(list) :arg-count 1)
+      (let ((length (car (splice-fun-args dims :any 1))))
+        (return-from make-array
+          (transform-make-array-vector length
+                                       element-type
+                                       initial-element
+                                       initial-contents
+                                       call))))
+    (unless (constant-lvar-p dims)
+      (give-up-ir1-transform
+       "The dimension list is not constant; cannot open code array creation."))
+    (let ((dims (lvar-value dims)))
+      (unless (every #'integerp dims)
+        (give-up-ir1-transform
+         "The dimension list contains something other than an integer: ~S"
+         dims))
+      (if (= (length dims) 1)
+          `(make-array ',(car dims)
+                       ,@(when element-type
+                               '(:element-type element-type))
+                       ,@(when initial-element
+                               '(:initial-element initial-element))
+                       ,@(when initial-contents
+                               '(:initial-contents initial-contents)))
+          (let* ((total-size (reduce #'* dims))
+                 (rank (length dims))
+                 (spec `(simple-array
+                         ,(cond ((null element-type) t)
+                                ((and (constant-lvar-p element-type)
+                                      (ir1-transform-specifier-type
+                                       (lvar-value element-type)))
+                                 (sb!xc:upgraded-array-element-type
+                                  (lvar-value element-type)))
+                                (t '*))
+                         ,(make-list rank :initial-element '*))))
+            `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank))
+                   (data (make-array ,total-size
+                                     ,@(when element-type
+                                             '(:element-type element-type))
+                                     ,@(when initial-element
+                                             '(:initial-element initial-element)))))
+               ,@(when initial-contents
+                       ;; FIXME: This is could be open coded at least a bit too
+                       `((sb!impl::fill-data-vector data ',dims initial-contents)))
+               (setf (%array-fill-pointer header) ,total-size)
+               (setf (%array-fill-pointer-p header) nil)
+               (setf (%array-available-elements header) ,total-size)
+               (setf (%array-data-vector header) data)
+               (setf (%array-displaced-p header) nil)
+               (setf (%array-displaced-from header) nil)
+               ,@(let ((axis -1))
+                      (mapcar (lambda (dim)
+                                `(setf (%array-dimension header ,(incf axis))
+                                       ,dim))
+                              dims))
+               (truly-the ,spec header)))))))
+
 (deftransform make-array ((dims &key initial-element element-type
                                      adjustable fill-pointer)
                           (t &rest *))
@@ -299,128 +523,6 @@
                  (%data-vector-and-index array 0)
                (fill vector (the ,(sb!vm:saetp-specifier saetp) initial-element)))
              array)))))
-
-;;; The integer type restriction on the length ensures that it will be
-;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and
-;;; :DISPLACED-TO keywords ensures that it will be simple; the lack of
-;;; :INITIAL-ELEMENT relies on another transform to deal with that
-;;; kind of initialization efficiently.
-(deftransform make-array ((length &key element-type)
-                          (integer &rest *))
-  (let* ((eltype (cond ((not element-type) t)
-                       ((not (constant-lvar-p element-type))
-                        (give-up-ir1-transform
-                         "ELEMENT-TYPE is not constant."))
-                       (t
-                        (lvar-value element-type))))
-         (len (if (constant-lvar-p length)
-                  (lvar-value length)
-                  '*))
-         (eltype-type (ir1-transform-specifier-type eltype))
-         (result-type-spec
-          `(simple-array
-            ,(if (unknown-type-p eltype-type)
-                 (give-up-ir1-transform
-                  "ELEMENT-TYPE is an unknown type: ~S" eltype)
-                 (sb!xc:upgraded-array-element-type eltype))
-            (,len)))
-         (saetp (find-if (lambda (saetp)
-                           (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
-                         sb!vm:*specialized-array-element-type-properties*)))
-    (unless saetp
-      (give-up-ir1-transform
-       "cannot open-code creation of ~S" result-type-spec))
-    #-sb-xc-host
-    (unless (ctypep (sb!vm:saetp-initial-element-default saetp) eltype-type)
-      ;; This situation arises e.g. in (MAKE-ARRAY 4 :ELEMENT-TYPE
-      ;; '(INTEGER 1 5)) ANSI's definition of MAKE-ARRAY says "If
-      ;; INITIAL-ELEMENT is not supplied, the consequences of later
-      ;; reading an uninitialized element of new-array are undefined,"
-      ;; so this could be legal code as long as the user plans to
-      ;; write before he reads, and if he doesn't we're free to do
-      ;; anything we like. But in case the user doesn't know to write
-      ;; elements before he reads elements (or to read manuals before
-      ;; he writes code:-), we'll signal a STYLE-WARNING in case he
-      ;; didn't realize this.
-      (compiler-style-warn "The default initial element ~S is not a ~S."
-                           (sb!vm:saetp-initial-element-default saetp)
-                           eltype))
-    (let* ((n-bits-per-element (sb!vm:saetp-n-bits saetp))
-           (typecode (sb!vm:saetp-typecode saetp))
-           (n-pad-elements (sb!vm:saetp-n-pad-elements saetp))
-           (padded-length-form (if (zerop n-pad-elements)
-                                   'length
-                                   `(+ length ,n-pad-elements)))
-           (n-words-form
-            (cond
-              ((= n-bits-per-element 0) 0)
-              ((>= n-bits-per-element sb!vm:n-word-bits)
-               `(* ,padded-length-form
-                 (the fixnum ; i.e., not RATIO
-                   ,(/ n-bits-per-element sb!vm:n-word-bits))))
-              (t
-               (let ((n-elements-per-word (/ sb!vm:n-word-bits
-                                             n-bits-per-element)))
-                 (declare (type index n-elements-per-word)) ; i.e., not RATIO
-                 `(ceiling ,padded-length-form ,n-elements-per-word))))))
-      (values
-       `(truly-the ,result-type-spec
-         (allocate-vector ,typecode length ,n-words-form))
-       '((declare (type index length)))))))
-
-;;; The list type restriction does not ensure that the result will be a
-;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
-;;; and displaced-to keywords ensures that it will be simple.
-;;;
-;;; FIXME: should we generalize this transform to non-simple (though
-;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
-;;; deal with those? Maybe when the DEFTRANSFORM
-;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
-;;; CSR, 2002-07-01
-(deftransform make-array ((dims &key element-type)
-                          (list &rest *))
-  (unless (or (null element-type) (constant-lvar-p element-type))
-    (give-up-ir1-transform
-     "The element-type is not constant; cannot open code array creation."))
-  (unless (constant-lvar-p dims)
-    (give-up-ir1-transform
-     "The dimension list is not constant; cannot open code array creation."))
-  (let ((dims (lvar-value dims)))
-    (unless (every #'integerp dims)
-      (give-up-ir1-transform
-       "The dimension list contains something other than an integer: ~S"
-       dims))
-    (if (= (length dims) 1)
-        `(make-array ',(car dims)
-                     ,@(when element-type
-                         '(:element-type element-type)))
-        (let* ((total-size (reduce #'* dims))
-               (rank (length dims))
-               (spec `(simple-array
-                       ,(cond ((null element-type) t)
-                              ((and (constant-lvar-p element-type)
-                                    (ir1-transform-specifier-type
-                                     (lvar-value element-type)))
-                               (sb!xc:upgraded-array-element-type
-                                (lvar-value element-type)))
-                              (t '*))
-                           ,(make-list rank :initial-element '*))))
-          `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank)))
-             (setf (%array-fill-pointer header) ,total-size)
-             (setf (%array-fill-pointer-p header) nil)
-             (setf (%array-available-elements header) ,total-size)
-             (setf (%array-data-vector header)
-                   (make-array ,total-size
-                               ,@(when element-type
-                                   '(:element-type element-type))))
-             (setf (%array-displaced-p header) nil)
-             (setf (%array-displaced-from header) nil)
-             ,@(let ((axis -1))
-                 (mapcar (lambda (dim)
-                           `(setf (%array-dimension header ,(incf axis))
-                                  ,dim))
-                         dims))
-             (truly-the ,spec header))))))
 \f
 ;;;; miscellaneous properties of arrays
 

diff --git a/src/compiler/generic/vm-fndb.lisp b/src/compiler/generic/vm-fndb.lisp
index 8da9bc3..299f49f 100644 (file)
--- a/src/compiler/generic/vm-fndb.lisp
+++ b/src/compiler/generic/vm-fndb.lisp
@@ -88,6 +88,11 @@
 (defknown %set-symbol-hash (symbol hash)
   t (unsafe))
 
+(defknown initialize-vector ((simple-array * (*)) &rest t)
+  (simple-array * (*))
+  (always-translatable)
+  :result-arg 0)
+
 (defknown vector-fill* (t t t t) vector
   (unsafe)
   :result-arg 0)

diff --git a/src/compiler/generic/vm-ir2tran.lisp b/src/compiler/generic/vm-ir2tran.lisp
index dfedc2d..0f5f92e 100644 (file)
--- a/src/compiler/generic/vm-ir2tran.lisp
+++ b/src/compiler/generic/vm-ir2tran.lisp
@@ -16,13 +16,6 @@
 (defoptimizer (%make-structure-instance stack-allocate-result) ((&rest args) node dx)
   t)
 
-(defoptimizer (make-array stack-allocate-result) ((&rest args) node dx)
-  ;; The actual stack allocation decision will be made on the basis of what
-  ;; ALLOCATE-VECTOR, but this is needed so that (FILL (MAKE-ARRAY N) X) and
-  ;; (REPLACE (MAKE-ARRAY (LENGTH V)) V) can potentially stack allocate the
-  ;; new vector.
-  t)
-
 (defoptimizer ir2-convert-reffer ((object) node block name offset lowtag)
   (let* ((lvar (node-lvar node))
          (locs (lvar-result-tns lvar
@@ -162,6 +155,52 @@
       (emit-inits node block name result lowtag words `((:dd . ,c-dd) ,@c-slot-specs) args)
       (move-lvar-result node block locs lvar))))
 
+(defoptimizer (initialize-vector ir2-convert)
+    ((vector &rest initial-contents) node block)
+  (let* ((vector-ctype (lvar-type vector))
+         (elt-ctype (if (array-type-p vector-ctype)
+                        (array-type-specialized-element-type vector-ctype)
+                        (bug "Unknow vector type in IR2 conversion for ~S."
+                             'initialize-vector)))
+         (saetp (find-saetp-by-ctype elt-ctype))
+         (lvar (node-lvar node))
+         (locs (lvar-result-tns lvar (list (primitive-type vector-ctype))))
+         (result (first locs))
+         (elt-ptype (primitive-type elt-ctype))
+         (tmp (make-normal-tn elt-ptype)))
+    (emit-move node block (lvar-tn node block vector) result)
+    (flet ((compute-setter ()
+             (macrolet
+                 ((frob ()
+                    (let ((*package* (find-package :sb!vm))
+                          (clauses nil))
+                      (map nil (lambda (s)
+                                 (when (sb!vm:saetp-specifier s)
+                                   (push
+                                    `(,(sb!vm:saetp-typecode s)
+                                       (lambda (index tn)
+                                         #!+(or x86 x86-64)
+                                         (vop ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/"
+                                                            (sb!vm:saetp-primitive-type-name s))
+                                              node block result index tn 0 tn)
+                                         #!-(or x86 x86-64)
+                                         (vop ,(symbolicate "DATA-VECTOR-SET/"
+                                                            (sb!vm:saetp-primitive-type-name s))
+                                              node block result index tn tn)))
+                                    clauses)))
+                           sb!vm:*specialized-array-element-type-properties*)
+                      `(ecase (sb!vm:saetp-typecode saetp)
+                         ,@(nreverse clauses)))))
+               (frob)))
+           (tnify (index)
+             (constant-tn (find-constant index))))
+      (let ((setter (compute-setter))
+            (length (length initial-contents)))
+        (dotimes (i length)
+          (emit-move node block (lvar-tn node block (pop initial-contents)) tmp)
+          (funcall setter (tnify i) tmp))))
+    (move-lvar-result node block locs lvar)))
+
 ;;; :SET-TRANS (in objdef.lisp DEFINE-PRIMITIVE-OBJECT) doesn't quite
 ;;; cut it for symbols, where under certain compilation options
 ;;; (e.g. #!+SB-THREAD) we have to do something complicated, rather

diff --git a/src/compiler/ir1opt.lisp b/src/compiler/ir1opt.lisp
index c22c25c..8604960 100644 (file)
--- a/src/compiler/ir1opt.lisp
+++ b/src/compiler/ir1opt.lisp
@@ -1289,6 +1289,7 @@
             (ref (lvar-use (combination-fun call))))
         (change-ref-leaf ref new-fun)
         (setf (combination-kind call) :full)
+        (maybe-propagate-dynamic-extent call new-fun)
         (locall-analyze-component *current-component*))))
   (values))
 

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index 7fa4abe..d501d67 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -1554,9 +1554,9 @@
 ;;; arguments.
 (defun splice-fun-args (lvar fun num-args)
   #!+sb-doc
-  "If LVAR is a call to FUN with NUM-ARGS args, change those arguments
-   to feed directly to the LVAR-DEST of LVAR, which must be a
-   combination."
+  "If LVAR is a call to FUN with NUM-ARGS args, change those arguments to feed
+directly to the LVAR-DEST of LVAR, which must be a combination. If FUN
+is :ANY, the function name is not checked."
   (declare (type lvar lvar)
            (type symbol fun)
            (type index num-args))
@@ -1566,7 +1566,8 @@
     (unless (combination-p inside)
       (give-up-ir1-transform))
     (let ((inside-fun (combination-fun inside)))
-      (unless (eq (lvar-fun-name inside-fun) fun)
+      (unless (or (eq fun :any)
+                  (eq (lvar-fun-name inside-fun) fun))
         (give-up-ir1-transform))
       (let ((inside-args (combination-args inside)))
         (unless (= (length inside-args) num-args)
@@ -1587,7 +1588,40 @@
                 (combination-kind inside) :known)
           (setf (node-derived-type inside) *wild-type*)
           (flush-dest lvar)
-          (values))))))
+          inside-args)))))
+
+;;; Eliminate keyword arguments from the call (leaving the
+;;; parameters in place.
+;;;
+;;;    (FOO ... :BAR X :QUUX Y)
+;;; becomes
+;;;    (FOO ... X Y)
+;;;
+;;; SPECS is a list of (:KEYWORD PARAMETER) specifications.
+;;; Returns the list of specified parameters names in the
+;;; order they appeared in the call. N-POSITIONAL is the
+;;; number of positional arguments in th call.
+(defun eliminate-keyword-args (call n-positional specs)
+  (let* ((specs (copy-tree specs))
+         (all (combination-args call))
+         (new-args (reverse (subseq all 0 n-positional)))
+         (key-args (subseq all n-positional))
+         (parameters nil))
+    (loop while key-args
+          do (let* ((key (pop key-args))
+                    (val (pop key-args))
+                    (keyword (if (constant-lvar-p key)
+                                 (lvar-value key)
+                                 (give-up-ir1-transform)))
+                    (spec (or (assoc keyword specs :test #'eq)
+                              (give-up-ir1-transform))))
+               (push val new-args)
+               (flush-dest key)
+               (push (second spec) parameters)
+               ;; In case of duplicate keys.
+               (setf (second spec) (gensym))))
+    (setf (combination-args call) (reverse new-args))
+    (reverse parameters)))
 
 (defun extract-fun-args (lvar fun num-args)
   (declare (type lvar lvar)
@@ -2040,3 +2074,12 @@
                 (eq (global-var-kind leaf) :global-function)
                 (not (null (member (leaf-source-name leaf) names
                                    :test #'equal))))))))
+
+(defun lvar-matches (lvar &key fun-names arg-count)
+  (let ((use (lvar-use lvar)))
+    (and (combination-p use)
+         (or (not fun-names)
+             (member (combination-fun-source-name use)
+                     fun-names :test #'eq))
+         (or (not arg-count)
+             (= arg-count (length (combination-args use)))))))

diff --git a/src/compiler/locall.lisp b/src/compiler/locall.lisp
index 1c6db26..ed3e34f 100644 (file)
--- a/src/compiler/locall.lisp
+++ b/src/compiler/locall.lisp
@@ -99,6 +99,37 @@
                       (setf (lvar-dynamic-extent (cdr cell)) cleanup)))))
   (values))
 
+;;; Called after a transform has been applied to CALL: if the call has a DX
+;;; result, propagate the DXness to the new functional as well.
+;;;
+;;; This is needed in case an earlier call to LOCALL-ANALYZE-COMPONENT
+;;; collected DX information before the transformation, in which case a later
+;;; call to LOCALL-ANALYZE-COMPONENT would not pick up the DX declaration
+;;; again, since the call has already been converted. (In other words, work
+;;; around the fact that optimization iterates, and locall analysis may have
+;;; already run by the time we are able to transform something.)
+(defun maybe-propagate-dynamic-extent (call fun)
+  (when (lambda-p fun)
+    (let* ((lvar (combination-lvar call))
+           (cleanup (or (and lvar (lvar-dynamic-extent lvar))
+                        (return-from maybe-propagate-dynamic-extent)))
+           (ret (lambda-return fun))
+           (res (if ret
+                    (return-result ret)
+                    (return-from maybe-propagate-dynamic-extent)))
+           (dx (car (rassoc lvar (cleanup-info cleanup) :test #'eq)))
+           (new-dx-lvars (if (and dx res)
+                             (handle-nested-dynamic-extent-lvars dx res)
+                             (return-from maybe-propagate-dynamic-extent))))
+      (when new-dx-lvars
+        ;; This builds on what RECOGNIZE-DYNAMIC-EXTENT-LVARS does above.
+        (aver (eq call (block-last (node-block call))))
+        (dolist (cell new-dx-lvars)
+          (let ((lvar (cdr cell)))
+            (aver (not (lvar-dynamic-extent lvar)))
+            (push cell (cleanup-info cleanup))
+            (setf (lvar-dynamic-extent (cdr cell)) cleanup)))))))
+
 ;;; This function handles merging the tail sets if CALL is potentially
 ;;; tail-recursive, and is a call to a function with a different
 ;;; TAIL-SET than CALL's FUN. This must be called whenever we alter

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 99d925a..4c183bb 100644 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -147,15 +147,51 @@
 
 ;;; MAKE-ARRAY
 
-(defun-with-dx make-array-on-stack ()
+(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 force-make-array-on-stack (n)
-  (declare (optimize safety))
-  (let ((v (make-array (min n 1))))
+(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))
+
+;;; 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))
+    (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))
@@ -483,8 +519,14 @@
   (assert-no-consing (test-lvar-subst 11))
   (assert-no-consing (dx-value-cell 13))
   (assert-no-consing (cons-on-stack 42))
-  (assert-no-consing (make-array-on-stack))
   (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))
   (assert-no-consing (make-foo1-on-stack 123))
   (assert-no-consing (nested-good 42))
   (#+raw-instance-init-vops assert-no-consing

diff --git a/version.lisp-expr b/version.lisp-expr
index ba90147..9d80aaf 100644 (file)
--- 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.28.50"
+"1.0.28.51"