Commit d80c929a authored by wlott's avatar wlott
Browse files

Moved all the array noise into it's own file, array-tran.lisp.

parent a76bc618
......@@ -7,7 +7,7 @@
;;; Scott Fahlman (FAHLMAN@CMUC).
;;; **********************************************************************
;;;
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.19 1990/10/10 15:19:57 ram Exp $
;;; $Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/compiler/srctran.lisp,v 1.20 1990/11/10 18:39:00 wlott Exp $
;;;
;;; This file contains macro-like source transformations which convert
;;; uses of certain functions into the canonical form desired within the
......@@ -528,104 +528,6 @@
0
'*))))
;;;; Array derive-type optimizers:
(defoptimizer (array-in-bounds-p derive-type) ((array &rest indices))
(assert-continuation-type
array
(specifier-type `(array * ,(make-list (length indices)
:initial-element '*))))
*universal-type*)
(defoptimizer (aref derive-type) ((array &rest indices))
(assert-continuation-type
array
(specifier-type `(array * ,(make-list (length indices)
:initial-element '*))))
(let ((type (continuation-type array)))
(when (array-type-p type)
(array-type-element-type type))))
(defoptimizer (data-vector-ref derive-type) ((array index))
(let ((type (continuation-type array)))
(when (array-type-p type)
(array-type-element-type type))))
(defoptimizer (%aset derive-type) ((array &rest stuff))
(assert-continuation-type
array
(specifier-type `(array * ,(make-list (1- (length stuff))
:initial-element '*))))
(let ((type (continuation-type array)))
(when (array-type-p type)
(let ((val (car (last stuff)))
(eltype (array-type-element-type type)))
(assert-continuation-type val eltype)
(continuation-type val)))))
(defoptimizer (data-vector-set derive-type) ((array index new-value))
(let ((type (continuation-type array)))
(when (array-type-p type)
(let ((eltype (array-type-element-type type)))
(assert-continuation-type new-value eltype)
(continuation-type new-value)))))
(defoptimizer (array-row-major-index derive-type) ((array &rest indices))
(assert-continuation-type
array
(specifier-type `(array * ,(make-list (length indices)
:initial-element '*))))
*universal-type*)
(defoptimizer (row-major-aref derive-type) ((array index))
(let ((type (continuation-type array)))
(when (array-type-p type)
(array-type-element-type type))))
(defoptimizer (%set-row-major-aref derive-type) ((array index new-value))
(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)))))
(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
'*)))))
;;;; Miscellaneous derive-type methods:
......@@ -1339,245 +1241,6 @@
(give-up))
'(%negate y))
;;;; Array accessors:
;;;
;;; We convert all array accessors into aref and %aset.
;;;
(def-source-transform svref (a i) `(aref (the simple-vector ,a) ,i))
(def-source-transform %svset (a i v) `(%aset (the simple-vector ,a) ,i ,v))
(def-source-transform schar (a i) `(aref (the simple-string ,a) ,i))
(def-source-transform %scharset (a i v) `(%aset (the simple-string ,a) ,i ,v))
(def-source-transform char (a i) `(aref (the string ,a) ,i))
(def-source-transform %charset (a i v) `(%aset (the string ,a) ,i ,v))
(def-source-transform sbit (a &rest i) `(aref (the (simple-array bit) ,a) ,@i))
(def-source-transform %sbitset (a &rest i) `(%aset (the (simple-array bit) ,a) ,@i))
(def-source-transform bit (a &rest i) `(aref (the (array bit) ,a) ,@i))
(def-source-transform %bitset (a &rest i) `(%aset (the (array bit) ,a) ,@i))
(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))))
(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)))
(type (specifier-type spec)))
(cond ((csubtypep type (specifier-type 'simple-string))
(when initial-element
(give-up "Can't hack initial elements in strings."))
`(truly-the ,spec (%primitive alloc-string (the index length))))
((csubtypep type (specifier-type 'simple-bit-vector))
(unless (or (not initial-element)
(and (constant-continuation-p initial-element)
(eql (continuation-value initial-element) 0)))
(give-up "Can't hack non-zero initial-elements in bit-vectors."))
(values
`(truly-the ,spec
(%primitive allocate-vector
vm:simple-bit-vector-type
length
(the index
(ceiling length vm:word-bits))))
'((declare (type index length)))))
((csubtypep type (specifier-type 'simple-vector))
`(truly-the ,spec
(%primitive alloc-g-vector
(the index length)
initial-element)))
(t
(give-up "Can't open-code creation of ~S."
(type-specifier type))))))
;;; ### Should pass though any :INITIAL-ELEMENT to MAKE-ARRAY, but this would
;;; be a pessimization until the compiler can transform MAKE-ARRAY of strings
;;; with initial elements. Until then, it is faster to call MAKE-STRING than
;;; MAKE-ARRAY.
;;;
(def-source-transform make-string (length)
`(make-array ,length :element-type 'base-character))
;;; Transforms for various random array properties. If the property is know
;;; at compile time because of a type spec, use that constant value.
(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)
(length dims)))))
(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)))))))
(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))))
(deftransform length ((vector) (vector))
'(vector-length vector))
(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)
(if (member '* dims)
(do ((form 1 `(truly-the index
(* (truly-the index
(array-dimension array ,i))
,form)))
(i 0 (1+ i)))
((= i (length dims)) form))
(reduce #'* dims))))))
(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.")))))))
;;; 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)
;;; Array accessor/setter transforms.
(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))))
(deftransform array-row-major-index ((array &rest indices))
(with-row-major-index (array indices index)
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))))
(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))
;;;; Apply:
;;;
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment