X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=fcf1f60667dcedf449873ee41d2dc211437d4084;hb=711f75f20284c41f53485fda882fc7cc9e8e930f;hp=a3cea574cc1e62e17aa84475897a56add13fa65c;hpb=7c43a308982c0a834db1727239b4ddf576b39fb0;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index a3cea57..fcf1f60 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -73,7 +73,7 @@ (apply #'type-intersection element-supertypes))))) (union-type (let ((union-types (union-type-types type)) - (element-type *empty-type*) + (element-type nil) (element-supertypes nil)) (dolist (union-type union-types) (multiple-value-bind (cur-type cur-supertype) @@ -81,7 +81,7 @@ (cond ((eq element-type *wild-type*) nil) - ((eq element-type *empty-type*) + ((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 @@ -98,6 +98,10 @@ (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 @@ -122,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) @@ -137,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 @@ -167,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))) @@ -176,9 +183,14 @@ ;; we can already decide on the result of the optimization without ;; even taking a look at the dimensions. (flet ((subscript-bounds (subscript) - (let* ((type (lvar-type subscript)) - (low (numeric-type-low type)) - (high (numeric-type-high type))) + (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)))) @@ -218,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)) @@ -271,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 @@ -351,8 +351,9 @@ ;;; 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 (and (fun-lexically-notinline-p 'list) - (fun-lexically-notinline-p 'vector)) + (if (or (and (fun-lexically-notinline-p 'list) + (fun-lexically-notinline-p 'vector)) + (oddp (length keyargs))) (values nil t) (multiple-value-bind (new-dimensions rank) (flet ((constant-dims (dimensions) @@ -371,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))))) @@ -607,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" @@ -624,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 '*)) @@ -982,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 @@ -1022,8 +1063,8 @@ (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) (let* (,@(let ((,index -1)) (mapcar (lambda (name) `(,name (array-dimension @@ -1056,17 +1097,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 @@ -1091,7 +1131,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))) @@ -1104,7 +1144,8 @@ `(deftransform ,name ((array index ,@extra)) (let* ((type (lvar-type array)) (element-type (array-type-upgraded-element-type type)) - (declared-type (array-type-declared-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