;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the
;;; elements.
(def-source-transform vector (&rest elements)
- (if (byte-compiling)
- (values nil t)
- (let ((len (length elements))
- (n -1))
- (once-only ((n-vec `(make-array ,len)))
- `(progn
- ,@(mapcar #'(lambda (el)
- (once-only ((n-val el))
- `(locally (declare (optimize (safety 0)))
- (setf (svref ,n-vec ,(incf n))
- ,n-val))))
- elements)
- ,n-vec)))))
+ (let ((len (length elements))
+ (n -1))
+ (once-only ((n-vec `(make-array ,len)))
+ `(progn
+ ,@(mapcar #'(lambda (el)
+ (once-only ((n-val el))
+ `(locally (declare (optimize (safety 0)))
+ (setf (svref ,n-vec ,(incf n))
+ ,n-val))))
+ elements)
+ ,n-vec))))
;;; Just convert it into a MAKE-ARRAY.
(def-source-transform make-string (length &key
(element-type ''base-char)
- (initial-element default-init-char))
- (if (byte-compiling)
- (values nil t)
- `(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)))
+ (initial-element
+ '#.*default-init-char-form*))
+ `(make-array (the index ,length)
+ :element-type ,element-type
+ :initial-element ,initial-element))
+
+(defstruct (specialized-array-element-type-properties
+ (:conc-name saetp-)
+ (:constructor !make-saetp (ctype
+ initial-element-default
+ n-bits
+ typecode
+ &key
+ (n-pad-elements 0)))
+ (:copier nil))
+ ;; the element type, e.g. #<BUILT-IN-CLASS BASE-CHAR (sealed)> or
+ ;; #<SB-KERNEL:NUMERIC-TYPE (UNSIGNED-BYTE 4)>
+ (ctype (required-argument) :type ctype :read-only t)
+ ;; what we get when the low-level vector-creation logic zeroes all
+ ;; the bits (which also serves as the default value of MAKE-ARRAY's
+ ;; :INITIAL-ELEMENT keyword)
+ (initial-element-default (required-argument) :read-only t)
+ ;; how many bits per element
+ (n-bits (required-argument) :type index :read-only t)
+ ;; the low-level type code
+ (typecode (required-argument) :type index :read-only t)
+ ;; the number of extra elements we use at the end of the array for
+ ;; low level hackery (e.g., one element for arrays of BASE-CHAR,
+ ;; which is used for a fixed #\NULL so that when we call out to C
+ ;; we don't need to cons a new copy)
+ (n-pad-elements (required-argument) :type index :read-only t))
+
+(defparameter *specialized-array-element-type-properties*
+ (map 'simple-vector
+ (lambda (args)
+ (destructuring-bind (type-spec &rest rest) args
+ (let ((ctype (specifier-type type-spec)))
+ (apply #'!make-saetp ctype rest))))
+ `((base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag
+ ;; (SIMPLE-STRINGs are stored with an extra trailing
+ ;; #\NULL for convenience in calling out to C.)
+ :n-pad-elements 1)
+ (single-float 0.0s0 32 ,sb!vm:simple-array-single-float-widetag)
+ (double-float 0.0d0 64 ,sb!vm:simple-array-double-float-widetag)
+ #!+long-float (long-float 0.0L0 #!+x86 96 #!+sparc 128
+ ,sb!vm:simple-array-long-float-widetag)
+ (bit 0 1 ,sb!vm:simple-bit-vector-widetag)
+ ((unsigned-byte 2) 0 2 ,sb!vm:simple-array-unsigned-byte-2-widetag)
+ ((unsigned-byte 4) 0 4 ,sb!vm:simple-array-unsigned-byte-4-widetag)
+ ((unsigned-byte 8) 0 8 ,sb!vm:simple-array-unsigned-byte-8-widetag)
+ ((unsigned-byte 16) 0 16 ,sb!vm:simple-array-unsigned-byte-16-widetag)
+ ((unsigned-byte 32) 0 32 ,sb!vm:simple-array-unsigned-byte-32-widetag)
+ ((signed-byte 8) 0 8 ,sb!vm:simple-array-signed-byte-8-widetag)
+ ((signed-byte 16) 0 16 ,sb!vm:simple-array-signed-byte-16-widetag)
+ ((signed-byte 30) 0 32 ,sb!vm:simple-array-signed-byte-30-widetag)
+ ((signed-byte 32) 0 32 ,sb!vm:simple-array-signed-byte-32-widetag)
+ ((complex single-float) #C(0.0s0 0.0s0) 64
+ ,sb!vm:simple-array-complex-single-float-widetag)
+ ((complex double-float) #C(0.0d0 0.0d0) 128
+ ,sb!vm:simple-array-complex-double-float-widetag)
+ #!+long-float ((complex long-float) #C(0.0L0 0.0L0)
+ #!+x86 192 #!+sparc 256
+ ,sb!vm:simple-array-complex-long-float-widetag)
+ (t 0 32 ,sb!vm:simple-vector-widetag))))
;;; 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.
+;;; 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)
(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))))))))
+ (result-type-spec `(simple-array ,eltype (,len)))
+ (eltype-type (specifier-type eltype))
+ (saetp (find-if (lambda (saetp)
+ (csubtypep eltype-type (saetp-ctype saetp)))
+ *specialized-array-element-type-properties*)))
+ (unless saetp
+ (give-up-ir1-transform
+ "cannot open-code creation of ~S" spec))
+
+ (let* ((initial-element-default (saetp-initial-element-default saetp))
+ (n-bits-per-element (saetp-n-bits saetp))
+ (typecode (saetp-typecode saetp))
+ (n-pad-elements (saetp-n-pad-elements saetp))
+ (padded-length-form (if (zerop n-pad-elements)
+ 'length
+ `(+ length ,n-pad-elements)))
+ (n-words-form
+ (if (>= n-bits-per-element sb!vm:word-bits)
+ `(* ,padded-length-form
+ (the fixnum ; i.e., not RATIO
+ ,(/ n-bits-per-element sb!vm:word-bits)))
+ (let ((n-elements-per-word (/ sb!vm:word-bits
+ n-bits-per-element)))
+ (declare (type index n-elements-per-word)) ; i.e., not RATIO
+ `(ceiling ,padded-length-form ,n-elements-per-word))))
+ (bare-constructor-form
+ `(truly-the ,result-type-spec
+ (allocate-vector ,typecode length ,n-words-form)))
+ (initial-element-form (if initial-element
+ 'initial-element
+ initial-element-default)))
+ (values
+ (cond (;; Can we skip the FILL step?
+ (or (null initial-element)
+ (and (constant-continuation-p initial-element)
+ (eql (continuation-value initial-element)
+ initial-element-default)))
+ (unless (csubtypep (ctype-of initial-element-default)
+ 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
+ ;; 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.
+ (compiler-note "The default initial element ~S is not a ~S."
+ initial-element-default
+ eltype))
+ bare-constructor-form)
+ (t
+ `(truly-the ,result-type-spec
+ (fill ,bare-constructor-form
+ ,initial-element-form))))
+ '((declare (type index length)))))))
;;; The list type restriction does not ensure that the result will be a
;;; multi-dimensional array. But the lack of adjustable, fill-pointer,
(continuation-value element-type))
(t '*))
,(make-list rank :initial-element '*))))
- `(let ((header (make-array-header sb!vm:simple-array-type ,rank)))
+ `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank)))
(setf (%array-fill-pointer header) ,total-size)
(setf (%array-fill-pointer-p header) nil)
(setf (%array-available-elements header) ,total-size)
(element-type '*)
unsafe?
fail-inline?)
- (/show "in %WITH-ARRAY-DATA-MACRO, yes.." array start end)
(let ((size (gensym "SIZE-"))
(defaulted-end (gensym "DEFAULTED-END-"))
(data (gensym "DATA-"))
(macrolet ((define-frob (reffer setter type)
`(progn
(def-source-transform ,reffer (a &rest i)
- (if (byte-compiling)
- (values nil t)
- `(aref (the ,',type ,a) ,@i)))
+ `(aref (the ,',type ,a) ,@i))
(def-source-transform ,setter (a &rest i)
- (if (byte-compiling)
- (values nil t)
- `(%aset (the ,',type ,a) ,@i))))))
+ `(%aset (the ,',type ,a) ,@i)))))
(define-frob svref %svset simple-vector)
(define-frob schar %scharset simple-string)
(define-frob char %charset string)