1.0.29.4: still more MAKE-ARRAY work

* Re-order the three MAKE-ARRAY deftransform, so that the more
  specific ones are tried before the general one -- which allows stack
  allocation in more the remaining cases that used to fail (I don't
  know why I blamed VECTOR-FILL* for that before.)

* When constant splicing for initial-element in
  TRANSFORM-MAKE-ARRAY-VECTOR didn't quote it, leading to lossiness
  with symbols or lists as constant initial-elements. (Bug masked
  earlier by the mis-ordering of the deftransforms.)

* In the final leg of TRANSFORM-MAKE-ARRAY-VECTOR also eliminate the
  possible :INITIAL-ELEMENT keyword.

* When eliminating keywords from a MAKE-ARRAY call, don't flush the
  lvars before checking that all of them can be eliminated. (Also
  masked by the earlier mis-ordering.)

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 4c4ec20..4c0688d 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -351,7 +351,7 @@
                               call 1 '((:element-type element-type)
                                        (:initial-element initial-element))))
                  (init (if (constant-lvar-p initial-element)
-                           (lvar-value initial-element)
+                           (list 'quote (lvar-value initial-element))
                            'initial-element)))
              `(lambda (length ,@parameters)
                 (declare (ignorable ,@parameters))
@@ -380,24 +380,74 @@
                                       default-initial-element
                                       elt-spec)))
            (let ((parameters (eliminate-keyword-args
-                              call 1 '((:element-type element-type)))))
+                              call 1 '((:element-type element-type)
+                                       (:initial-element initial-element)))))
              `(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))
+;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least
+;;; specific must come first, otherwise suboptimal transforms will result for
+;;; some forms.
+
+(deftransform make-array ((dims &key initial-element element-type
+                                     adjustable fill-pointer)
+                          (t &rest *))
+  (when (null initial-element)
+    (give-up-ir1-transform))
+  (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))))
+         (eltype-type (ir1-transform-specifier-type eltype))
+         (saetp (find-if (lambda (saetp)
+                           (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
+                         sb!vm:*specialized-array-element-type-properties*))
+         (creation-form `(make-array dims
+                          :element-type ',(type-specifier (sb!vm:saetp-ctype saetp))
+                          ,@(when fill-pointer
+                                  '(:fill-pointer fill-pointer))
+                          ,@(when adjustable
+                                  '(:adjustable adjustable)))))
+
+    (unless saetp
+      (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
+
+    (cond ((and (constant-lvar-p initial-element)
+                (eql (lvar-value initial-element)
+                     (sb!vm:saetp-initial-element-default saetp)))
+           creation-form)
+          (t
+           ;; error checking for target, disabled on the host because
+           ;; (CTYPE-OF #\Null) is not possible.
+           #-sb-xc-host
+           (when (constant-lvar-p initial-element)
+             (let ((value (lvar-value initial-element)))
+               (cond
+                 ((not (ctypep value (sb!vm:saetp-ctype saetp)))
+                  ;; this case will cause an error at runtime, so we'd
+                  ;; better WARN about it now.
+                  (warn 'array-initial-element-mismatch
+                        :format-control "~@<~S is not a ~S (which is the ~
+                                         ~S of ~S).~@:>"
+                        :format-arguments
+                        (list
+                         value
+                         (type-specifier (sb!vm:saetp-ctype saetp))
+                         'upgraded-array-element-type
+                         eltype)))
+                 ((not (ctypep value eltype-type))
+                  ;; this case will not cause an error at runtime, but
+                  ;; it's still worth STYLE-WARNing about.
+                  (compiler-style-warn "~S is not a ~S."
+                                       value eltype)))))
+           `(let ((array ,creation-form))
+             (multiple-value-bind (vector)
+                 (%data-vector-and-index array 0)
+               (fill vector (the ,(sb!vm:saetp-specifier saetp) initial-element)))
+             array)))))
 
 ;;; The list type restriction does not ensure that the result will be a
 ;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
@@ -474,64 +524,18 @@
                               dims))
                (truly-the ,spec header)))))))
 
-(deftransform make-array ((dims &key initial-element element-type
-                                     adjustable fill-pointer)
-                          (t &rest *))
-  (when (null initial-element)
-    (give-up-ir1-transform))
-  (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))))
-         (eltype-type (ir1-transform-specifier-type eltype))
-         (saetp (find-if (lambda (saetp)
-                           (csubtypep eltype-type (sb!vm:saetp-ctype saetp)))
-                         sb!vm:*specialized-array-element-type-properties*))
-         (creation-form `(make-array dims
-                          :element-type ',(type-specifier (sb!vm:saetp-ctype saetp))
-                          ,@(when fill-pointer
-                                  '(:fill-pointer fill-pointer))
-                          ,@(when adjustable
-                                  '(:adjustable adjustable)))))
-
-    (unless saetp
-      (give-up-ir1-transform "ELEMENT-TYPE not found in *SAETP*: ~S" eltype))
-
-    (cond ((and (constant-lvar-p initial-element)
-                (eql (lvar-value initial-element)
-                     (sb!vm:saetp-initial-element-default saetp)))
-           creation-form)
-          (t
-           ;; error checking for target, disabled on the host because
-           ;; (CTYPE-OF #\Null) is not possible.
-           #-sb-xc-host
-           (when (constant-lvar-p initial-element)
-             (let ((value (lvar-value initial-element)))
-               (cond
-                 ((not (ctypep value (sb!vm:saetp-ctype saetp)))
-                  ;; this case will cause an error at runtime, so we'd
-                  ;; better WARN about it now.
-                  (warn 'array-initial-element-mismatch
-                        :format-control "~@<~S is not a ~S (which is the ~
-                                         ~S of ~S).~@:>"
-                        :format-arguments
-                        (list
-                         value
-                         (type-specifier (sb!vm:saetp-ctype saetp))
-                         'upgraded-array-element-type
-                         eltype)))
-                 ((not (ctypep value eltype-type))
-                  ;; this case will not cause an error at runtime, but
-                  ;; it's still worth STYLE-WARNing about.
-                  (compiler-style-warn "~S is not a ~S."
-                                       value eltype)))))
-           `(let ((array ,creation-form))
-             (multiple-value-bind (vector)
-                 (%data-vector-and-index array 0)
-               (fill vector (the ,(sb!vm:saetp-specifier saetp) initial-element)))
-             array)))))
+(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))
 \f
 ;;;; miscellaneous properties of arrays
 

diff --git a/src/compiler/ir1util.lisp b/src/compiler/ir1util.lisp
index d79da6b..19e0adb 100644 (file)
--- a/src/compiler/ir1util.lisp
+++ b/src/compiler/ir1util.lisp
@@ -1637,7 +1637,8 @@ is :ANY, the function name is not checked."
          (all (combination-args call))
          (new-args (reverse (subseq all 0 n-positional)))
          (key-args (subseq all n-positional))
-         (parameters nil))
+         (parameters nil)
+         (flushed-keys nil))
     (loop while key-args
           do (let* ((key (pop key-args))
                     (val (pop key-args))
@@ -1647,10 +1648,12 @@ is :ANY, the function name is not checked."
                     (spec (or (assoc keyword specs :test #'eq)
                               (give-up-ir1-transform))))
                (push val new-args)
-               (flush-dest key)
+               (push key flushed-keys)
                (push (second spec) parameters)
                ;; In case of duplicate keys.
                (setf (second spec) (gensym))))
+    (dolist (key flushed-keys)
+      (flush-dest key))
     (setf (combination-args call) (reverse new-args))
     (reverse parameters)))
 

diff --git a/tests/compiler.impure.lisp b/tests/compiler.impure.lisp
index d5ec1ca..bda6fb3 100644 (file)
--- a/tests/compiler.impure.lisp
+++ b/tests/compiler.impure.lisp
@@ -1086,13 +1086,19 @@
                     *hairy-progv-var*))))
 
 (with-test (:name :fill-complex-single-float)
-  (assert (eql #c(-1.0 2.0)
-               (aref (funcall
-                      (lambda ()
-                        (make-array 2
-                                    :element-type '(complex single-float)
-                                    :initial-element #c(-1.0 2.0))))
-                     0))))
+  (assert (every (lambda (x) (eql x #c(-1.0 -2.0)))
+                 (funcall
+                  (lambda ()
+                    (make-array 2
+                                :element-type '(complex single-float)
+                                :initial-element #c(-1.0 -2.0)))))))
+
+(with-test (:name :make-array-symbol-as-initial-element)
+  (assert (every (lambda (x) (eq x 'a))
+                 (funcall
+                  (compile nil
+                           `(lambda ()
+                              (make-array 12 :initial-element 'a)))))))
 \f
 ;;;; tests not in the problem domain, but of the consistency of the
 ;;;; compiler machinery itself

diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index 3620c6d..9e77321 100644 (file)
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -181,9 +181,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))
@@ -535,7 +532,6 @@
     (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

diff --git a/version.lisp-expr b/version.lisp-expr
index 4c4695b..326fa46 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.29.3"
+"1.0.29.4"