;;; -*- Package: C; Log: C.Log -*- ;;; ;;; ********************************************************************** ;;; This code was written as part of the CMU Common Lisp project at ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; (ext:file-comment "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.20 1997/08/24 03:46:45 dtc Exp $") ;;; ;;; ********************************************************************** ;;; ;;; This file contains array specific optimizers and transforms. ;;; ;;; Extracted from srctran and extended by William Lott. ;;; (in-package "C") ;;;; Derive-Type Optimizers ;;; ASSERT-ARRAY-RANK -- internal ;;; ;;; Array operations that use a specific number of indices implicitly assert ;;; that the array is of that rank. ;;; (defun assert-array-rank (array rank) (assert-continuation-type array (specifier-type `(array * ,(make-list rank :initial-element '*))))) ;;; EXTRACT-ELEMENT-TYPE -- internal ;;; ;;; Array access functions return an object from the array, hence it's type ;;; is going to be the array element type. ;;; (defun extract-element-type (array) (let ((type (continuation-type array))) (if (array-type-p type) (array-type-element-type type) *universal-type*))) ;;; ASSERT-NEW-VALUE-TYPE -- internal ;;; ;;; 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 functions. ;;; (defun assert-new-value-type (new-value array) (let ((type (continuation-type array))) (when (array-type-p type) (assert-continuation-type new-value (array-type-element-type type)))) (continuation-type new-value)) ;;; Unsupplied-Or-NIL -- Internal ;;; ;;; Return true if Arg is NIL, or is a constant-continuation whose value is ;;; NIL, false otherwise. ;;; (defun unsupplied-or-nil (arg) (declare (type (or continuation null) arg)) (or (not arg) (and (constant-continuation-p arg) (not (continuation-value arg))))) ;;; ARRAY-IN-BOUNDS-P -- derive-type optimizer. ;;; (defoptimizer (array-in-bounds-p derive-type) ((array &rest indices)) (assert-array-rank array (length indices)) *universal-type*) ;;; AREF -- derive-type optimizer. ;;; (defoptimizer (aref derive-type) ((array &rest indices)) (assert-array-rank array (length indices)) (extract-element-type array)) ;;; %ASET -- derive-type optimizer. ;;; (defoptimizer (%aset derive-type) ((array &rest stuff)) (assert-array-rank array (1- (length stuff))) (assert-new-value-type (car (last stuff)) array)) ;;; DATA-VECTOR-REF -- derive-type optimizer. ;;; (defoptimizer (data-vector-ref derive-type) ((array index)) (extract-element-type array)) ;;; DATA-VECTOR-SET -- derive-type optimizer. ;;; (defoptimizer (data-vector-set derive-type) ((array index new-value)) (assert-new-value-type new-value array)) ;;; %WITH-ARRAY-DATA -- derive-type optimizer. ;;; ;;; Figure out the type of the data vector if we know the argument element ;;; type. ;;; (defoptimizer (%with-array-data derive-type) ((array start end)) (let ((atype (continuation-type array))) (when (array-type-p atype) (values-specifier-type `(values (simple-array ,(type-specifier (array-type-element-type atype)) (*)) index index index))))) ;;; ARRAY-ROW-MAJOR-INDEX -- derive-type optimizer. ;;; (defoptimizer (array-row-major-index derive-type) ((array &rest indices)) (assert-array-rank array (length indices)) *universal-type*) ;;; ROW-MAJOR-AREF -- derive-type optimizer. ;;; (defoptimizer (row-major-aref derive-type) ((array index)) (extract-element-type array)) ;;; %SET-ROW-MAJOR-AREF -- derive-type optimizer. ;;; (defoptimizer (%set-row-major-aref derive-type) ((array index new-value)) (assert-new-value-type new-value array)) ;;; MAKE-ARRAY -- derive-type optimizer. ;;; (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)))) (specifier-type `(,(if simple 'simple-array 'array) ,(cond ((not element-type) 't) ((constant-continuation-p element-type) (continuation-value element-type)) (t '*)) ,(cond ((not simple) '*) ((constant-continuation-p dims) (let ((val (continuation-value dims))) (if (listp val) val (list val)))) ((csubtypep (continuation-type dims) (specifier-type 'integer)) '(*)) (t '*)))))) ;;;; Constructors. ;;; VECTOR -- source-transform. ;;; ;;; Convert VECTOR into a make-array followed by setfs of all the elements. ;;; (def-source-transform vector (&rest elements) (if (byte-compiling) (values nil t) (let ((len (length elements)) (n -1)) (once-only ((n-vec `(make-array ,len))) `(progn ,@(mapcar #'(lambda (el) (once-only ((n-val el)) `(locally (declare (optimize (safety 0))) (setf (svref ,n-vec ,(incf n)) ,n-val)))) elements) ,n-vec))))) ;;; MAKE-STRING -- source-transform. ;;; ;;; Just convert it into a make-array. ;;; (def-source-transform make-string (length &key (initial-element #\NULL)) (if (byte-compiling) (values nil t) `(make-array (the index ,length) :element-type 'base-char :initial-element ,initial-element))) (defconstant array-info '((base-char #\NULL 8 vm:simple-string-type) (single-float 0.0s0 32 vm:simple-array-single-float-type) (double-float 0.0d0 64 vm:simple-array-double-float-type) (bit 0 1 vm:simple-bit-vector-type) ((unsigned-byte 2) 0 2 vm:simple-array-unsigned-byte-2-type) ((unsigned-byte 4) 0 4 vm:simple-array-unsigned-byte-4-type) ((unsigned-byte 8) 0 8 vm:simple-array-unsigned-byte-8-type) ((unsigned-byte 16) 0 16 vm:simple-array-unsigned-byte-16-type) ((unsigned-byte 32) 0 32 vm:simple-array-unsigned-byte-32-type) #+signed-array ((signed-byte 8) 0 8 vm:simple-array-signed-byte-8-type) #+signed-array ((signed-byte 16) 0 16 vm:simple-array-signed-byte-16-type) #+signed-array ((signed-byte 30) 0 32 vm:simple-array-signed-byte-30-type) #+signed-array ((signed-byte 32) 0 32 vm:simple-array-signed-byte-32-type) (t 0 32 vm:simple-vector-type))) ;;; MAKE-ARRAY -- source-transform. ;;; ;;; The integer type restriction on the length assures that it will be a ;;; vector. The lack of adjustable, fill-pointer, and displaced-to keywords ;;; assures that it will be simple. ;;; (deftransform make-array ((length &key initial-element element-type) (integer &rest *)) (let* ((eltype (cond ((not element-type) t) ((not (constant-continuation-p element-type)) (give-up "Element-Type is not constant.")) (t (continuation-value element-type)))) (len (if (constant-continuation-p length) (continuation-value length) '*)) (spec `(simple-array ,eltype (,len))) (eltype-type (specifier-type eltype))) (multiple-value-bind (default-initial-element element-size typecode) (dolist (info array-info (give-up "Cannot open-code creation of ~S" spec)) (when (csubtypep eltype-type (specifier-type (car info))) (return (values-list (cdr info))))) (let* ((nwords-form (if (>= element-size vm:word-bits) `(* length ,(/ element-size vm:word-bits)) (let ((elements-per-word (/ 32 element-size))) `(truncate (+ length ,(if (eq 'vm:simple-string-type typecode) elements-per-word (1- elements-per-word))) ,elements-per-word)))) (constructor `(truly-the ,spec (allocate-vector ,typecode length ,nwords-form)))) (values (if (and default-initial-element (or (null initial-element) (and (constant-continuation-p initial-element) (eql (continuation-value initial-element) default-initial-element)))) constructor `(truly-the ,spec (fill ,constructor initial-element))) '((declare (type index length)))))))) ;;; MAKE-ARRAY -- transform. ;;; ;;; The list type restriction does not assure that the result will be a ;;; multi-dimensional array. But the lack of ;;; (deftransform make-array ((dims &key initial-element element-type) (list &rest *)) (unless (or (null element-type) (constant-continuation-p element-type)) (give-up "Element-type not constant; cannot open code array creation")) (unless (constant-continuation-p dims) (give-up "Dimension list not constant; cannot open code array creation")) (let ((dims (continuation-value dims))) (unless (every #'integerp dims) (give-up "Dimension list contains something other than an integer: ~S" dims)) (if (= (length dims) 1) `(make-array ',(car dims) ,@(when initial-element '(:initial-element initial-element)) ,@(when element-type '(:element-type element-type))) (let* ((total-size (reduce #'* dims)) (rank (length dims)) (spec `(simple-array ,(cond ((null element-type) t) ((constant-continuation-p element-type) (continuation-value element-type)) (t '*)) ,(make-list rank :initial-element '*)))) `(let ((header (make-array-header vm:simple-array-type ,rank))) (setf (%array-fill-pointer header) ,total-size) (setf (%array-fill-pointer-p header) nil) (setf (%array-available-elements header) ,total-size) (setf (%array-data-vector header) (make-array ,total-size ,@(when element-type '(:element-type element-type)) ,@(when initial-element '(:initial-element initial-element)))) (setf (%array-displaced-p header) nil) ,@(let ((axis -1)) (mapcar #'(lambda (dim) `(setf (%array-dimension header ,(incf axis)) ,dim)) dims)) (truly-the ,spec header)))))) ;;;; Random properties of arrays. ;;; Transforms for various random array properties. If the property is know ;;; at compile time because of a type spec, use that constant value. ;;; ARRAY-RANK -- transform. ;;; ;;; If we can tell the rank from the type info, use it instead. ;;; (deftransform array-rank ((array)) (let ((array-type (continuation-type array))) (unless (array-type-p array-type) (give-up)) (let ((dims (array-type-dimensions array-type))) (if (not (listp dims)) (give-up "Array rank not known at compile time: ~S" dims) (length dims))))) ;;; ARRAY-DIMENSION -- transform. ;;; ;;; 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-dimension ;;; (which just indirects the array header) or length (if it's simple and a ;;; vector). ;;; (deftransform array-dimension ((array axis) (array index)) (unless (constant-continuation-p axis) (give-up "Axis not constant.")) (let ((array-type (continuation-type array)) (axis (continuation-value axis))) (unless (array-type-p array-type) (give-up)) (let ((dims (array-type-dimensions array-type))) (unless (listp dims) (give-up "Array dimensions unknown, must call array-dimension at runtime.")) (unless (> (length dims) axis) (abort-transform "Array has dimensions ~S, ~D is too large." dims axis)) (let ((dim (nth axis dims))) (cond ((integerp dim) dim) ((= (length dims) 1) (ecase (array-type-complexp array-type) ((t) '(%array-dimension array 0)) ((nil) '(length array)) (* (give-up "Can't tell if array is simple.")))) (t '(%array-dimension array axis))))))) ;;; LENGTH -- transform. ;;; ;;; If the length has been declared and it's simple, just return it. ;;; (deftransform length ((vector) ((simple-array * (*)))) (let ((type (continuation-type vector))) (unless (array-type-p type) (give-up)) (let ((dims (array-type-dimensions type))) (unless (and (listp dims) (integerp (car dims))) (give-up "Vector length unknown, must call length at runtime.")) (car dims)))) ;;; LENGTH -- transform. ;;; ;;; All vectors can get their length by using vector-length. If it's simple, ;;; it will extract the length slot from the vector. It it's complex, it will ;;; extract the fill pointer slot from the array header. ;;; (deftransform length ((vector) (vector)) '(vector-length vector)) ;;; If a simple array with known dimensions, then vector-length is a ;;; compile-time constant. ;;; (deftransform vector-length ((vector) ((simple-array * (*)))) (let ((vtype (continuation-type vector))) (if (array-type-p vtype) (let ((dim (first (array-type-dimensions vtype)))) (when (eq dim '*) (give-up)) dim) (give-up)))) ;;; ARRAY-TOTAL-SIZE -- transform. ;;; ;;; Again, if we can tell the results from the type, just use it. Otherwise, ;;; if we know the rank, convert into a computation based on array-dimension. ;;; We can wrap a truly-the index around the multiplications because we know ;;; that the total size must be an index. ;;; (deftransform array-total-size ((array) (array)) (let ((array-type (continuation-type array))) (unless (array-type-p array-type) (give-up)) (let ((dims (array-type-dimensions array-type))) (unless (listp dims) (give-up "Can't tell the rank at compile time.")) (if (member '* dims) (do ((form 1 `(truly-the index (* (array-dimension array ,i) ,form))) (i 0 (1+ i))) ((= i (length dims)) form)) (reduce #'* dims))))) ;;; ARRAY-HAS-FILL-POINTER-P -- transform. ;;; ;;; Only complex vectors have fill pointers. ;;; (deftransform array-has-fill-pointer-p ((array)) (let ((array-type (continuation-type array))) (unless (array-type-p array-type) (give-up)) (let ((dims (array-type-dimensions array-type))) (if (and (listp dims) (not (= (length dims) 1))) nil (ecase (array-type-complexp array-type) ((t) t) ((nil) nil) (* (give-up "Array type ambiguous; must call ~ array-has-fill-pointer-p at runtime."))))))) ;;; %CHECK-BOUND -- transform. ;;; ;;; Primitive used to verify indicies into arrays. If we can tell at ;;; compile-time or we are generating unsafe code, don't bother with the VOP. ;;; (deftransform %check-bound ((array dimension index)) (unless (constant-continuation-p dimension) (give-up)) (let ((dim (continuation-value dimension))) `(the (integer 0 ,dim) index))) ;;; (deftransform %check-bound ((array dimension index) * * :policy (and (> speed safety) (= safety 0))) 'index) ;;; WITH-ROW-MAJOR-INDEX -- internal. ;;; ;;; Handy macro for computing the row-major index given a set of indices. We ;;; wrap each index with a call to %check-bound to assure that everything ;;; works out correctly. We can wrap all the interior arith with truly-the ;;; index because we know the the resultant row-major index must be an index. ;;; (eval-when (compile eval) ;;; (defmacro with-row-major-index ((array indices index &optional new-value) &rest body) `(let (n-indices dims) (dotimes (i (length ,indices)) (push (make-symbol (format nil "INDEX-~D" i)) n-indices) (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))) (let* (,@(let ((,index -1)) (mapcar #'(lambda (name) `(,name (array-dimension ,',array ,(incf ,index)))) dims)) (,',index ,(if (null dims) 0 (do* ((dims dims (cdr dims)) (indices n-indices (cdr indices)) (last-dim nil (car dims)) (form `(%check-bound ,',array ,(car dims) ,(car indices)) `(truly-the index (+ (truly-the index (* ,form ,last-dim)) (%check-bound ,',array ,(car dims) ,(car indices)))))) ((null (cdr dims)) form))))) ,',@body)))) ;;; ); eval-when ;;; ARRAY-ROW-MAJOR-INDEX -- transform. ;;; ;;; Just return the index after computing it. ;;; (deftransform array-row-major-index ((array &rest indices)) (with-row-major-index (array indices index) index)) ;;;; Array accessors: ;;; SVREF, %SVSET, SCHAR, %SCHARSET, CHAR, ;;; %CHARSET, SBIT, %SBITSET, BIT, %BITSET ;;; -- source transforms. ;;; ;;; We convert all typed array accessors into aref and %aset with type ;;; assertions on the array. ;;; (macrolet ((frob (reffer setter type) `(progn (def-source-transform ,reffer (a &rest i) (if (byte-compiling) (values nil t) `(aref (the ,',type ,a) ,@i))) (def-source-transform ,setter (a &rest i) (if (byte-compiling) (values nil t) `(%aset (the ,',type ,a) ,@i)))))) (frob svref %svset simple-vector) (frob schar %scharset simple-string) (frob char %charset string) (frob sbit %sbitset (simple-array bit)) (frob bit %bitset (array bit))) ;;; AREF, %ASET -- transform. ;;; ;;; Convert into a data-vector-ref (or 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) (data-vector-ref array index))) ;;; (deftransform %aset ((array &rest stuff)) (let ((indices (butlast stuff))) (with-row-major-index (array indices index new-value) (data-vector-set array index new-value)))) ;;; ROW-MAJOR-AREF, %SET-ROW-MAJOR-AREF -- transform. ;;; ;;; Just convert into a data-vector-ref (or set) after checking that the ;;; index is inside the array total size. ;;; (deftransform row-major-aref ((array index)) `(data-vector-ref array (%check-bound array (array-total-size array) index))) ;;; (deftransform %set-row-major-aref ((array index new-value)) `(data-vector-set array (%check-bound array (array-total-size array) index) new-value)) ;;;; Bit-vector array operation canonicalization: ;;; ;;; We convert all bit-vector operations to have the result array specified. ;;; This allows any result allocation to be open-coded, and eliminates the need ;;; for any VM-dependent transforms to handle these cases. (dolist (fun '(bit-and bit-ior bit-xor bit-eqv bit-nand bit-nor bit-andc1 bit-andc2 bit-orc1 bit-orc2)) ;; ;; Make a result array if result is NIL or unsupplied. (deftransform fun ((bit-array-1 bit-array-2 &optional result-bit-array) '(bit-vector bit-vector &optional null) '* :eval-name t :policy (>= speed space)) `(,fun bit-array-1 bit-array-2 (make-array (length bit-array-1) :element-type 'bit))) ;; ;; If result its T, make it the first arg. (deftransform fun ((bit-array-1 bit-array-2 result-bit-array) '(bit-vector bit-vector (member t)) '* :eval-name t) `(,fun bit-array-1 bit-array-2 bit-array-1))) ;;; Similar for BIT-NOT, but there is only one arg... ;;; (deftransform bit-not ((bit-array-1 &optional result-bit-array) (bit-vector &optional null) * :policy (>= speed space)) '(bit-not bit-array-1 (make-array (length bit-array-1) :element-type 'bit))) ;;; (deftransform bit-not ((bit-array-1 result-bit-array) (bit-vector (constant-argument t))) '(bit-not bit-array-1 bit-array-1)) ;;; ARRAY-HEADER-P -- transform. ;;; ;;; Pick off some constant cases. ;;; (deftransform array-header-p ((array) (array)) (let ((type (continuation-type array))) (declare (optimize (safety 3))) (unless (array-type-p type) (give-up)) (let ((dims (array-type-dimensions type))) (cond ((csubtypep type (specifier-type '(simple-array * (*)))) ;; No array header. nil) ((and (listp dims) (> (length dims) 1)) ;; Multi-dimensional array, will have a header. t) (t (give-up))))))