"upgraded array element type not known at compile time")
element-type-specifier)))
-;;; Array access functions return an object from the array, hence its
-;;; type is going to be the array upgraded element type.
+;;; Array access functions return an object from the array, hence its type is
+;;; going to be the array upgraded element type. Secondary return value is the
+;;; known supertype of the upgraded-array-element-type, if if the exact
+;;; U-A-E-T is not known. (If it is NIL, the primary return value is as good
+;;; as it gets.)
(defun extract-upgraded-element-type (array)
(let ((type (lvar-type array)))
(cond
;; we can have values declared e.g. (AND SIMPLE-VECTOR UNKNOWN-TYPE),
;; which are represented in the compiler as INTERSECTION-TYPE, not
;; array type.
- ((array-type-p type) (array-type-specialized-element-type type))
- ;; fix for bug #396. This type logic corresponds to the special
- ;; case for strings in HAIRY-DATA-VECTOR-REF
- ;; (generic/vm-tran.lisp)
- ((csubtypep type (specifier-type 'simple-string))
+ ((array-type-p type)
+ (values (array-type-specialized-element-type type) nil))
+ ;; fix for bug #396. This type logic corresponds to the special case for
+ ;; strings in HAIRY-DATA-VECTOR-REF (generic/vm-tran.lisp)
+ ((csubtypep type (specifier-type 'string))
(cond
- ((csubtypep type (specifier-type '(simple-array character (*))))
- (specifier-type 'character))
+ ((csubtypep type (specifier-type '(array character (*))))
+ (values (specifier-type 'character) nil))
#!+sb-unicode
- ((csubtypep type (specifier-type '(simple-array base-char (*))))
- (specifier-type 'base-char))
- ((csubtypep type (specifier-type '(simple-array nil (*))))
- *empty-type*)
- ;; see KLUDGE below.
- (t *wild-type*)))
+ ((csubtypep type (specifier-type '(array base-char (*))))
+ (values (specifier-type 'base-char) nil))
+ ((csubtypep type (specifier-type '(array nil (*))))
+ (values *empty-type* nil))
+ (t
+ ;; See KLUDGE below.
+ (values *wild-type* (specifier-type 'character)))))
(t
;; 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*))))
+ (values *wild-type* nil)))))
(defun extract-declared-element-type (array)
(let ((type (lvar-type array)))
(specifier-type `(array * ,(make-list rank :initial-element '*)))
(lexenv-policy (node-lexenv (lvar-dest array)))))
+(defun derive-aref-type (array)
+ (multiple-value-bind (uaet other) (extract-upgraded-element-type array)
+ (or other uaet)))
+
(defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
(assert-array-rank array (length indices))
*universal-type*)
(defoptimizer (aref derive-type) ((array &rest indices) node)
(assert-array-rank array (length indices))
- (extract-upgraded-element-type array))
+ (derive-aref-type array))
(defoptimizer (%aset derive-type) ((array &rest stuff))
(assert-array-rank array (1- (length stuff)))
(macrolet ((define (name)
`(defoptimizer (,name derive-type) ((array index))
- (extract-upgraded-element-type array))))
+ (derive-aref-type array))))
(define hairy-data-vector-ref)
(define hairy-data-vector-ref/check-bounds)
(define data-vector-ref))
#!+(or x86 x86-64)
(defoptimizer (data-vector-ref-with-offset derive-type) ((array index offset))
- (extract-upgraded-element-type array))
+ (derive-aref-type array))
(macrolet ((define (name)
`(defoptimizer (,name derive-type) ((array index new-value))
*universal-type*)
(defoptimizer (row-major-aref derive-type) ((array index))
- (extract-upgraded-element-type array))
+ (derive-aref-type array))
(defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
(assert-new-value-type new-value array))
(once-only ((n-array array)
(n-svalue `(the index ,svalue))
(n-evalue `(the (or index null) ,evalue)))
- (let ((check-bounds (policy env (= 0 insert-array-bounds-checks))))
+ (let ((check-bounds (policy env (plusp insert-array-bounds-checks))))
`(multiple-value-bind (,data-var
,start-var
,end-var
`(array-total-size ,n-array)))
(n-end `(or ,n-evalue ,n-len)))
(if check-bounds
- `(values ,n-array ,n-svalue ,n-end 0)
- `(if (<= ,n-svalue ,n-end ,n-len)
+ `(if (<= 0 ,n-svalue ,n-end ,n-len)
(values ,n-array ,n-svalue ,n-end 0)
,(if check-fill-pointer
`(sequence-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)
- `(array-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue))))))
+ `(array-bounding-indices-bad-error ,n-array ,n-svalue ,n-evalue)))
+ `(values ,n-array ,n-svalue ,n-end 0))))
,(if force-inline
`(%with-array-data-macro ,n-array ,n-svalue ,n-evalue
:check-bounds ,check-bounds
(defun transform-%with-array-data/muble (array node check-fill-pointer)
(let ((element-type (upgraded-element-type-specifier-or-give-up array))
- (type (lvar-type array)))
+ (type (lvar-type array))
+ (check-bounds (policy node (plusp insert-array-bounds-checks))))
(if (and (array-type-p type)
+ (not (array-type-complexp type))
(listp (array-type-dimensions type))
(not (null (cdr (array-type-dimensions type)))))
;; If it's a simple multidimensional array, then just return
;; users to use WITH-ARRAY-DATA and we may use it ourselves at
;; some point in the future for optimized libraries or
;; similar.
- ;;
- ;; FIXME: The return values here don't seem sane, and
- ;; bounds-checks are elided!
- `(let ((data (truly-the (simple-array ,element-type (*))
- (%array-data-vector array))))
- (values data 0 (length data) 0))
+ (if check-bounds
+ `(let* ((data (truly-the (simple-array ,element-type (*))
+ (%array-data-vector array)))
+ (len (length data))
+ (real-end (or end len)))
+ (unless (<= 0 start data-end lend)
+ (sequence-bounding-indices-bad-error array start end))
+ (values data 0 real-end 0))
+ `(let ((data (truly-the (simple-array ,element-type (*))
+ (%array-data-vector array))))
+ (values data 0 (or end (length data)) 0)))
`(%with-array-data-macro array start end
:check-fill-pointer ,check-fill-pointer
- :check-bounds ,(policy node (< 0 insert-array-bounds-checks))
+ :check-bounds ,check-bounds
:element-type ,element-type))))
;; It might very well be reasonable to allow general ARRAY here, I
;; without bloating the code. If we already know the type of the array
;; with sufficient precision, skip directly to DATA-VECTOR-REF.
(deftransform aref ((array index) (t t) * :node node)
- (let ((type (lvar-type array)))
- (cond ((and (array-type-p type)
- (null (array-type-complexp type))
- (not (eql (extract-upgraded-element-type array)
- *wild-type*))
- (eql (length (array-type-dimensions type)) 1))
- `(data-vector-ref array (%check-bound array
- (array-dimension array 0)
- index)))
- ((policy node (zerop insert-array-bounds-checks))
- `(hairy-data-vector-ref array index))
- (t
- `(hairy-data-vector-ref/check-bounds array index)))))
+ (let* ((type (lvar-type array))
+ (element-ctype (extract-upgraded-element-type array)))
+ (cond
+ ((and (array-type-p type)
+ (null (array-type-complexp type))
+ (not (eql element-ctype *wild-type*))
+ (eql (length (array-type-dimensions type)) 1))
+ (let* ((declared-element-ctype (extract-declared-element-type array))
+ (bare-form
+ `(data-vector-ref array
+ (%check-bound array (array-dimension array 0) index))))
+ (if (type= declared-element-ctype element-ctype)
+ bare-form
+ `(the ,(type-specifier declared-element-ctype) ,bare-form))))
+ ((policy node (zerop insert-array-bounds-checks))
+ `(hairy-data-vector-ref array index))
+ (t `(hairy-data-vector-ref/check-bounds array index)))))
(deftransform %aset ((array index new-value) (t t t) * :node node)
(if (policy node (zerop insert-array-bounds-checks))
;;; available, switch back to the normal one to give other transforms
;;; a stab at it.
(macrolet ((define (name transform-to extra extra-type)
+ (declare (ignore extra-type))
`(deftransform ,name ((array index ,@extra))
(let ((type (lvar-type array))
(element-type (extract-upgraded-element-type array)))