Optimize make-array for unknown dimensions.

(make-array x :element-type '(unsigned-byte 8)) went through a costly
procedure of determining what type should be used for
(unsigned-byte 8), but this can be done at compile-time.
That form is now 25 times faster, and only 4 times slower than
(make-array (the integer x) :element-type '(unsigned-byte 8))

diff --git a/NEWS b/NEWS
index 79be5ec..303ebc0 100644 (file)
--- a/NEWS
+++ b/NEWS
@@ -8,6 +8,8 @@ changes relative to sbcl-1.1.14:
     execution.  The previous behaviour can be obtained by instead setting that
     variable to :greedy.  Thanks again to Google for their support, and, more
     crucially, to Alexandra Barchunova for her hard work.
+  * optimization: make-array with known element-type and unkown dimensions is
+    much faster.
   * enhancement: sb-ext:save-lisp-and-die on Windows now accepts
     :application-type argument, which can be :console or :gui. :gui allows
     having GUI applications without an automatically appearing console window.

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index c9204fb..72bf994 100644 (file)
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1369,6 +1369,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "%LASTN/BIGNUM"
                "%LOG1P"
                #!+long-float "%LONG-FLOAT"
+               "%MAKE-ARRAY"
                "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE"
                "%MAKE-FUNCALLABLE-STRUCTURE-INSTANCE-ALLOCATOR"
                "%MAKE-RATIO" "%MAKE-LISP-OBJ"

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 02425d1..e367539 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -106,32 +106,16 @@
                             ,(sb!vm:saetp-n-bits saetp))))
                 sb!vm:*specialized-array-element-type-properties*)))))
 
-(defun %complex-vector-widetag (type)
-  (case type
-    ;; Pick off some easy common cases.
-    ((t)
-     #.sb!vm:complex-vector-widetag)
-    ((base-char #!-sb-unicode character)
-     #.sb!vm:complex-base-string-widetag)
-    #!+sb-unicode
-    ((character)
-     #.sb!vm:complex-character-string-widetag)
-    ((nil)
-     #.sb!vm:complex-vector-nil-widetag)
-    ((bit)
-     #.sb!vm:complex-bit-vector-widetag)
-    ;; OK, we have to wade into SUBTYPEPing after all.
-    (t
-     (pick-vector-type type
-       (nil #.sb!vm:complex-vector-nil-widetag)
-       #!-sb-unicode
-       (character #.sb!vm:complex-base-string-widetag)
-       #!+sb-unicode
-       (base-char #.sb!vm:complex-base-string-widetag)
-       #!+sb-unicode
-       (character #.sb!vm:complex-character-string-widetag)
-       (bit #.sb!vm:complex-bit-vector-widetag)
-       (t #.sb!vm:complex-vector-widetag)))))
+(defun %complex-vector-widetag (widetag)
+  (macrolet ((make-case ()
+               `(case widetag
+                  ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
+                          for complex = (sb!vm:saetp-complex-typecode saetp)
+                          when complex
+                          collect (list (sb!vm:saetp-typecode saetp) complex))
+                  (t
+                   #.sb!vm:complex-vector-widetag))))
+    (make-case)))
 
 (defglobal %%simple-array-n-bits%% (make-array (1+ sb!vm:widetag-mask)))
 #.(loop for info across sb!vm:*specialized-array-element-type-properties*
@@ -155,101 +139,131 @@
                          n-bits)
                       sb!vm:n-word-bits))))
 
-(defun make-array (dimensions &key
-                              (element-type t)
-                              (initial-element nil initial-element-p)
-                              (initial-contents nil initial-contents-p)
-                              adjustable fill-pointer
-                              displaced-to displaced-index-offset)
+(defun array-underlying-widetag (array)
+  (macrolet ((make-case ()
+               `(case widetag
+                  ,@(loop for saetp across sb!vm:*specialized-array-element-type-properties*
+                          for complex = (sb!vm:saetp-complex-typecode saetp)
+                          when complex
+                          collect (list complex (sb!vm:saetp-typecode saetp)))
+                  ((,sb!vm:simple-array-widetag
+                    ,sb!vm:complex-vector-widetag
+                    ,sb!vm:complex-array-widetag)
+                   (with-array-data ((array array) (start) (end))
+                     (declare (ignore start end))
+                     (widetag-of array)))
+                  (t
+                   widetag))))
+    (let ((widetag (widetag-of array)))
+      (make-case))))
+
+;;; Widetag is the widetag of the underlying vector,
+;;; it'll be the same as the resulting array widetag only for simple vectors
+(defun %make-array (dimensions widetag n-bits
+                    &key
+                      element-type
+                      (initial-element nil initial-element-p)
+                      (initial-contents nil initial-contents-p)
+                      adjustable fill-pointer
+                      displaced-to displaced-index-offset)
+  (declare (ignore element-type))
   (let* ((dimensions (if (listp dimensions) dimensions (list dimensions)))
          (array-rank (length (the list dimensions)))
          (simple (and (null fill-pointer)
                       (not adjustable)
                       (null displaced-to))))
     (declare (fixnum array-rank))
-    (when (and displaced-index-offset (null displaced-to))
-      (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
-    (when (and displaced-to
-               (arrayp displaced-to)
-               (not (equal (array-element-type displaced-to)
-                           (upgraded-array-element-type element-type))))
-      (error "Array element type of :DISPLACED-TO array does not match specified element type"))
-    (if (and simple (= array-rank 1))
-        ;; it's a (SIMPLE-ARRAY * (*))
-        (multiple-value-bind (type n-bits)
-            (%vector-widetag-and-n-bits element-type)
-          (declare (type (unsigned-byte 8) type)
-                   (type (integer 0 256) n-bits))
-          (let* ((length (car dimensions))
-                 (array (allocate-vector-with-widetag type length n-bits)))
-            (declare (type index length))
-            (when initial-element-p
-              (fill array initial-element))
-            (when initial-contents-p
-              (when initial-element-p
-                (error "can't specify both :INITIAL-ELEMENT and ~
+    (cond ((and displaced-index-offset (null displaced-to))
+           (error "can't specify :DISPLACED-INDEX-OFFSET without :DISPLACED-TO"))
+          ((and simple (= array-rank 1))
+           ;; it's a (SIMPLE-ARRAY * (*))
+           (let* ((length (car dimensions))
+                  (array (allocate-vector-with-widetag widetag length n-bits)))
+             (declare (type index length))
+             (when initial-element-p
+               (fill array initial-element))
+             (when initial-contents-p
+               (when initial-element-p
+                 (error "can't specify both :INITIAL-ELEMENT and ~
                        :INITIAL-CONTENTS"))
-              (unless (= length (length initial-contents))
-                (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
+               (unless (= length (length initial-contents))
+                 (error "There are ~W elements in the :INITIAL-CONTENTS, but ~
                        the vector length is ~W."
-                       (length initial-contents)
-                       length))
-              (replace array initial-contents))
-            array))
-        ;; it's either a complex array or a multidimensional array.
-        (let* ((total-size (reduce #'* dimensions))
-               (data (or displaced-to
-                         (data-vector-from-inits
-                          dimensions total-size element-type nil
-                          initial-contents initial-contents-p
-                          initial-element initial-element-p)))
-               (array (make-array-header
-                       (cond ((= array-rank 1)
-                              (%complex-vector-widetag element-type))
-                             (simple sb!vm:simple-array-widetag)
-                             (t sb!vm:complex-array-widetag))
-                       array-rank)))
-          (cond (fill-pointer
-                 (unless (= array-rank 1)
-                   (error "Only vectors can have fill pointers."))
-                 (let ((length (car dimensions)))
-                   (declare (fixnum length))
-                   (setf (%array-fill-pointer array)
-                     (cond ((eq fill-pointer t)
-                            length)
-                           (t
-                            (unless (and (fixnump fill-pointer)
-                                         (>= fill-pointer 0)
-                                         (<= fill-pointer length))
-                              ;; FIXME: should be TYPE-ERROR?
-                              (error "invalid fill-pointer ~W"
-                                     fill-pointer))
-                            fill-pointer))))
-                 (setf (%array-fill-pointer-p array) t))
-                (t
-                 (setf (%array-fill-pointer array) total-size)
-                 (setf (%array-fill-pointer-p array) nil)))
-          (setf (%array-available-elements array) total-size)
-          (setf (%array-data-vector array) data)
-          (setf (%array-displaced-from array) nil)
-          (cond (displaced-to
-                 (when (or initial-element-p initial-contents-p)
-                   (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
+                        (length initial-contents)
+                        length))
+               (replace array initial-contents))
+             array))
+          ((and (arrayp displaced-to)
+                (/= (array-underlying-widetag displaced-to) widetag))
+           (error "Array element type of :DISPLACED-TO array does not match specified element type"))
+          (t
+           ;; it's either a complex array or a multidimensional array.
+           (let* ((total-size (reduce #'* dimensions))
+                  (data (or displaced-to
+                            (data-vector-from-inits
+                             dimensions total-size nil widetag n-bits
+                             initial-contents initial-contents-p
+                             initial-element initial-element-p)))
+                  (array (make-array-header
+                          (cond ((= array-rank 1)
+                                 (%complex-vector-widetag widetag))
+                                (simple sb!vm:simple-array-widetag)
+                                (t sb!vm:complex-array-widetag))
+                          array-rank)))
+             (cond (fill-pointer
+                    (unless (= array-rank 1)
+                      (error "Only vectors can have fill pointers."))
+                    (let ((length (car dimensions)))
+                      (declare (fixnum length))
+                      (setf (%array-fill-pointer array)
+                            (cond ((eq fill-pointer t)
+                                   length)
+                                  (t
+                                   (unless (and (fixnump fill-pointer)
+                                                (>= fill-pointer 0)
+                                                (<= fill-pointer length))
+                                     ;; FIXME: should be TYPE-ERROR?
+                                     (error "invalid fill-pointer ~W"
+                                            fill-pointer))
+                                   fill-pointer))))
+                    (setf (%array-fill-pointer-p array) t))
+                   (t
+                    (setf (%array-fill-pointer array) total-size)
+                    (setf (%array-fill-pointer-p array) nil)))
+             (setf (%array-available-elements array) total-size)
+             (setf (%array-data-vector array) data)
+             (setf (%array-displaced-from array) nil)
+             (cond (displaced-to
+                    (when (or initial-element-p initial-contents-p)
+                      (error "Neither :INITIAL-ELEMENT nor :INITIAL-CONTENTS ~
                    can be specified along with :DISPLACED-TO"))
-                 (let ((offset (or displaced-index-offset 0)))
-                   (when (> (+ offset total-size)
-                            (array-total-size displaced-to))
-                     (error "~S doesn't have enough elements." displaced-to))
-                   (setf (%array-displacement array) offset)
-                   (setf (%array-displaced-p array) t)
-                   (%save-displaced-array-backpointer array data)))
-                (t
-                 (setf (%array-displaced-p array) nil)))
-          (let ((axis 0))
-            (dolist (dim dimensions)
-              (setf (%array-dimension array axis) dim)
-              (incf axis)))
-          array))))
+                    (let ((offset (or displaced-index-offset 0)))
+                      (when (> (+ offset total-size)
+                               (array-total-size displaced-to))
+                        (error "~S doesn't have enough elements." displaced-to))
+                      (setf (%array-displacement array) offset)
+                      (setf (%array-displaced-p array) t)
+                      (%save-displaced-array-backpointer array data)))
+                   (t
+                    (setf (%array-displaced-p array) nil)))
+             (let ((axis 0))
+               (dolist (dim dimensions)
+                 (setf (%array-dimension array axis) dim)
+                 (incf axis)))
+             array)))))
+
+(defun make-array (dimensions &rest args
+                   &key (element-type t)
+                        initial-element initial-contents
+                        adjustable
+                        fill-pointer
+                        displaced-to
+                        displaced-index-offset)
+  (declare (ignore initial-element
+                   initial-contents adjustable
+                   fill-pointer displaced-to displaced-index-offset))
+  (multiple-value-bind (widetag n-bits) (%vector-widetag-and-n-bits element-type)
+    (apply #'%make-array dimensions widetag n-bits args)))
 
 (defun make-static-vector (length &key
                            (element-type '(unsigned-byte 8))
@@ -301,18 +315,21 @@ of specialized arrays is supported."
 ;;; to FILL-DATA-VECTOR for error checking on the structure of
 ;;; initial-contents.
 (defun data-vector-from-inits (dimensions total-size
-                               element-type widetag
+                               element-type widetag n-bits
                                initial-contents initial-contents-p
                                initial-element initial-element-p)
   (when initial-element-p
     (when initial-contents-p
       (error "cannot supply both :INITIAL-CONTENTS and :INITIAL-ELEMENT to
             either MAKE-ARRAY or ADJUST-ARRAY."))
-    (unless (typep initial-element element-type)
-      (error "~S cannot be used to initialize an array of type ~S."
-             initial-element element-type)))
+    ;; FIXME: element-type can be NIL when widetag is non-nil,
+    ;; and FILL will check the type, although the error will be not as nice.
+    ;; (cond (typep initial-element element-type)
+    ;;   (error "~S cannot be used to initialize an array of type ~S."
+    ;;          initial-element element-type))
+    )
   (let ((data (if widetag
-                  (allocate-vector-with-widetag widetag total-size)
+                  (allocate-vector-with-widetag widetag total-size n-bits)
                   (make-array total-size :element-type element-type))))
     (cond (initial-element-p
            (fill (the vector data) initial-element))
@@ -869,7 +886,7 @@ of specialized arrays is supported."
                          the :INITIAL-ELEMENT or :DISPLACED-TO option."))
              (let* ((array-size (apply #'* dimensions))
                     (array-data (data-vector-from-inits
-                                 dimensions array-size element-type nil
+                                 dimensions array-size element-type nil nil
                                  initial-contents initial-contents-p
                                  initial-element initial-element-p)))
                (if (adjustable-array-p array)
@@ -923,7 +940,7 @@ of specialized arrays is supported."
                         (setf new-data
                               (data-vector-from-inits
                                dimensions new-length element-type
-                               (widetag-of old-data)
+                               (widetag-of old-data) nil
                                initial-contents initial-contents-p
                                initial-element initial-element-p))
                         ;; Provide :END1 to avoid full call to LENGTH
@@ -952,7 +969,8 @@ of specialized arrays is supported."
                                      (data-vector-from-inits
                                       dimensions new-length
                                       element-type
-                                      (widetag-of old-data) () nil
+                                      (widetag-of old-data) nil
+                                      () nil
                                       initial-element initial-element-p)
                                      old-data)))
                    (if (or (zerop old-length) (zerop new-length))

diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp
index 14b2fa5..c44afb4 100644 (file)
--- a/src/compiler/array-tran.lisp
+++ b/src/compiler/array-tran.lisp
@@ -280,15 +280,16 @@
 (defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
   (assert-new-value-type new-value array))
 
-(defoptimizer (make-array derive-type)
-              ((dims &key initial-element element-type initial-contents
-                adjustable fill-pointer displaced-index-offset displaced-to))
+(defun derive-make-array-type (dims element-type adjustable
+                               fill-pointer displaced-to)
   (let* ((simple (and (unsupplied-or-nil adjustable)
                       (unsupplied-or-nil displaced-to)
                       (unsupplied-or-nil fill-pointer)))
          (spec
-          (or `(,(if simple 'simple-array 'array)
+           (or `(,(if simple 'simple-array 'array)
                  ,(cond ((not element-type) t)
+                        ((ctype-p element-type)
+                         (type-specifier element-type))
                         ((constant-lvar-p element-type)
                          (let ((ctype (careful-specifier-type
                                        (lvar-value element-type))))
@@ -309,13 +310,31 @@
                          '(*))
                         (t
                          '*)))
-              'array)))
+               'array)))
     (if (and (not simple)
              (or (supplied-and-true adjustable)
                  (supplied-and-true displaced-to)
                  (supplied-and-true fill-pointer)))
         (careful-specifier-type `(and ,spec (not simple-array)))
         (careful-specifier-type spec))))
+
+(defoptimizer (make-array derive-type)
+    ((dims &key element-type adjustable fill-pointer displaced-to))
+  (derive-make-array-type dims element-type adjustable
+                          fill-pointer displaced-to))
+
+(defoptimizer (%make-array derive-type)
+    ((dims widetag n-bits &key adjustable fill-pointer displaced-to))
+  (declare (ignore n-bits))
+  (let ((saetp (and (constant-lvar-p widetag)
+                    (find (lvar-value widetag)
+                          sb!vm:*specialized-array-element-type-properties*
+                          :key #'sb!vm:saetp-typecode))))
+    (derive-make-array-type dims (if saetp
+                                     (sb!vm:saetp-ctype saetp)
+                                     *wild-type*)
+                            adjustable fill-pointer displaced-to)))
+
 \f
 ;;;; constructors
 
@@ -524,9 +543,9 @@
 
 (deftransform make-array ((dims &key initial-element element-type
                                      adjustable fill-pointer)
-                          (t &rest *))
-  (when (null initial-element)
-    (give-up-ir1-transform))
+                          (t &rest *) *
+                          :node node)
+  (delay-ir1-transform node :constraint)
   (let* ((eltype (cond ((not element-type) t)
                        ((not (constant-lvar-p element-type))
                         (give-up-ir1-transform
@@ -534,22 +553,28 @@
                        (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))
+         (saetp (if (unknown-type-p eltype-type)
+                    (give-up-ir1-transform
+                     "ELEMENT-TYPE ~s is not a known type"
+                     eltype-type)
+                    (find eltype-type
+                          sb!vm:*specialized-array-element-type-properties*
+                          :key #'sb!vm:saetp-ctype
+                          :test #'csubtypep)))
+         (creation-form `(%make-array
+                          dims
+                          ,(if saetp
+                               (sb!vm:saetp-typecode saetp)
+                               (give-up-ir1-transform))
+                          ,(sb!vm:saetp-n-bits saetp)
                           ,@(when fill-pointer
-                                  '(:fill-pointer 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)))
+                              '(:adjustable adjustable)))))
+    (cond ((or (not initial-element)
+               (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
@@ -576,10 +601,10 @@
                   (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)))))
+              (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,

diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index 9fadaf9..f3a08f0 100644 (file)
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -875,7 +875,20 @@
                       (:fill-pointer t)
                       (:displaced-to (or array null))
                       (:displaced-index-offset index))
-  array (flushable))
+  array (flushable explicit-check))
+
+(defknown %make-array ((or index list)
+                       (unsigned-byte #.sb!vm:n-widetag-bits)
+                       (unsigned-byte 16)
+                       &key
+                       (:element-type type-specifier)
+                       (:initial-element t)
+                       (:initial-contents t)
+                       (:adjustable t)
+                       (:fill-pointer t)
+                       (:displaced-to (or array null))
+                       (:displaced-index-offset index))
+    array (flushable))
 
 (defknown vector (&rest t) simple-vector (flushable))