- `(make-array (the index ,length)
- :element-type ,element-type
- :initial-element ,initial-element)))
-
-(defparameter *array-info*
- #((base-char #.default-init-char 8 sb!vm:simple-string-type)
- (single-float 0.0s0 32 sb!vm:simple-array-single-float-type)
- (double-float 0.0d0 64 sb!vm:simple-array-double-float-type)
- #!+long-float (long-float 0.0l0 #!+x86 96 #!+sparc 128
- sb!vm:simple-array-long-float-type)
- (bit 0 1 sb!vm:simple-bit-vector-type)
- ((unsigned-byte 2) 0 2 sb!vm:simple-array-unsigned-byte-2-type)
- ((unsigned-byte 4) 0 4 sb!vm:simple-array-unsigned-byte-4-type)
- ((unsigned-byte 8) 0 8 sb!vm:simple-array-unsigned-byte-8-type)
- ((unsigned-byte 16) 0 16 sb!vm:simple-array-unsigned-byte-16-type)
- ((unsigned-byte 32) 0 32 sb!vm:simple-array-unsigned-byte-32-type)
- ((signed-byte 8) 0 8 sb!vm:simple-array-signed-byte-8-type)
- ((signed-byte 16) 0 16 sb!vm:simple-array-signed-byte-16-type)
- ((signed-byte 30) 0 32 sb!vm:simple-array-signed-byte-30-type)
- ((signed-byte 32) 0 32 sb!vm:simple-array-signed-byte-32-type)
- ((complex single-float) #C(0.0s0 0.0s0) 64
- sb!vm:simple-array-complex-single-float-type)
- ((complex double-float) #C(0.0d0 0.0d0) 128
- sb!vm:simple-array-complex-double-float-type)
- #!+long-float
- ((complex long-float) #C(0.0l0 0.0l0) #!+x86 192 #!+sparc 256
- sb!vm:simple-array-complex-long-float-type)
- (t 0 32 sb!vm:simple-vector-type)))
-
-;;; 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.
-(deftransform make-array ((length &key initial-element element-type)
- (integer &rest *))
+ `(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))))
+
+;;; 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))))
+ (init (if (constant-lvar-p initial-element)
+ (list 'quote (lvar-value initial-element))
+ 'initial-element)))
+ `(lambda (length ,@parameters)
+ (declare (ignorable ,@parameters))
+ (truly-the ,result-spec
+ (fill ,alloc-form (the ,elt-spec ,init))))))
+ ;; 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)
+ (:initial-element initial-element)))))
+ `(lambda (length ,@parameters)
+ (declare (ignorable ,@parameters))
+ ,alloc-form))))))
+
+;;; 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))