diff --git a/compiler/srctran.lisp b/compiler/srctran.lisp index 320dca818208732c7df2dde77d2618e4128e877a..df025b4387c5b438ffd4bb86adbb416f19aeb534 100644 --- a/compiler/srctran.lisp +++ b/compiler/srctran.lisp @@ -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: ;;;