element-type-specifier)))
;;; Array access functions return an object from the array, hence its
-;;; type will be asserted to be array element type.
-(defun extract-element-type (array)
- (let ((type (continuation-type array)))
- (if (array-type-p type)
- (array-type-element-type type)
- *universal-type*)))
-
-;;; Array access functions return an object from the array, hence its
;;; type is going to be the array upgraded element type.
(defun extract-upgraded-element-type (array)
(let ((type (continuation-type array)))
(defun assert-new-value-type (new-value array)
(let ((type (continuation-type array)))
(when (array-type-p type)
- (assert-continuation-type new-value (array-type-element-type type))))
+ (assert-continuation-type new-value (array-type-specialized-element-type type))))
(continuation-type new-value))
;;; Return true if Arg is NIL, or is a constant-continuation whose
;; If the node continuation has a single use then assert its type.
(let ((cont (node-cont node)))
(when (= (length (find-uses cont)) 1)
- (assert-continuation-type cont (extract-element-type array))))
+ (assert-continuation-type cont (extract-upgraded-element-type array))))
(extract-upgraded-element-type array))
(defoptimizer (%aset derive-type) ((array &rest stuff))
(when (array-type-p atype)
(values-specifier-type
`(values (simple-array ,(type-specifier
- (array-type-element-type atype))
+ (array-type-specialized-element-type atype))
(*))
index index index)))))
;;; 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)))))
+(define-source-transform vector (&rest elements)
+ (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)))
+(define-source-transform make-string (length &key
+ (element-type ''base-char)
+ (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
- low-level-initial-element-default
+ initial-element-default
n-bits
typecode
&key
- (n-pad-elements 0)
- (high-level-initial-element-default
- low-level-initial-element-default)))
+ (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
- (low-level-initial-element-default (required-argument) :read-only t)
- ;; the high level default value. The distinction between this and
- ;; the low-level default can be illustrated for strings of ASCII
- ;; characters. The low-level default is #\NULL (i.e. CHAR-CODE = 0)
- ;; because the array, like other arrays, is born zeroed. However, we
- ;; don't like that as a high level default because it's not a
- ;; STANDARD-CHAR, so we use something else (e.g. #\SPACE) instead.
- (high-level-initial-element-default (required-argument) :read-only t)
+ (ctype (missing-arg) :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 (missing-arg) :read-only t)
;; how many bits per element
- (n-bits (required-argument) :type index :read-only t)
+ (n-bits (missing-arg) :type index :read-only t)
;; the low-level type code
- (typecode (required-argument) :type index :read-only t)
+ (typecode (missing-arg) :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))
+ (n-pad-elements (missing-arg) :type index :read-only t))
(defparameter *specialized-array-element-type-properties*
(map 'simple-vector
(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-type
+ `((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
- ;; #\NULL is set automatically by the low-level
- ;; logic, but that's a little distasteful as a
- ;; high-level default because it's not a
- ;; STANDARD-CHAR, so use #\SPACE instead.
- :high-level-initial-element-default #\space)
- (single-float 0.0s0 32 ,sb!vm:simple-array-single-float-type)
- (double-float 0.0d0 64 ,sb!vm:simple-array-double-float-type)
+ :n-pad-elements 1)
+ (single-float 0.0f0 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-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)
+ ,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.0f0 0.0f0) 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-type)
+ ,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-type)
- (t 0 32 ,sb!vm:simple-vector-type
- :high-level-initial-element-default nil))))
+ ,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)))
+ (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* (;; FIXME: This is basically a literal translation of the
- ;; old CMU CL code, which made no distinction between low-
- ;; and high-level default initial elements (hence bug 126),
- ;; so we just drop the high-level default initial element
- ;; on the floor here (hence bug 126 remains).
- (default-initial-element
- (saetp-low-level-initial-element-default saetp))
+ "cannot open-code creation of ~S" result-type-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))
'length
`(+ length ,n-pad-elements)))
(n-words-form
- (if (>= n-bits-per-element sb!vm:word-bits)
+ (if (>= n-bits-per-element sb!vm:n-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 sb!vm:n-word-bits)))
+ (let ((n-elements-per-word (/ sb!vm:n-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))))
- (constructor
- `(truly-the ,spec
- (allocate-vector ,typecode length ,n-words-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)))))))
+ (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)
'(:initial-element initial-element))))
(setf (%array-displaced-p header) nil)
,@(let ((axis -1))
- (mapcar #'(lambda (dim)
- `(setf (%array-dimension header ,(incf axis))
- ,dim))
+ (mapcar (lambda (dim)
+ `(setf (%array-dimension header ,(incf axis))
+ ,dim))
dims))
(truly-the ,spec header))))))
\f
(give-up-ir1-transform
"The array dimensions are unknown; must call ARRAY-DIMENSION at runtime."))
(unless (> (length dims) axis)
- (abort-ir1-transform "The array has dimensions ~S, ~D is too large."
+ (abort-ir1-transform "The array has dimensions ~S, ~W is too large."
dims
axis))
(let ((dim (nth axis dims)))
(cond (,end
(unless (or ,unsafe? (<= ,end ,size))
,(if fail-inline?
- `(error "End ~D is greater than total size ~D."
+ `(error "End ~W is greater than total size ~W."
,end ,size)
`(failed-%with-array-data ,array ,start ,end)))
,end)
(t ,size))))
(unless (or ,unsafe? (<= ,start ,defaulted-end))
,(if fail-inline?
- `(error "Start ~D is greater than end ~D." ,start ,defaulted-end)
+ `(error "Start ~W is greater than end ~W." ,start ,defaulted-end)
`(failed-%with-array-data ,array ,start ,end)))
(do ((,data ,array (%array-data-vector ,data))
(,cumulative-offset 0
;;; assertions on the array.
(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)))
- (def-source-transform ,setter (a &rest i)
- (if (byte-compiling)
- (values nil t)
- `(%aset (the ,',type ,a) ,@i))))))
+ (define-source-transform ,reffer (a &rest i)
+ `(aref (the ,',type ,a) ,@i))
+ (define-source-transform ,setter (a &rest i)
+ `(%aset (the ,',type ,a) ,@i)))))
(define-frob svref %svset simple-vector)
(define-frob schar %scharset simple-string)
(define-frob char %charset string)
;;;; and eliminates the need for any VM-dependent transforms to handle
;;;; these cases.
-(dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1
- bit-andc2 bit-orc1 bit-orc2))
- ;; Make a result array if result is NIL or unsupplied.
- (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array)
- '(bit-vector bit-vector &optional null) '*
- :eval-name t
- :policy (>= speed space))
- `(,fun bit-array-1 bit-array-2
- (make-array (length bit-array-1) :element-type 'bit)))
- ;; If result is T, make it the first arg.
- (deftransform fun ((bit-array-1 bit-array-2 result-bit-array)
- '(bit-vector bit-vector (member t)) '*
- :eval-name t)
- `(,fun bit-array-1 bit-array-2 bit-array-1)))
+(macrolet ((def (fun)
+ `(progn
+ (deftransform ,fun ((bit-array-1 bit-array-2
+ &optional result-bit-array)
+ (bit-vector bit-vector &optional null) *
+ :policy (>= speed space))
+ `(,',fun bit-array-1 bit-array-2
+ (make-array (length bit-array-1) :element-type 'bit)))
+ ;; If result is T, make it the first arg.
+ (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array)
+ (bit-vector bit-vector (member t)) *)
+ `(,',fun bit-array-1 bit-array-2 bit-array-1)))))
+ (def bit-and)
+ (def bit-ior)
+ (def bit-xor)
+ (def bit-eqv)
+ (def bit-nand)
+ (def bit-nor)
+ (def bit-andc1)
+ (def bit-andc2)
+ (def bit-orc1)
+ (def bit-orc2))
;;; Similar for BIT-NOT, but there is only one arg...
(deftransform bit-not ((bit-array-1 &optional result-bit-array)
'(bit-not bit-array-1
(make-array (length bit-array-1) :element-type 'bit)))
(deftransform bit-not ((bit-array-1 result-bit-array)
- (bit-vector (constant-argument t)))
+ (bit-vector (constant-arg t)))
'(bit-not bit-array-1 bit-array-1))
-;;; FIXME: What does (CONSTANT-ARGUMENT T) mean? Is it the same thing
-;;; as (CONSTANT-ARGUMENT (MEMBER T)), or does it mean any constant
+;;; FIXME: What does (CONSTANT-ARG T) mean? Is it the same thing
+;;; as (CONSTANT-ARG (MEMBER T)), or does it mean any constant
;;; value?
\f
;;; Pick off some constant cases.
(deftransform array-header-p ((array) (array))
(let ((type (continuation-type array)))
- (declare (optimize (safety 3)))
(unless (array-type-p type)
(give-up-ir1-transform))
(let ((dims (array-type-dimensions type)))
(cond ((csubtypep type (specifier-type '(simple-array * (*))))
- ;; No array header.
+ ;; no array header
nil)
((and (listp dims) (> (length dims) 1))
- ;; Multi-dimensional array, will have a header.
+ ;; multi-dimensional array, will have a header
t)
(t
(give-up-ir1-transform))))))
projects / sbcl.git / blobdiff