;;; type is going to be the array upgraded element type.
(defun extract-upgraded-element-type (array)
(let ((type (continuation-type array)))
+ ;; Note that this IF mightn't be satisfied even if the runtime
+ ;; value is known to be a subtype of some specialized ARRAY, because
+ ;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
+ ;; which are represented in the compiler as INTERSECTION-TYPE, not
+ ;; array type.
(if (array-type-p type)
(array-type-specialized-element-type type)
- *universal-type*)))
+ ;; KLUDGE: there is no good answer here, but at least
+ ;; *wild-type* won't cause HAIRY-DATA-VECTOR-{REF,SET} to be
+ ;; erroneously optimized (see generic/vm-tran.lisp) -- CSR,
+ ;; 2002-08-21
+ *wild-type*)))
;;; The ``new-value'' for array setters must fit in the array, and the
;;; return type is going to be the same as the new-value for SETF
(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-specialized-element-type type))))
+ (assert-continuation-type
+ new-value
+ (array-type-specialized-element-type type)
+ (lexenv-policy (node-lexenv (continuation-dest new-value))))))
(continuation-type new-value))
-;;; Return true if Arg is NIL, or is a constant-continuation whose
+(defun assert-array-complex (array)
+ (assert-continuation-type
+ array
+ (make-array-type :complexp t
+ :element-type *wild-type*)
+ (lexenv-policy (node-lexenv (continuation-dest array)))))
+
+;;; Return true if ARG is NIL, or is a constant-continuation whose
;;; value is NIL, false otherwise.
(defun unsupplied-or-nil (arg)
(declare (type (or continuation null) arg))
(defun assert-array-rank (array rank)
(assert-continuation-type
array
- (specifier-type `(array * ,(make-list rank :initial-element '*)))))
+ (specifier-type `(array * ,(make-list rank :initial-element '*)))
+ (lexenv-policy (node-lexenv (continuation-dest array)))))
(defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
(assert-array-rank array (length indices))
;; 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-upgraded-element-type array))))
+ (assert-continuation-type cont (extract-upgraded-element-type array)
+ (lexenv-policy (node-lexenv node)))))
(extract-upgraded-element-type array))
(defoptimizer (%aset derive-type) ((array &rest stuff))
(let ((simple (and (unsupplied-or-nil adjustable)
(unsupplied-or-nil displaced-to)
(unsupplied-or-nil fill-pointer))))
- (specifier-type
- `(,(if simple 'simple-array 'array)
- ,(cond ((not element-type) t)
- ((constant-continuation-p element-type)
- (continuation-value element-type))
- (t
- '*))
- ,(cond ((not simple)
- '*)
- ((constant-continuation-p dims)
- (let ((val (continuation-value dims)))
- (if (listp val) val (list val))))
- ((csubtypep (continuation-type dims)
- (specifier-type 'integer))
- '(*))
- (t
- '*))))))
+ (or (careful-specifier-type
+ `(,(if simple 'simple-array 'array)
+ ,(cond ((not element-type) t)
+ ((constant-continuation-p element-type)
+ (continuation-value element-type))
+ (t
+ '*))
+ ,(cond ((not simple)
+ '*)
+ ((constant-continuation-p dims)
+ (let ((val (continuation-value dims)))
+ (if (listp val) val (list val))))
+ ((csubtypep (continuation-type dims)
+ (specifier-type 'integer))
+ '(*))
+ (t
+ '*))))
+ (specifier-type 'array))))
+
+;;; Complex array operations should assert that their array argument
+;;; is complex. In SBCL, vectors with fill-pointers are complex.
+(defoptimizer (fill-pointer derive-type) ((vector))
+ (assert-array-complex vector))
+(defoptimizer (%set-fill-pointer derive-type) ((vector index))
+ (declare (ignorable index))
+ (assert-array-complex vector))
+
+(defoptimizer (vector-push derive-type) ((object vector))
+ (declare (ignorable object))
+ (assert-array-complex vector))
+(defoptimizer (vector-push-extend derive-type)
+ ((object vector &optional index))
+ (declare (ignorable object index))
+ (assert-array-complex vector))
+(defoptimizer (vector-pop derive-type) ((vector))
+ (assert-array-complex vector))
\f
;;;; constructors
,n-vec))))
;;; Just convert it into a MAKE-ARRAY.
-(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))
+(deftransform 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-)
(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
+ `(;; Erm. Yeah. There aren't a lot of things that make sense
+ ;; for an initial element for (ARRAY NIL). -- CSR, 2002-03-07
+ (nil '#:mu 0 ,sb!vm:simple-array-nil-widetag)
+ (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)
#!+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)
+ ;; KLUDGE: The fact that these UNSIGNED-BYTE entries come
+ ;; before their SIGNED-BYTE partners is significant in the
+ ;; implementation of the compiler; some of the cross-compiler
+ ;; code (see e.g. COERCE-TO-SMALLEST-ELTYPE in
+ ;; src/compiler/debug-dump.lisp) attempts to create an array
+ ;; specialized on (UNSIGNED-BYTE FOO), where FOO could be 7;
+ ;; (UNSIGNED-BYTE 7) is SUBTYPEP (SIGNED-BYTE 8), so if we're
+ ;; not careful we could get the wrong specialized array when
+ ;; we try to FIND-IF, below. -- CSR, 2002-07-08
((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)
,sb!vm:simple-array-complex-long-float-widetag)
(t 0 32 ,sb!vm:simple-vector-widetag))))
+(deftransform make-array ((dims &key initial-element element-type
+ adjustable fill-pointer)
+ (t &rest *))
+ (when (null initial-element)
+ (give-up-ir1-transform))
+ (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))))
+ (eltype-type (ir1-transform-specifier-type eltype))
+ (saetp (find-if (lambda (saetp)
+ (csubtypep eltype-type (saetp-ctype saetp)))
+ *specialized-array-element-type-properties*))
+ (creation-form `(make-array dims
+ :element-type ',(type-specifier (saetp-ctype saetp))
+ ,@(when 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-continuation-p initial-element)
+ (eql (continuation-value initial-element)
+ (saetp-initial-element-default saetp)))
+ creation-form)
+ (t
+ ;; error checking for target, disabled on the host because
+ ;; (CTYPE-OF #\Null) is not possible.
+ #-sb-xc-host
+ (when (constant-continuation-p initial-element)
+ (let ((value (continuation-value initial-element)))
+ (cond
+ ((not (csubtypep (ctype-of value)
+ (saetp-ctype saetp)))
+ ;; this case will cause an error at runtime, so we'd
+ ;; better WARN about it now.
+ (compiler-warn "~@<~S is not a ~S (which is the ~
+ UPGRADED-ARRAY-ELEMENT-TYPE of ~S).~@:>"
+ value
+ (type-specifier (saetp-ctype saetp))
+ eltype))
+ ((not (csubtypep (ctype-of value) eltype-type))
+ ;; this case will not cause an error at runtime, but
+ ;; it's still worth STYLE-WARNing about.
+ (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 initial-element))
+ array)))))
+
;;; 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)
+;;; :DISPLACED-TO keywords ensures that it will be simple; the lack of
+;;; :INITIAL-ELEMENT relies on another transform to deal with that
+;;; kind of initialization efficiently.
+(deftransform make-array ((length &key element-type)
(integer &rest *))
(let* ((eltype (cond ((not element-type) t)
((not (constant-continuation-p element-type))
(continuation-value length)
'*))
(result-type-spec `(simple-array ,eltype (,len)))
- (eltype-type (specifier-type eltype))
+ (eltype-type (ir1-transform-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" result-type-spec))
-
- (let* ((initial-element-default (saetp-initial-element-default saetp))
- (n-bits-per-element (saetp-n-bits saetp))
+ #-sb-xc-host
+ (unless (csubtypep (ctype-of (saetp-initial-element-default saetp))
+ 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-style-warn "The default initial element ~S is not a ~S."
+ (saetp-initial-element-default saetp)
+ eltype))
+ (let* ((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:n-word-bits)
- `(* ,padded-length-form
- (the fixnum ; i.e., not RATIO
- ,(/ 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))))
- (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)))
+ (cond
+ ((= n-bits-per-element 0) 0)
+ ((>= n-bits-per-element sb!vm:n-word-bits)
+ `(* ,padded-length-form
+ (the fixnum ; i.e., not RATIO
+ ,(/ n-bits-per-element sb!vm:n-word-bits))))
+ (t
+ (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))))))
(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))))
+ `(truly-the ,result-type-spec
+ (allocate-vector ,typecode length ,n-words-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,
;;; and displaced-to keywords ensures that it will be simple.
-(deftransform make-array ((dims &key initial-element element-type)
+;;;
+;;; FIXME: should we generalize this transform to non-simple (though
+;;; non-displaced-to) arrays, given that we have %WITH-ARRAY-DATA to
+;;; deal with those? Maybe when the DEFTRANSFORM
+;;; %DATA-VECTOR-AND-INDEX in the VECTOR case problem is solved? --
+;;; CSR, 2002-07-01
+(deftransform make-array ((dims &key element-type)
(list &rest *))
(unless (or (null element-type) (constant-continuation-p element-type))
(give-up-ir1-transform
dims))
(if (= (length dims) 1)
`(make-array ',(car dims)
- ,@(when initial-element
- '(:initial-element initial-element))
,@(when element-type
'(:element-type element-type)))
(let* ((total-size (reduce #'* dims))
(setf (%array-data-vector header)
(make-array ,total-size
,@(when element-type
- '(:element-type element-type))
- ,@(when initial-element
- '(:initial-element initial-element))))
+ '(:element-type element-type))))
(setf (%array-displaced-p header) nil)
,@(let ((axis -1))
(mapcar (lambda (dim)
`(if (<= ,n-svalue ,n-end ,n-len)
;; success
(values ,n-array ,n-svalue ,n-end 0)
- (failed-%with-array-data ,n-array ,n-svalue ,n-evalue))))
+ (failed-%with-array-data ,n-array
+ ,n-svalue
+ ,n-evalue))))
(,(if force-inline '%with-array-data-macro '%with-array-data)
,n-array ,n-svalue ,n-evalue))
,@forms)))
(element-type '*)
unsafe?
fail-inline?)
- (let ((size (gensym "SIZE-"))
- (defaulted-end (gensym "DEFAULTED-END-"))
- (data (gensym "DATA-"))
- (cumulative-offset (gensym "CUMULATIVE-OFFSET-")))
+ (with-unique-names (size defaulted-end data cumulative-offset)
`(let* ((,size (array-total-size ,array))
(,defaulted-end
(cond (,end
(unless (or ,unsafe? (<= ,end ,size))
,(if fail-inline?
- `(error "End ~W is greater than total size ~W."
- ,end ,size)
+ `(error 'bounding-indices-bad-error
+ :datum (cons ,start ,end)
+ :expected-type `(cons (integer 0 ,',size)
+ (integer ,',start ,',size))
+ :object ,array)
`(failed-%with-array-data ,array ,start ,end)))
,end)
(t ,size))))
(unless (or ,unsafe? (<= ,start ,defaulted-end))
,(if fail-inline?
- `(error "Start ~W is greater than end ~W." ,start ,defaulted-end)
+ `(error 'bounding-indices-bad-error
+ :datum (cons ,start ,end)
+ :expected-type `(cons (integer 0 ,',size)
+ (integer ,',start ,',size))
+ :object ,array)
`(failed-%with-array-data ,array ,start ,end)))
(do ((,data ,array (%array-data-vector ,data))
(,cumulative-offset 0
;; haven't tried to understand the
;; performance issues involved. --
;; WHN, and also CSR 2002-05-26
- (simple-array index (or index null))
+ ((or vector simple-array) index (or index null))
*
:important t
:node node
`(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)
(define-frob sbit %sbitset (simple-array bit))
(define-frob bit %bitset (array bit)))
+(macrolet ((define-frob (reffer setter type)
+ `(progn
+ (define-source-transform ,reffer (a i)
+ `(aref (the ,',type ,a) ,i))
+ (define-source-transform ,setter (a i v)
+ `(%aset (the ,',type ,a) ,i ,v)))))
+ (define-frob svref %svset simple-vector)
+ (define-frob schar %scharset simple-string)
+ (define-frob char %charset string))
(macrolet (;; This is a handy macro for computing the row-major index
;; given a set of indices. We wrap each index with a call
projects / sbcl.git / blobdiff