X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=5a81b1a7d7669daef229012d7320723fea610031;hb=1bcf4fb22a25e713a0ab898d78abb97abe94c225;hp=1224c8508a50aaeebc2f785e9b33582a3df036c4;hpb=031ae238d37250e935dabaf2a3efb6e0305dd3e7;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 1224c85..5a81b1a 100644 --- a/src/compiler/array-tran.lisp +++ b/src/compiler/array-tran.lisp @@ -25,14 +25,6 @@ element-type-specifier))) ;;; Array access functions return an object from the array, hence its -;;; type will be asserted to be 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*))) - -;;; Array access functions return an object from the array, hence its ;;; type is going to be the array upgraded element type. (defun extract-upgraded-element-type (array) (let ((type (continuation-type array))) @@ -46,7 +38,7 @@ (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)))) + (assert-continuation-type new-value (array-type-specialized-element-type type)))) (continuation-type new-value)) ;;; Return true if Arg is NIL, or is a constant-continuation whose @@ -75,7 +67,7 @@ ;; If the node continuation has a single use then assert its type. (let ((cont (node-cont node))) (when (= (length (find-uses cont)) 1) - (assert-continuation-type cont (extract-element-type array)))) + (assert-continuation-type cont (extract-upgraded-element-type array)))) (extract-upgraded-element-type array)) (defoptimizer (%aset derive-type) ((array &rest stuff)) @@ -99,7 +91,7 @@ (when (array-type-p atype) (values-specifier-type `(values (simple-array ,(type-specifier - (array-type-element-type atype)) + (array-type-specialized-element-type atype)) (*)) index index index))))) @@ -141,31 +133,27 @@ ;;; Convert VECTOR into a MAKE-ARRAY followed by SETFs of all the ;;; elements. -(def-source-transform vector (&rest elements) - (if (byte-compiling) - (values nil t) - (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))))) +(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)))) + 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*)) - (if (byte-compiling) - (values nil t) - `(make-array (the index ,length) - :element-type ,element-type - :initial-element ,initial-element))) +(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)) (defstruct (specialized-array-element-type-properties (:conc-name saetp-) @@ -178,20 +166,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,32 +187,32 @@ (destructuring-bind (type-spec &rest rest) args (let ((ctype (specifier-type type-spec))) (apply #'!make-saetp ctype rest)))) - `((base-char ,(code-char 0) 8 ,sb!vm:simple-string-type + `((base-char ,(code-char 0) 8 ,sb!vm:simple-string-widetag ;; (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-type) - (double-float 0.0d0 64 ,sb!vm:simple-array-double-float-type) + (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-type) - (bit 0 1 ,sb!vm:simple-bit-vector-type) - ((unsigned-byte 2) 0 2 ,sb!vm:simple-array-unsigned-byte-2-type) - ((unsigned-byte 4) 0 4 ,sb!vm:simple-array-unsigned-byte-4-type) - ((unsigned-byte 8) 0 8 ,sb!vm:simple-array-unsigned-byte-8-type) - ((unsigned-byte 16) 0 16 ,sb!vm:simple-array-unsigned-byte-16-type) - ((unsigned-byte 32) 0 32 ,sb!vm:simple-array-unsigned-byte-32-type) - ((signed-byte 8) 0 8 ,sb!vm:simple-array-signed-byte-8-type) - ((signed-byte 16) 0 16 ,sb!vm:simple-array-signed-byte-16-type) - ((signed-byte 30) 0 32 ,sb!vm:simple-array-signed-byte-30-type) - ((signed-byte 32) 0 32 ,sb!vm:simple-array-signed-byte-32-type) - ((complex single-float) #C(0.0s0 0.0s0) 64 - ,sb!vm:simple-array-complex-single-float-type) + ,sb!vm:simple-array-long-float-widetag) + (bit 0 1 ,sb!vm:simple-bit-vector-widetag) + ((unsigned-byte 2) 0 2 ,sb!vm:simple-array-unsigned-byte-2-widetag) + ((unsigned-byte 4) 0 4 ,sb!vm:simple-array-unsigned-byte-4-widetag) + ((unsigned-byte 8) 0 8 ,sb!vm:simple-array-unsigned-byte-8-widetag) + ((unsigned-byte 16) 0 16 ,sb!vm:simple-array-unsigned-byte-16-widetag) + ((unsigned-byte 32) 0 32 ,sb!vm:simple-array-unsigned-byte-32-widetag) + ((signed-byte 8) 0 8 ,sb!vm:simple-array-signed-byte-8-widetag) + ((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.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-type) + ,sb!vm:simple-array-complex-double-float-widetag) #!+long-float ((complex long-float) #C(0.0L0 0.0L0) #!+x86 192 #!+sparc 256 - ,sb!vm:simple-array-complex-long-float-type) - (t 0 32 ,sb!vm:simple-vector-type)))) + ,sb!vm:simple-array-complex-long-float-widetag) + (t 0 32 ,sb!vm:simple-vector-widetag)))) ;;; The integer type restriction on the length ensures that it will be ;;; a vector. The lack of :ADJUSTABLE, :FILL-POINTER, and @@ -247,7 +235,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)) @@ -257,11 +245,11 @@ 'length `(+ length ,n-pad-elements))) (n-words-form - (if (>= n-bits-per-element sb!vm:word-bits) + (if (>= n-bits-per-element sb!vm:n-word-bits) `(* ,padded-length-form (the fixnum ; i.e., not RATIO - ,(/ n-bits-per-element sb!vm:word-bits))) - (let ((n-elements-per-word (/ sb!vm:word-bits + ,(/ n-bits-per-element sb!vm:n-word-bits))) + (let ((n-elements-per-word (/ sb!vm:n-word-bits n-bits-per-element))) (declare (type index n-elements-per-word)) ; i.e., not RATIO `(ceiling ,padded-length-form ,n-elements-per-word)))) @@ -331,7 +319,7 @@ (continuation-value element-type)) (t '*)) ,(make-list rank :initial-element '*)))) - `(let ((header (make-array-header sb!vm:simple-array-type ,rank))) + `(let ((header (make-array-header sb!vm:simple-array-widetag ,rank))) (setf (%array-fill-pointer header) ,total-size) (setf (%array-fill-pointer-p header) nil) (setf (%array-available-elements header) ,total-size) @@ -343,9 +331,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)))))) @@ -383,7 +371,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))) @@ -524,12 +512,7 @@ `(if (<= ,n-svalue ,n-end ,n-len) ;; success (values ,n-array ,n-svalue ,n-end 0) - ;; failure: Make a NOTINLINE call to - ;; %WITH-ARRAY-DATA with our bad data - ;; to cause the error to be signalled. - (locally - (declare (notinline %with-array-data)) - (%with-array-data ,n-array ,n-svalue ,n-evalue))))) + (failed-%with-array-data ,n-array ,n-svalue ,n-evalue)))) (,(if force-inline '%with-array-data-macro '%with-array-data) ,n-array ,n-svalue ,n-evalue)) ,@forms))) @@ -552,14 +535,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 @@ -573,16 +556,12 @@ (declare (type index ,cumulative-offset)))))) (deftransform %with-array-data ((array start end) - ;; Note: This transform is limited to - ;; VECTOR only because I happened to - ;; create it in order to get sequence - ;; function operations to be more - ;; efficient. It might very well be - ;; reasonable to allow general ARRAY - ;; here, I just haven't tried to - ;; understand the performance issues - ;; involved. -- WHN - (vector index (or index null)) + ;; It might very well be reasonable to + ;; allow general ARRAY here, I just + ;; haven't tried to understand the + ;; performance issues involved. -- + ;; WHN, and also CSR 2002-05-26 + ((or vector simple-array) index (or index null)) * :important t :node node @@ -599,14 +578,10 @@ ;;; assertions on the array. (macrolet ((define-frob (reffer setter type) `(progn - (def-source-transform ,reffer (a &rest i) - (if (byte-compiling) - (values nil t) - `(aref (the ,',type ,a) ,@i))) - (def-source-transform ,setter (a &rest i) - (if (byte-compiling) - (values nil t) - `(%aset (the ,',type ,a) ,@i)))))) + (define-source-transform ,reffer (a &rest i) + `(aref (the ,',type ,a) ,@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) (define-frob char %charset string) @@ -690,20 +665,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) @@ -712,24 +695,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))))))