"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))
,@(when element-type
'(:element-type element-type))))
(setf (%array-displaced-p header) nil)
+ (setf (%array-displaced-from header) nil)
,@(let ((axis -1))
(mapcar (lambda (dim)
`(setf (%array-dimension header ,(incf axis))
(deftransform array-rank ((array))
(let ((array-type (lvar-type array)))
(let ((dims (array-type-dimensions-or-give-up array-type)))
- (if (not (listp dims))
- (give-up-ir1-transform
- "The array rank is not known at compile time: ~S"
- dims)
- (length dims)))))
+ (cond ((listp dims)
+ (length dims))
+ ((eq t (array-type-complexp array-type))
+ '(%array-rank array))
+ (t
+ `(if (array-header-p array)
+ (%array-rank array)
+ 1))))))
;;; If we know the dimensions at compile time, just use it. Otherwise,
;;; if we can tell that the axis is in bounds, convert to
(array index))
(unless (constant-lvar-p axis)
(give-up-ir1-transform "The axis is not constant."))
- (let ((array-type (lvar-type array))
+ ;; Dimensions may change thanks to ADJUST-ARRAY, so we need the
+ ;; conservative type.
+ (let ((array-type (lvar-conservative-type array))
(axis (lvar-value axis)))
(let ((dims (array-type-dimensions-or-give-up array-type)))
(unless (listp dims)
((t)
'(%array-dimension array 0))
((nil)
- '(length array))
+ '(vector-length array))
((:maybe)
- (give-up-ir1-transform
- "can't tell whether array is simple"))))
+ `(if (array-header-p array)
+ (%array-dimension array axis)
+ (vector-length array)))))
(t
'(%array-dimension array axis)))))))
;; 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)))
projects / sbcl.git / blobdiff