Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/pcl/src-16f.lha/compiler/array-tran.lisp

Text File | 1991-11-13 | 18.6 KB | 572 lines

;;; -*- 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.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or [e-mail].
;;;
(ext:file-comment
  "$Header: array-tran.lisp,v 1.14 91/11/12 14:14:14 ram 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)
  (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 (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)
    (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)
          `(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))


;;;; 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)))