- `(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 *))
- (let* ((eltype (cond ((not element-type) t)
- ((not (constant-continuation-p element-type))
- (give-up-ir1-transform
- "ELEMENT-TYPE is not constant."))
- (t
- (continuation-value element-type))))
- (len (if (constant-continuation-p length)
- (continuation-value length)
- '*))
- (spec `(simple-array ,eltype (,len)))
- (eltype-type (specifier-type eltype)))
- (multiple-value-bind (default-initial-element element-size typecode)
- (dovector (info *array-info*
- (give-up-ir1-transform
- "cannot open-code creation of ~S" spec))
- (when (csubtypep eltype-type (specifier-type (car info)))
- (return (values-list (cdr info)))))
- (let* ((nwords-form
- (if (>= element-size sb!vm:word-bits)
- `(* length ,(/ element-size sb!vm:word-bits))
- (let ((elements-per-word (/ 32 element-size)))
- `(truncate (+ length
- ,(if (eq 'sb!vm:simple-string-type typecode)
- ;; (Simple strings are stored with an
- ;; extra trailing null for convenience
- ;; in calling out to C.)
- elements-per-word
- (1- elements-per-word)))
- ,elements-per-word))))
- (constructor
- `(truly-the ,spec
- (allocate-vector ,typecode length ,nwords-form))))
- (values
- (cond ((and default-initial-element
- (or (null initial-element)
- (and (constant-continuation-p initial-element)
- (eql (continuation-value initial-element)
- default-initial-element))))
- (unless (csubtypep (ctype-of default-initial-element)
- 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 before he reads, we'll signal a
- ;; STYLE-WARNING in case he didn't realize this.
- ;;
- ;; FIXME: should be STYLE-WARNING, not note
- (compiler-note "The default initial element ~S is not a ~S."
- default-initial-element
- eltype))
- constructor)
- (t
- `(truly-the ,spec (fill ,constructor initial-element))))
- '((declare (type index length))))))))
+ `(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)
+ (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)))))
+ `(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))