X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=f3cf13671892cfcdfdade46346322ef55c74f4b6;hb=0e8649cf907d26f111864e4e29c7f9787828efbd;hp=34d88402f2f1d0d5862350a9f2b536521a4f52b1;hpb=67a805dee41b93fa03c6e72f3d1ce3078dfe88eb;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 34d8840..f3cf136 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -169,6 +169,11 @@ (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))) @@ -180,9 +185,11 @@ (flet ((subscript-bounds (subscript) (let* ((type1 (lvar-type subscript)) (type2 (if (csubtypep type1 (specifier-type 'integer)) - (weaken-integer-type type1) + (weaken-integer-type type1 :range-only t) (give-up))) - (low (numeric-type-low type2)) + (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)) @@ -223,9 +230,9 @@ (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)) @@ -365,7 +372,8 @@ (values dimensions nil)))) (let ((initial-contents (getf keyargs :initial-contents))) (when (and initial-contents rank) - (setf (getf keyargs :initial-contents) + (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))))) @@ -601,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" @@ -618,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 '*)) @@ -976,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 @@ -1016,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 @@ -1050,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 @@ -1085,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)))