X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=5a81b1a7d7669daef229012d7320723fea610031;hb=1bcf4fb22a25e713a0ab898d78abb97abe94c225;hp=0e1990de5e1e0555834d63bcae5fb627a5b1d483;hpb=4ad052044a22f502d9dc6faf6dfe01f3bab84262;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 0e1990d..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))))) @@ -146,11 +138,11 @@ (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)))) @@ -199,7 +191,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 +205,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 +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)) @@ -339,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)))))) @@ -520,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))) @@ -569,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 @@ -682,9 +665,10 @@ ;;;; and eliminates the need for any VM-dependent transforms to handle ;;;; these cases. -(macrolet ((def-frob (fun) +(macrolet ((def (fun) `(progn - (deftransform ,fun ((bit-array-1 bit-array-2 &optional result-bit-array) + (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 @@ -693,16 +677,16 @@ (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-frob bit-and) - (def-frob bit-ior) - (def-frob bit-xor) - (def-frob bit-eqv) - (def-frob bit-nand) - (def-frob bit-nor) - (def-frob bit-andc1) - (def-frob bit-andc2) - (def-frob bit-orc1) - (def-frob bit-orc2)) + (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) @@ -711,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))))))