X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=2f3585a1852e446ecdc084b2a9c03f6e61adc6df;hb=d93e034b8a53d8e3d8d6fa8b768cb5952d3ee548;hp=066040c63df479c9f877e6979257cf8244f70ddd;hpb=545fa4548b327804cf78afe38a2ecd94ced86162;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 066040c..2f3585a 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -141,24 +141,24 @@ ;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the ;;; elements. -(def-source-transform vector (&rest elements) +(define-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)))) + ,@(mapcar (lambda (el) + (once-only ((n-val el)) + `(locally (declare (optimize (safety 0))) + (setf (svref ,n-vec ,(incf n)) + ,n-val)))) elements) ,n-vec)))) ;;; Just convert it into a MAKE-ARRAY. -(def-source-transform make-string (length &key - (element-type ''base-char) - (initial-element - '#.*default-init-char-form*)) +(define-source-transform make-string (length &key + (element-type ''base-char) + (initial-element + '#.*default-init-char-form*)) `(make-array (the index ,length) :element-type ,element-type :initial-element ,initial-element)) @@ -174,20 +174,20 @@ (:copier nil)) ;; the element type, e.g. # or ;; # - (ctype (required-argument) :type ctype :read-only t) + (ctype (missing-arg) :type ctype :read-only t) ;; what we get when the low-level vector-creation logic zeroes all ;; the bits (which also serves as the default value of MAKE-ARRAY's ;; :INITIAL-ELEMENT keyword) - (initial-element-default (required-argument) :read-only t) + (initial-element-default (missing-arg) :read-only t) ;; how many bits per element - (n-bits (required-argument) :type index :read-only t) + (n-bits (missing-arg) :type index :read-only t) ;; the low-level type code - (typecode (required-argument) :type index :read-only t) + (typecode (missing-arg) :type index :read-only t) ;; the number of extra elements we use at the end of the array for ;; low level hackery (e.g., one element for arrays of BASE-CHAR, ;; which is used for a fixed #\NULL so that when we call out to C ;; we don't need to cons a new copy) - (n-pad-elements (required-argument) :type index :read-only t)) + (n-pad-elements (missing-arg) :type index :read-only t)) (defparameter *specialized-array-element-type-properties* (map 'simple-vector @@ -199,7 +199,7 @@ ;; (SIMPLE-STRINGs are stored with an extra trailing ;; #\NULL for convenience in calling out to C.) :n-pad-elements 1) - (single-float 0.0s0 32 ,sb!vm:simple-array-single-float-widetag) + (single-float 0.0f0 32 ,sb!vm:simple-array-single-float-widetag) (double-float 0.0d0 64 ,sb!vm:simple-array-double-float-widetag) #!+long-float (long-float 0.0L0 #!+x86 96 #!+sparc 128 ,sb!vm:simple-array-long-float-widetag) @@ -213,7 +213,7 @@ ((signed-byte 16) 0 16 ,sb!vm:simple-array-signed-byte-16-widetag) ((signed-byte 30) 0 32 ,sb!vm:simple-array-signed-byte-30-widetag) ((signed-byte 32) 0 32 ,sb!vm:simple-array-signed-byte-32-widetag) - ((complex single-float) #C(0.0s0 0.0s0) 64 + ((complex single-float) #C(0.0f0 0.0f0) 64 ,sb!vm:simple-array-complex-single-float-widetag) ((complex double-float) #C(0.0d0 0.0d0) 128 ,sb!vm:simple-array-complex-double-float-widetag) @@ -243,7 +243,7 @@ *specialized-array-element-type-properties*))) (unless saetp (give-up-ir1-transform - "cannot open-code creation of ~S" spec)) + "cannot open-code creation of ~S" result-type-spec)) (let* ((initial-element-default (saetp-initial-element-default saetp)) (n-bits-per-element (saetp-n-bits saetp)) @@ -339,9 +339,9 @@ '(:initial-element initial-element)))) (setf (%array-displaced-p header) nil) ,@(let ((axis -1)) - (mapcar #'(lambda (dim) - `(setf (%array-dimension header ,(incf axis)) - ,dim)) + (mapcar (lambda (dim) + `(setf (%array-dimension header ,(incf axis)) + ,dim)) dims)) (truly-the ,spec header)))))) @@ -379,7 +379,7 @@ (give-up-ir1-transform "The array dimensions are unknown; must call ARRAY-DIMENSION at runtime.")) (unless (> (length dims) axis) - (abort-ir1-transform "The array has dimensions ~S, ~D is too large." + (abort-ir1-transform "The array has dimensions ~S, ~W is too large." dims axis)) (let ((dim (nth axis dims))) @@ -548,14 +548,14 @@ (cond (,end (unless (or ,unsafe? (<= ,end ,size)) ,(if fail-inline? - `(error "End ~D is greater than total size ~D." + `(error "End ~W is greater than total size ~W." ,end ,size) `(failed-%with-array-data ,array ,start ,end))) ,end) (t ,size)))) (unless (or ,unsafe? (<= ,start ,defaulted-end)) ,(if fail-inline? - `(error "Start ~D is greater than end ~D." ,start ,defaulted-end) + `(error "Start ~W is greater than end ~W." ,start ,defaulted-end) `(failed-%with-array-data ,array ,start ,end))) (do ((,data ,array (%array-data-vector ,data)) (,cumulative-offset 0 @@ -595,9 +595,9 @@ ;;; assertions on the array. (macrolet ((define-frob (reffer setter type) `(progn - (def-source-transform ,reffer (a &rest i) + (define-source-transform ,reffer (a &rest i) `(aref (the ,',type ,a) ,@i)) - (def-source-transform ,setter (a &rest i) + (define-source-transform ,setter (a &rest i) `(%aset (the ,',type ,a) ,@i))))) (define-frob svref %svset simple-vector) (define-frob schar %scharset simple-string) @@ -682,20 +682,28 @@ ;;;; 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 is 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))) +(macrolet ((def (fun) + `(progn + (deftransform ,fun ((bit-array-1 bit-array-2 + &optional result-bit-array) + (bit-vector bit-vector &optional null) * + :policy (>= speed space)) + `(,',fun bit-array-1 bit-array-2 + (make-array (length bit-array-1) :element-type 'bit))) + ;; If result is T, make it the first arg. + (deftransform ,fun ((bit-array-1 bit-array-2 result-bit-array) + (bit-vector bit-vector (member t)) *) + `(,',fun bit-array-1 bit-array-2 bit-array-1))))) + (def bit-and) + (def bit-ior) + (def bit-xor) + (def bit-eqv) + (def bit-nand) + (def bit-nor) + (def bit-andc1) + (def bit-andc2) + (def bit-orc1) + (def bit-orc2)) ;;; Similar for BIT-NOT, but there is only one arg... (deftransform bit-not ((bit-array-1 &optional result-bit-array) @@ -704,24 +712,23 @@ '(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-vector (constant-arg t))) '(bit-not bit-array-1 bit-array-1)) -;;; FIXME: What does (CONSTANT-ARGUMENT T) mean? Is it the same thing -;;; as (CONSTANT-ARGUMENT (MEMBER T)), or does it mean any constant +;;; FIXME: What does (CONSTANT-ARG T) mean? Is it the same thing +;;; as (CONSTANT-ARG (MEMBER T)), or does it mean any constant ;;; value? ;;; 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-ir1-transform)) (let ((dims (array-type-dimensions type))) (cond ((csubtypep type (specifier-type '(simple-array * (*)))) - ;; No array header. + ;; no array header nil) ((and (listp dims) (> (length dims) 1)) - ;; Multi-dimensional array, will have a header. + ;; multi-dimensional array, will have a header t) (t (give-up-ir1-transform))))))