X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=f3cf13671892cfcdfdade46346322ef55c74f4b6;hb=0e8649cf907d26f111864e4e29c7f9787828efbd;hp=340ce5313b62b093f5e305cea7c7cba65929283e;hpb=e4c6f7338e2ca63cef6f82fbd8f88bc9264c292e;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 340ce53..f3cf136 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -17,54 +17,102 @@ ;;; GIVE-UP-IR1-TRANSFORM if the upgraded element type can't be ;;; determined. (defun upgraded-element-type-specifier-or-give-up (lvar) - (let* ((element-ctype (extract-upgraded-element-type lvar)) - (element-type-specifier (type-specifier element-ctype))) + (let ((element-type-specifier (upgraded-element-type-specifier lvar))) (if (eq element-type-specifier '*) (give-up-ir1-transform "upgraded array element type not known at compile time") element-type-specifier))) +(defun upgraded-element-type-specifier (lvar) + (type-specifier (array-type-upgraded-element-type (lvar-type lvar)))) + ;;; 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 - ;; 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. - ((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 '(array character (*)))) - (values (specifier-type 'character) nil)) - #!+sb-unicode - ((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 - (values *wild-type* nil))))) - -(defun extract-declared-element-type (array) - (let ((type (lvar-type array))) - (if (array-type-p type) - (array-type-element-type type) - *wild-type*))) +(defun array-type-upgraded-element-type (type) + (typecase type + ;; 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. + (array-type + (values (array-type-specialized-element-type type) nil)) + ;; Deal with intersection types (bug #316078) + (intersection-type + (let ((intersection-types (intersection-type-types type)) + (element-type *wild-type*) + (element-supertypes nil)) + (dolist (intersection-type intersection-types) + (multiple-value-bind (cur-type cur-supertype) + (array-type-upgraded-element-type intersection-type) + ;; According to ANSI, an array may have only one specialized + ;; element type - e.g. '(and (array foo) (array bar)) + ;; is not a valid type unless foo and bar upgrade to the + ;; same element type. + (cond + ((eq cur-type *wild-type*) + nil) + ((eq element-type *wild-type*) + (setf element-type cur-type)) + ((or (not (csubtypep cur-type element-type)) + (not (csubtypep element-type cur-type))) + ;; At least two different element types where given, the array + ;; is valid iff they represent the same type. + ;; + ;; FIXME: TYPE-INTERSECTION already takes care of disjoint array + ;; types, so I believe this code should be unreachable. Maybe + ;; signal a warning / error instead? + (setf element-type *empty-type*))) + (push (or cur-supertype (type-*-to-t cur-type)) + element-supertypes))) + (values element-type + (when (and (eq *wild-type* element-type) element-supertypes) + (apply #'type-intersection element-supertypes))))) + (union-type + (let ((union-types (union-type-types type)) + (element-type nil) + (element-supertypes nil)) + (dolist (union-type union-types) + (multiple-value-bind (cur-type cur-supertype) + (array-type-upgraded-element-type union-type) + (cond + ((eq element-type *wild-type*) + nil) + ((eq element-type nil) + (setf element-type cur-type)) + ((or (eq cur-type *wild-type*) + ;; If each of the two following tests fail, it is not + ;; possible to determine the element-type of the array + ;; because more than one kind of element-type was provided + ;; like in '(or (array foo) (array bar)) although a + ;; supertype (or foo bar) may be provided as the second + ;; returned value returned. See also the KLUDGE below. + (not (csubtypep cur-type element-type)) + (not (csubtypep element-type cur-type))) + (setf element-type *wild-type*))) + (push (or cur-supertype (type-*-to-t cur-type)) + element-supertypes))) + (values element-type + (when (eq *wild-type* element-type) + (apply #'type-union element-supertypes))))) + (member-type + ;; Convert member-type to an union-type. + (array-type-upgraded-element-type + (apply #'type-union (mapcar #'ctype-of (member-type-members type))))) + (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 + (values *wild-type* nil)))) + +(defun array-type-declared-element-type (type) + (if (array-type-p type) + (array-type-element-type type) + *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 @@ -78,14 +126,6 @@ (lexenv-policy (node-lexenv (lvar-dest new-value)))))) (lvar-type new-value)) -(defun assert-array-complex (array) - (assert-lvar-type - array - (make-array-type :complexp t - :element-type *wild-type*) - (lexenv-policy (node-lexenv (lvar-dest array)))) - nil) - ;;; Return true if ARG is NIL, or is a constant-lvar whose ;;; value is NIL, false otherwise. (defun unsupplied-or-nil (arg) @@ -93,6 +133,12 @@ (or (not arg) (and (constant-lvar-p arg) (not (lvar-value arg))))) + +(defun supplied-and-true (arg) + (and arg + (constant-lvar-p arg) + (lvar-value arg) + t)) ;;;; DERIVE-TYPE optimizers @@ -105,20 +151,88 @@ (lexenv-policy (node-lexenv (lvar-dest array))))) (defun derive-aref-type (array) - (multiple-value-bind (uaet other) (extract-upgraded-element-type array) + (multiple-value-bind (uaet other) + (array-type-upgraded-element-type (lvar-type array)) (or other uaet))) (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices)) (assert-array-rank array (length indices)) *universal-type*) +(deftransform array-in-bounds-p ((array &rest subscripts)) + (flet ((give-up () + (give-up-ir1-transform + "~@")) + (bound-known-p (x) + (integerp x))) ; might be NIL or * + (block nil + (let ((dimensions (array-type-dimensions-or-give-up + (lvar-conservative-type array)))) + ;; Might be *. (Note: currently this is never true, because the type + ;; derivation infers the rank from the call to ARRAY-IN-BOUNDS-P, but + ;; let's keep this future proof.) + (when (eq '* dimensions) + (give-up-ir1-transform "array bounds unknown")) + ;; shortcut for zero dimensions + (when (some (lambda (dim) + (and (bound-known-p dim) (zerop dim))) + dimensions) + (return nil)) + ;; we first collect the subscripts LVARs' bounds and see whether + ;; we can already decide on the result of the optimization without + ;; even taking a look at the dimensions. + (flet ((subscript-bounds (subscript) + (let* ((type1 (lvar-type subscript)) + (type2 (if (csubtypep type1 (specifier-type 'integer)) + (weaken-integer-type type1 :range-only t) + (give-up))) + (low (if (integer-type-p type2) + (numeric-type-low type2) + (give-up))) + (high (numeric-type-high type2))) + (cond + ((and (or (not (bound-known-p low)) (minusp low)) + (or (not (bound-known-p high)) (not (minusp high)))) + ;; can't be sure about the lower bound and the upper bound + ;; does not give us a definite clue either. + (give-up)) + ((and (bound-known-p high) (minusp high)) + (return nil)) ; definitely below lower bound (zero). + (t + (cons low high)))))) + (let* ((subscripts-bounds (mapcar #'subscript-bounds subscripts)) + (subscripts-lower-bound (mapcar #'car subscripts-bounds)) + (subscripts-upper-bound (mapcar #'cdr subscripts-bounds)) + (in-bounds 0)) + (mapcar (lambda (low high dim) + (cond + ;; first deal with infinite bounds + ((some (complement #'bound-known-p) (list low high dim)) + (when (and (bound-known-p dim) (bound-known-p low) (<= dim low)) + (return nil))) + ;; now we know all bounds + ((>= low dim) + (return nil)) + ((< high dim) + (aver (not (minusp low))) + (incf in-bounds)) + (t + (give-up)))) + subscripts-lower-bound + subscripts-upper-bound + dimensions) + (if (eql in-bounds (length dimensions)) + t + (give-up)))))))) + (defoptimizer (aref derive-type) ((array &rest indices) node) (assert-array-rank array (length indices)) (derive-aref-type array)) -(defoptimizer (%aset derive-type) ((array &rest stuff)) - (assert-array-rank array (1- (length stuff))) - (assert-new-value-type (car (last stuff)) array)) +(defoptimizer ((setf aref) derive-type) ((new-value array &rest subscripts)) + (assert-array-rank array (length subscripts)) + (assert-new-value-type new-value array)) (macrolet ((define (name) `(defoptimizer (,name derive-type) ((array index)) @@ -169,51 +283,39 @@ (defoptimizer (make-array derive-type) ((dims &key initial-element element-type initial-contents adjustable fill-pointer displaced-index-offset displaced-to)) - (let ((simple (and (unsupplied-or-nil adjustable) - (unsupplied-or-nil displaced-to) - (unsupplied-or-nil fill-pointer)))) - (or (careful-specifier-type - `(,(if simple 'simple-array 'array) - ,(cond ((not element-type) t) - ((constant-lvar-p element-type) - (let ((ctype (careful-specifier-type - (lvar-value element-type)))) - (cond - ((or (null ctype) (unknown-type-p ctype)) '*) - (t (sb!xc:upgraded-array-element-type - (lvar-value element-type)))))) - (t - '*)) - ,(cond ((constant-lvar-p dims) - (let* ((val (lvar-value dims)) - (cdims (if (listp val) val (list val)))) - (if simple - cdims - (length cdims)))) - ((csubtypep (lvar-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)) + (let* ((simple (and (unsupplied-or-nil adjustable) + (unsupplied-or-nil displaced-to) + (unsupplied-or-nil fill-pointer))) + (spec + (or `(,(if simple 'simple-array 'array) + ,(cond ((not element-type) t) + ((constant-lvar-p element-type) + (let ((ctype (careful-specifier-type + (lvar-value element-type)))) + (cond + ((or (null ctype) (unknown-type-p ctype)) '*) + (t (sb!xc:upgraded-array-element-type + (lvar-value element-type)))))) + (t + '*)) + ,(cond ((constant-lvar-p dims) + (let* ((val (lvar-value dims)) + (cdims (if (listp val) val (list val)))) + (if simple + cdims + (length cdims)))) + ((csubtypep (lvar-type dims) + (specifier-type 'integer)) + '(*)) + (t + '*))) + 'array))) + (if (and (not simple) + (or (supplied-and-true adjustable) + (supplied-and-true displaced-to) + (supplied-and-true fill-pointer))) + (careful-specifier-type `(and ,spec (not simple-array))) + (careful-specifier-type spec)))) ;;;; constructors @@ -231,21 +333,50 @@ ,@(when initial-element '(:initial-element initial-element))))) -;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments, -;;; so that we can pick them apart. -(define-source-transform make-array (&whole form dimensions &rest keyargs - &environment env) - (if (and (fun-lexically-notinline-p 'list) - (fun-lexically-notinline-p 'vector)) +(defun rewrite-initial-contents (rank initial-contents env) + (if (plusp rank) + (if (and (consp initial-contents) + (member (car initial-contents) '(list vector sb!impl::backq-list))) + `(list ,@(mapcar (lambda (dim) + (rewrite-initial-contents (1- rank) dim env)) + (cdr initial-contents))) + initial-contents) + ;; This is the important bit: once we are past the level of + ;; :INITIAL-CONTENTS that relates to the array structure, reinline LIST + ;; and VECTOR so that nested DX isn't screwed up. + `(locally (declare (inline list vector)) + ,initial-contents))) + +;;; Prevent open coding DIMENSION and :INITIAL-CONTENTS arguments, so that we +;;; can pick them apart in the DEFTRANSFORMS, and transform '(3) style +;;; dimensions to integer args directly. +(define-source-transform make-array (dimensions &rest keyargs &environment env) + (if (or (and (fun-lexically-notinline-p 'list) + (fun-lexically-notinline-p 'vector)) + (oddp (length keyargs))) (values nil t) - `(locally (declare (notinline list vector)) - ;; Transform '(3) style dimensions to integer args directly. - ,(if (sb!xc:constantp dimensions env) - (let ((dims (constant-form-value dimensions env))) - (if (and (listp dims) (= 1 (length dims))) - `(make-array ',(car dims) ,@keyargs) - form)) - form)))) + (multiple-value-bind (new-dimensions rank) + (flet ((constant-dims (dimensions) + (let* ((dims (constant-form-value dimensions env)) + (canon (if (listp dims) dims (list dims))) + (rank (length canon))) + (values (if (= rank 1) + (list 'quote (car canon)) + (list 'quote canon)) + rank)))) + (cond ((sb!xc:constantp dimensions env) + (constant-dims dimensions)) + ((and (consp dimensions) (eq 'list dimensions)) + (values dimensions (length (cdr dimensions)))) + (t + (values dimensions nil)))) + (let ((initial-contents (getf keyargs :initial-contents))) + (when (and initial-contents rank) + (setf keyargs (copy-list keyargs) + (getf keyargs :initial-contents) + (rewrite-initial-contents rank initial-contents env)))) + `(locally (declare (notinline list vector)) + (make-array ,new-dimensions ,@keyargs))))) ;;; This baby is a bit of a monster, but it takes care of any MAKE-ARRAY ;;; call which creates a vector with a known element type -- and tries @@ -329,7 +460,7 @@ (truly-the ,result-spec (initialize-vector ,alloc-form ,@(map 'list (lambda (elt) - `(the ,elt-spec ,elt)) + `(the ,elt-spec ',elt)) contents))))))) ;; any other :INITIAL-CONTENTS (initial-contents @@ -351,7 +482,7 @@ call 1 '((:element-type element-type) (:initial-element initial-element)))) (init (if (constant-lvar-p initial-element) - (lvar-value initial-element) + (list 'quote (lvar-value initial-element)) 'initial-element))) `(lambda (length ,@parameters) (declare (ignorable ,@parameters)) @@ -380,24 +511,74 @@ default-initial-element elt-spec))) (let ((parameters (eliminate-keyword-args - call 1 '((:element-type element-type))))) + call 1 '((:element-type element-type) + (:initial-element initial-element))))) `(lambda (length ,@parameters) (declare (ignorable ,@parameters)) ,alloc-form)))))) -(deftransform make-array ((dims &key - element-type initial-element initial-contents) - (integer &key - (:element-type (constant-arg *)) - (:initial-element *) - (:initial-contents *)) - * - :node call) - (transform-make-array-vector dims - element-type - initial-element - initial-contents - call)) +;;; IMPORTANT: The order of these three MAKE-ARRAY forms matters: the least +;;; specific must come first, otherwise suboptimal transforms will result for +;;; some forms. + +(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-lvar-p element-type)) + (give-up-ir1-transform + "ELEMENT-TYPE is not constant.")) + (t + (lvar-value element-type)))) + (eltype-type (ir1-transform-specifier-type eltype)) + (saetp (find-if (lambda (saetp) + (csubtypep eltype-type (sb!vm:saetp-ctype saetp))) + sb!vm:*specialized-array-element-type-properties*)) + (creation-form `(make-array dims + :element-type ',(type-specifier (sb!vm: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-lvar-p initial-element) + (eql (lvar-value initial-element) + (sb!vm: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-lvar-p initial-element) + (let ((value (lvar-value initial-element))) + (cond + ((not (ctypep value (sb!vm:saetp-ctype saetp))) + ;; this case will cause an error at runtime, so we'd + ;; better WARN about it now. + (warn 'array-initial-element-mismatch + :format-control "~@<~S is not a ~S (which is the ~ + ~S of ~S).~@:>" + :format-arguments + (list + value + (type-specifier (sb!vm:saetp-ctype saetp)) + 'upgraded-array-element-type + eltype))) + ((not (ctypep 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 (the ,(sb!vm:saetp-specifier saetp) initial-element))) + array))))) ;;; The list type restriction does not ensure that the result will be a ;;; multi-dimensional array. But the lack of adjustable, fill-pointer, @@ -428,7 +609,12 @@ (unless (constant-lvar-p dims) (give-up-ir1-transform "The dimension list is not constant; cannot open code array creation.")) - (let ((dims (lvar-value dims))) + (let ((dims (lvar-value dims)) + (element-type-ctype (and (constant-lvar-p element-type) + (ir1-transform-specifier-type + (lvar-value element-type))))) + (when (unknown-type-p element-type-ctype) + (give-up-ir1-transform)) (unless (every #'integerp dims) (give-up-ir1-transform "The dimension list contains something other than an integer: ~S" @@ -445,9 +631,7 @@ (rank (length dims)) (spec `(simple-array ,(cond ((null element-type) t) - ((and (constant-lvar-p element-type) - (ir1-transform-specifier-type - (lvar-value element-type))) + (element-type-ctype (sb!xc:upgraded-array-element-type (lvar-value element-type))) (t '*)) @@ -474,64 +658,18 @@ dims)) (truly-the ,spec header))))))) -(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-lvar-p element-type)) - (give-up-ir1-transform - "ELEMENT-TYPE is not constant.")) - (t - (lvar-value element-type)))) - (eltype-type (ir1-transform-specifier-type eltype)) - (saetp (find-if (lambda (saetp) - (csubtypep eltype-type (sb!vm:saetp-ctype saetp))) - sb!vm:*specialized-array-element-type-properties*)) - (creation-form `(make-array dims - :element-type ',(type-specifier (sb!vm: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-lvar-p initial-element) - (eql (lvar-value initial-element) - (sb!vm: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-lvar-p initial-element) - (let ((value (lvar-value initial-element))) - (cond - ((not (ctypep value (sb!vm:saetp-ctype saetp))) - ;; this case will cause an error at runtime, so we'd - ;; better WARN about it now. - (warn 'array-initial-element-mismatch - :format-control "~@<~S is not a ~S (which is the ~ - ~S of ~S).~@:>" - :format-arguments - (list - value - (type-specifier (sb!vm:saetp-ctype saetp)) - 'upgraded-array-element-type - eltype))) - ((not (ctypep 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 (the ,(sb!vm:saetp-specifier saetp) initial-element))) - array))))) +(deftransform make-array ((dims &key element-type initial-element initial-contents) + (integer &key + (:element-type (constant-arg *)) + (:initial-element *) + (:initial-contents *)) + * + :node call) + (transform-make-array-vector dims + element-type + initial-element + initial-contents + call)) ;;;; miscellaneous properties of arrays @@ -543,18 +681,32 @@ ;;; maybe this is just too sloppy for actual type logic. -- CSR, ;;; 2004-02-18 (defun array-type-dimensions-or-give-up (type) - (typecase type - (array-type (array-type-dimensions type)) - (union-type - (let ((types (union-type-types type))) - ;; there are at least two types, right? - (aver (> (length types) 1)) - (let ((result (array-type-dimensions-or-give-up (car types)))) - (dolist (type (cdr types) result) - (unless (equal (array-type-dimensions-or-give-up type) result) - (give-up-ir1-transform)))))) - ;; FIXME: intersection type [e.g. (and (array * (*)) (satisfies foo)) ] - (t (give-up-ir1-transform)))) + (labels ((maybe-array-type-dimensions (type) + (typecase type + (array-type + (array-type-dimensions type)) + (union-type + (let* ((types (remove nil (mapcar #'maybe-array-type-dimensions + (union-type-types type)))) + (result (car types))) + (dolist (other (cdr types) result) + (unless (equal result other) + (give-up-ir1-transform + "~@" + (type-specifier type)))))) + (intersection-type + (let* ((types (remove nil (mapcar #'maybe-array-type-dimensions + (intersection-type-types type)))) + (result (car types))) + (dolist (other (cdr types) result) + (unless (equal result other) + (abort-ir1-transform + "~@" + (type-specifier type))))))))) + (or (maybe-array-type-dimensions type) + (give-up-ir1-transform + "~@" + (type-specifier type))))) (defun conservative-array-type-complexp (type) (typecase type @@ -835,32 +987,68 @@ ;;;; array accessors -;;; We convert all typed array accessors into AREF and %ASET with type +;;; We convert all typed array accessors into AREF and (SETF AREF) with type ;;; assertions on the array. -(macrolet ((define-bit-frob (reffer setter simplep) +(macrolet ((define-bit-frob (reffer simplep) `(progn (define-source-transform ,reffer (a &rest i) `(aref (the (,',(if simplep 'simple-array 'array) bit ,(mapcar (constantly '*) i)) ,a) ,@i)) - (define-source-transform ,setter (a &rest i) - `(%aset (the (,',(if simplep 'simple-array 'array) - bit - ,(cdr (mapcar (constantly '*) i))) - ,a) ,@i))))) - (define-bit-frob sbit %sbitset t) - (define-bit-frob bit %bitset nil)) + (define-source-transform (setf ,reffer) (value a &rest i) + `(setf (aref (the (,',(if simplep 'simple-array 'array) + bit + ,(mapcar (constantly '*) i)) + ,a) ,@i) + ,value))))) + (define-bit-frob sbit t) + (define-bit-frob bit nil)) + (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) + `(setf (aref (the ,',type ,a) ,i) ,v))))) (define-frob schar %scharset simple-string) (define-frob char %charset string)) +;;; We transform SVREF and %SVSET directly into DATA-VECTOR-REF/SET: this is +;;; around 100 times faster than going through the general-purpose AREF +;;; transform which ends up doing a lot of work -- and introducing many +;;; intermediate lambdas, each meaning a new trip through the compiler -- to +;;; get the same result. +;;; +;;; FIXME: [S]CHAR, and [S]BIT above would almost certainly benefit from a similar +;;; treatment. +(define-source-transform svref (vector index) + (let ((elt-type (or (when (symbolp vector) + (let ((var (lexenv-find vector vars))) + (when (lambda-var-p var) + (type-specifier + (array-type-declared-element-type (lambda-var-type var)))))) + t))) + (with-unique-names (n-vector) + `(let ((,n-vector ,vector)) + (the ,elt-type (data-vector-ref + (the simple-vector ,n-vector) + (%check-bound ,n-vector (length ,n-vector) ,index))))))) + +(define-source-transform %svset (vector index value) + (let ((elt-type (or (when (symbolp vector) + (let ((var (lexenv-find vector vars))) + (when (lambda-var-p var) + (type-specifier + (array-type-declared-element-type (lambda-var-type var)))))) + t))) + (with-unique-names (n-vector) + `(let ((,n-vector ,vector)) + (truly-the ,elt-type (data-vector-set + (the simple-vector ,n-vector) + (%check-bound ,n-vector (length ,n-vector) ,index) + (the ,elt-type ,value))))))) + (macrolet (;; This is a handy macro for computing the row-major index ;; given a set of indices. We wrap each index with a call ;; to %CHECK-BOUND to ensure that everything works out @@ -875,8 +1063,9 @@ (push (make-symbol (format nil "DIM-~D" i)) dims)) (setf n-indices (nreverse n-indices)) (setf dims (nreverse dims)) - `(lambda (,',array ,@n-indices - ,@',(when new-value (list new-value))) + `(lambda (,@',(when new-value (list new-value)) + ,',array ,@n-indices) + (declare (ignorable ,',array)) (let* (,@(let ((,index -1)) (mapcar (lambda (name) `(,name (array-dimension @@ -909,17 +1098,16 @@ (with-row-major-index (array indices index) index)) - ;; Convert AREF and %ASET into a HAIRY-DATA-VECTOR-REF (or + ;; Convert AREF and (SETF AREF) into a HAIRY-DATA-VECTOR-REF (or ;; HAIRY-DATA-VECTOR-SET) with the set of indices replaced with the an ;; expression for the row major index. (deftransform aref ((array &rest indices)) (with-row-major-index (array indices index) (hairy-data-vector-ref array index))) - (deftransform %aset ((array &rest stuff)) - (let ((indices (butlast stuff))) - (with-row-major-index (array indices index new-value) - (hairy-data-vector-set array index new-value))))) + (deftransform (setf aref) ((new-value array &rest subscripts)) + (with-row-major-index (array subscripts index new-value) + (hairy-data-vector-set array index new-value)))) ;; For AREF of vectors we do the bounds checking in the callee. This ;; lets us do a significantly more efficient check for simple-arrays @@ -927,13 +1115,13 @@ ;; with sufficient precision, skip directly to DATA-VECTOR-REF. (deftransform aref ((array index) (t t) * :node node) (let* ((type (lvar-type array)) - (element-ctype (extract-upgraded-element-type array))) + (element-ctype (array-type-upgraded-element-type type))) (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)) + (let* ((declared-element-ctype (array-type-declared-element-type type)) (bare-form `(data-vector-ref array (%check-bound array (array-dimension array 0) index)))) @@ -944,7 +1132,7 @@ `(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) +(deftransform (setf aref) ((new-value array index) (t t t) * :node node) (if (policy node (zerop insert-array-bounds-checks)) `(hairy-data-vector-set array index new-value) `(hairy-data-vector-set/check-bounds array index new-value))) @@ -955,9 +1143,10 @@ (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)) - (declared-type (extract-declared-element-type array))) + (let* ((type (lvar-type array)) + (element-type (array-type-upgraded-element-type type)) + (declared-type (type-specifier + (array-type-declared-element-type type)))) ;; If an element type has been declared, we want to ;; use that information it for type checking (even ;; if the access can't be optimized due to the array