1.0.28.58: more MAKE-ARRAY goodness

[sbcl.git] / src / compiler / array-tran.lisp

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index c7481e2..340ce53 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -233,13 +233,19 @@
 
 ;;; 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))
+(define-source-transform make-array (&whole form 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))
-         ,form)))
+         ;; 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))))
 
 ;;; 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
@@ -343,11 +349,14 @@
                     (not (eql default-initial-element (lvar-value initial-element)))))
            (let ((parameters (eliminate-keyword-args
                               call 1 '((:element-type element-type)
-                                       (:initial-element initial-element)))))
+                                       (:initial-element initial-element))))
+                 (init (if (constant-lvar-p initial-element)
+                           (lvar-value initial-element)
+                           'initial-element)))
              `(lambda (length ,@parameters)
                 (declare (ignorable ,@parameters))
                 (truly-the ,result-spec
-                           (fill ,alloc-form (the ,elt-spec initial-element))))))
+                           (fill ,alloc-form (the ,elt-spec ,init))))))
           ;; just :ELEMENT-TYPE, or maybe with :INITIAL-ELEMENT EQL to the
           ;; default
           (t