From 519803d112c10a66049af4f323f76680ed346d64 Mon Sep 17 00:00:00 2001 From: wlott <wlott> Date: Sat, 10 Nov 1990 18:39:33 +0000 Subject: [PATCH] Initial revision --- compiler/array-tran.lisp | 505 +++++++++++++++++++++++++++++++++++++++ 1 file changed, 505 insertions(+) create mode 100644 compiler/array-tran.lisp diff --git a/compiler/array-tran.lisp b/compiler/array-tran.lisp new file mode 100644 index 000000000..848d59fbe --- /dev/null +++ b/compiler/array-tran.lisp @@ -0,0 +1,505 @@ +;;; -*- Package: C; Log: C.Log -*- +;;; +;;; ********************************************************************** +;;; This code was written as part of the Spice Lisp project at +;;; Carnegie-Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of Spice Lisp, please contact +;;; Scott Fahlman (FAHLMAN@CMUC). +;;; ********************************************************************** +;;; +;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/array-tran.lisp,v 1.1 1990/11/10 18:39:33 wlott Exp $ +;;; +;;; This file contains array specific optimizers and transforms. +;;; +;;; Extracted from srctran and extended by William Lott. +;;; +(in-package "C") + + +;;;; Derive-Type Optimizers + +;;; ASSERT-NUMBER-OF-ARGS -- internal +;;; +;;; Array operations that use a specific number of indices implicitly assert +;;; that the array is of that rank. +;;; +(defun assert-continuation-rank (array rank) + (assert-array-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 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)) + +;;; 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)) + (specifier-type + `(,(if (and (unsupplied-or-nil adjustable) + (unsupplied-or-nil displaced-to) + (unsupplied-or-nil fill-pointer)) + 'simple-array + 'array) + ,(cond ((not element-type) 't) + ((constant-continuation-p element-type) + (continuation-value element-type)) + (t + '*)) + ,(cond ((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) + (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)) + `(make-array ,length + :element-type 'base-character + :initial-element ',initial-element)) + +(defconstant array-info + '((base-character #\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) + (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 ((constructor + `(truly-the + ,spec + (allocate-vector + ,typecode + length + (truncate (+ (* ,(if (eq 'vm:simple-string-type typecode) + '(1+ length) + 'length) + ,element-size) + (1- vm:word-bits)) + vm:word-bits))))) + (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 sometime 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)) + +;;; 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) + `(aref (the ,',type ,a) ,@i)) + (def-source-transform ,setter (a &rest i) + `(%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)) -- GitLab