X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Farray-tran.lisp;h=5a81b1a7d7669daef229012d7320723fea610031;hb=7f0f521aa3f6b45259c5dfd5f7f11adcd1a7cac6;hp=98befa5369fb4e259384317c7cea66bf27979b72;hpb=80304981972c91c1b3f3fca75f36dacf1fecf307;p=sbcl.git diff --git a/src/compiler/array-tran.lisp b/src/compiler/array-tran.lisp index 98befa5..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))))) @@ -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)) @@ -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) @@ -720,15 +704,14 @@ ;;; 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))))))