X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=287162b519b1d1425081143b0a3042acc0bb9221;hb=94c003b32e49fc11a182d50c405ffa18183aa005;hp=26d7855d2402968264457b01e47f4092d5388572;hpb=4413876742e64de8a5925c98d1925ba9e5f75d8d;p=sbcl.git diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 26d7855..287162b 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -73,31 +73,6 @@ sb!vm:bignum-digits-offset index offset)) -#!+x86 -(progn -(define-source-transform sb!kernel:%vector-raw-bits (thing index) - `(sb!kernel:%raw-bits-with-offset ,thing ,index 2)) - -(define-source-transform sb!kernel:%raw-bits (thing index) - `(sb!kernel:%raw-bits-with-offset ,thing ,index 0)) - -(define-source-transform sb!kernel:%set-vector-raw-bits (thing index value) - `(sb!kernel:%set-raw-bits-with-offset ,thing ,index 2 ,value)) - -(define-source-transform sb!kernel:%set-raw-bits (thing index value) - `(sb!kernel:%set-raw-bits-with-offset ,thing ,index 0 ,value)) - -(deftransform sb!kernel:%raw-bits-with-offset ((thing index offset) * * :node node) - (fold-index-addressing 'sb!kernel:%raw-bits-with-offset - sb!vm:n-word-bits sb!vm:other-pointer-lowtag - 0 index offset)) - -(deftransform sb!kernel:%set-raw-bits-with-offset ((thing index offset value) * *) - (fold-index-addressing 'sb!kernel:%set-raw-bits-with-offset - sb!vm:n-word-bits sb!vm:other-pointer-lowtag - 0 index offset t)) -) ; PROGN - ;;; The layout is stored in slot 0. (define-source-transform %instance-layout (x) `(truly-the layout (%instance-ref ,x 0))) @@ -131,10 +106,15 @@ ((simple-array nil (*)) (data-vector-ref string index)))))) -(deftransform hairy-data-vector-ref ((array index) (array t) *) +;;; This and the corresponding -SET transform work equally well on non-simple +;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases +;;; where it actually helped with non-simple arrays -- to the contrary, it +;;; only made for bigger and up 1o 100% slower code. +(deftransform hairy-data-vector-ref ((array index) (simple-array t) *) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array)) - (declared-element-ctype (extract-declared-element-type array))) + (let* ((type (lvar-type array)) + (element-ctype (array-type-upgraded-element-type type)) + (declared-element-ctype (array-type-declared-element-type type))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -213,12 +193,17 @@ ((simple-array nil (*)) (data-vector-set string index new-value)))))) +;;; This and the corresponding -REF transform work equally well on non-simple +;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases +;;; where it actually helped with non-simple arrays -- to the contrary, it +;;; only made for bigger and up 1o 100% slower code. (deftransform hairy-data-vector-set ((array index new-value) - (array t t) + (simple-array t t) *) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array)) - (declared-element-ctype (extract-declared-element-type array))) + (let* ((type (lvar-type array)) + (element-ctype (array-type-upgraded-element-type type)) + (declared-element-ctype (array-type-declared-element-type type))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -281,14 +266,32 @@ sb!vm:vector-data-offset index offset t)))) -(defoptimizer (%data-vector-and-index derive-type) ((array index)) - (let ((atype (lvar-type array))) +(defun maybe-array-data-vector-type-specifier (array-lvar) + (let ((atype (lvar-type array-lvar))) (when (array-type-p atype) - (values-specifier-type - `(values (simple-array ,(type-specifier - (array-type-specialized-element-type atype)) - (*)) - index))))) + (let ((dims (array-type-dimensions atype))) + (if (or (array-type-complexp atype) + (eq '* dims) + (notevery #'integerp dims)) + `(simple-array ,(type-specifier + (array-type-specialized-element-type atype)) + (*)) + `(simple-array ,(type-specifier + (array-type-specialized-element-type atype)) + (,(apply #'* dims)))))))) + +(macrolet ((def (name) + `(defoptimizer (,name derive-type) ((array-lvar)) + (let ((spec (maybe-array-data-vector-type-specifier array-lvar))) + (when spec + (specifier-type spec)))))) + (def %array-data-vector) + (def array-storage-vector)) + +(defoptimizer (%data-vector-and-index derive-type) ((array index)) + (let ((spec (maybe-array-data-vector-type-specifier array))) + (when spec + (values-specifier-type `(values ,spec index))))) (deftransform %data-vector-and-index ((%array %index) (simple-array t) @@ -312,41 +315,6 @@ '(if (array-header-p %array) (values (%array-data-vector %array) %index) (values %array %index))) - -;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8) -;;; -;;; FIXME: In CMU CL, these were commented out with #+NIL. Why? Should -;;; we fix them or should we delete them? (Perhaps these definitions -;;; predate the various DATA-VECTOR-REF-FOO VOPs which have -;;; (:TRANSLATE DATA-VECTOR-REF), and are redundant now?) -#+nil -(macrolet - ((frob (type bits) - (let ((elements-per-word (truncate sb!vm:n-word-bits bits))) - `(progn - (deftransform data-vector-ref ((vector index) - (,type *)) - `(multiple-value-bind (word bit) - (floor index ,',elements-per-word) - (ldb ,(ecase sb!vm:target-byte-order - (:little-endian '(byte ,bits (* bit ,bits))) - (:big-endian '(byte ,bits (- sb!vm:n-word-bits - (* (1+ bit) ,bits))))) - (%raw-bits vector (+ word sb!vm:vector-data-offset))))) - (deftransform data-vector-set ((vector index new-value) - (,type * *)) - `(multiple-value-bind (word bit) - (floor index ,',elements-per-word) - (setf (ldb ,(ecase sb!vm:target-byte-order - (:little-endian '(byte ,bits (* bit ,bits))) - (:big-endian - '(byte ,bits (- sb!vm:n-word-bits - (* (1+ bit) ,bits))))) - (%raw-bits vector (+ word sb!vm:vector-data-offset))) - new-value))))))) - (frob simple-bit-vector 1) - (frob (simple-array (unsigned-byte 2) (*)) 2) - (frob (simple-array (unsigned-byte 4) (*)) 4)) ;;;; BIT-VECTOR hackery @@ -380,24 +348,23 @@ ;; are handled by the (1- length), below. ;; CSR, 2002-04-24 result-bit-array - (do ((index sb!vm:vector-data-offset (1+ index)) - (end-1 (+ sb!vm:vector-data-offset - ;; bit-vectors of length 1-32 - ;; need precisely one (SETF - ;; %RAW-BITS), done here in the - ;; epilogue. - CSR, 2002-04-24 - (truncate (truly-the index (1- length)) - sb!vm:n-word-bits)))) + (do ((index 0 (1+ index)) + ;; bit-vectors of length 1-32 need + ;; precisely one (SETF %VECTOR-RAW-BITS), + ;; done here in the epilogue. - CSR, + ;; 2002-04-24 + (end-1 (truncate (truly-the index (1- length)) + sb!vm:n-word-bits))) ((>= index end-1) - (setf (%raw-bits result-bit-array index) - (,',wordfun (%raw-bits bit-array-1 index) - (%raw-bits bit-array-2 index))) + (setf (%vector-raw-bits result-bit-array index) + (,',wordfun (%vector-raw-bits bit-array-1 index) + (%vector-raw-bits bit-array-2 index))) result-bit-array) (declare (optimize (speed 3) (safety 0)) (type index index end-1)) - (setf (%raw-bits result-bit-array index) - (,',wordfun (%raw-bits bit-array-1 index) - (%raw-bits bit-array-2 index)))))))))) + (setf (%vector-raw-bits result-bit-array index) + (,',wordfun (%vector-raw-bits bit-array-1 index) + (%vector-raw-bits bit-array-2 index)))))))))) (def bit-and word-logical-and) (def bit-ior word-logical-or) (def bit-xor word-logical-xor) @@ -427,29 +394,27 @@ ;; n-word-bits cases are handled by the (1- length), below. ;; CSR, 2002-04-24 result-bit-array - (do ((index sb!vm:vector-data-offset (1+ index)) - (end-1 (+ sb!vm:vector-data-offset - ;; bit-vectors of length 1 to n-word-bits need - ;; precisely one (SETF %RAW-BITS), done here in - ;; the epilogue. - CSR, 2002-04-24 - (truncate (truly-the index (1- length)) - sb!vm:n-word-bits)))) + (do ((index 0 (1+ index)) + ;; bit-vectors of length 1 to n-word-bits need precisely + ;; one (SETF %VECTOR-RAW-BITS), done here in the + ;; epilogue. - CSR, 2002-04-24 + (end-1 (truncate (truly-the index (1- length)) + sb!vm:n-word-bits))) ((>= index end-1) - (setf (%raw-bits result-bit-array index) - (word-logical-not (%raw-bits bit-array index))) + (setf (%vector-raw-bits result-bit-array index) + (word-logical-not (%vector-raw-bits bit-array index))) result-bit-array) (declare (optimize (speed 3) (safety 0)) (type index index end-1)) - (setf (%raw-bits result-bit-array index) - (word-logical-not (%raw-bits bit-array index)))))))) + (setf (%vector-raw-bits result-bit-array index) + (word-logical-not (%vector-raw-bits bit-array index)))))))) (deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector)) `(and (= (length x) (length y)) (let ((length (length x))) (or (= length 0) - (do* ((i sb!vm:vector-data-offset (+ i 1)) - (end-1 (+ sb!vm:vector-data-offset - (floor (1- length) sb!vm:n-word-bits)))) + (do* ((i 0 (+ i 1)) + (end-1 (floor (1- length) sb!vm:n-word-bits))) ((>= i end-1) (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits))) (mask (ash #.(1- (ash 1 sb!vm:n-word-bits)) @@ -461,7 +426,7 @@ (:little-endian 0) (:big-endian '(- sb!vm:n-word-bits extra)))) - (%raw-bits x i))) + (%vector-raw-bits x i))) (numy (logand (ash mask @@ -469,13 +434,13 @@ (:little-endian 0) (:big-endian '(- sb!vm:n-word-bits extra)))) - (%raw-bits y i)))) + (%vector-raw-bits y i)))) (declare (type (integer 1 #.sb!vm:n-word-bits) extra) (type sb!vm:word mask numx numy)) (= numx numy))) (declare (type index i end-1)) - (let ((numx (%raw-bits x i)) - (numy (%raw-bits y i))) + (let ((numx (%vector-raw-bits x i)) + (numy (%vector-raw-bits y i))) (declare (type sb!vm:word numx numy)) (unless (= numx numy) (return nil)))))))) @@ -485,11 +450,10 @@ `(let ((length (length sequence))) (if (zerop length) 0 - (do ((index sb!vm:vector-data-offset (1+ index)) + (do ((index 0 (1+ index)) (count 0) - (end-1 (+ sb!vm:vector-data-offset - (truncate (truly-the index (1- length)) - sb!vm:n-word-bits)))) + (end-1 (truncate (truly-the index (1- length)) + sb!vm:n-word-bits))) ((>= index end-1) (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits))) (mask (ash #.(1- (ash 1 sb!vm:n-word-bits)) @@ -499,7 +463,7 @@ (:little-endian 0) (:big-endian '(- sb!vm:n-word-bits extra)))) - (%raw-bits sequence index)))) + (%vector-raw-bits sequence index)))) (declare (type (integer 1 #.sb!vm:n-word-bits) extra)) (declare (type sb!vm:word mask bits)) (incf count (logcount bits)) @@ -512,7 +476,7 @@ count)))) (declare (type index index count end-1) (optimize (speed 3) (safety 0))) - (incf count (logcount (%raw-bits sequence index))))))) + (incf count (logcount (%vector-raw-bits sequence index))))))) (deftransform fill ((sequence item) (simple-bit-vector bit) * :policy (>= speed space)) @@ -525,19 +489,18 @@ (value ,value)) (if (= length 0) sequence - (do ((index sb!vm:vector-data-offset (1+ index)) - (end-1 (+ sb!vm:vector-data-offset - ;; bit-vectors of length 1 to n-word-bits need - ;; precisely one (SETF %RAW-BITS), done here - ;; in the epilogue. - CSR, 2002-04-24 - (truncate (truly-the index (1- length)) - sb!vm:n-word-bits)))) + (do ((index 0 (1+ index)) + ;; bit-vectors of length 1 to n-word-bits need precisely + ;; one (SETF %VECTOR-RAW-BITS), done here in the + ;; epilogue. - CSR, 2002-04-24 + (end-1 (truncate (truly-the index (1- length)) + sb!vm:n-word-bits))) ((>= index end-1) - (setf (%raw-bits sequence index) value) + (setf (%vector-raw-bits sequence index) value) sequence) (declare (optimize (speed 3) (safety 0)) (type index index end-1)) - (setf (%raw-bits sequence index) value)))))) + (setf (%vector-raw-bits sequence index) value)))))) (deftransform fill ((sequence item) (simple-base-string base-char) * :policy (>= speed space)) @@ -554,8 +517,8 @@ (value ,value)) (multiple-value-bind (times rem) (truncate length sb!vm:n-word-bytes) - (do ((index sb!vm:vector-data-offset (1+ index)) - (end (+ times sb!vm:vector-data-offset))) + (do ((index 0 (1+ index)) + (end times)) ((>= index end) (let ((place (* times sb!vm:n-word-bytes))) (declare (fixnum place)) @@ -564,7 +527,7 @@ (setf (schar sequence (the index (+ place j))) item)))) (declare (optimize (speed 3) (safety 0)) (type index index)) - (setf (%raw-bits sequence index) value)))))) + (setf (%vector-raw-bits sequence index) value)))))) ;;;; %BYTE-BLT @@ -606,10 +569,11 @@ (values))) ;;;; transforms for EQL of floating point values - +#!-float-eql-vops (deftransform eql ((x y) (single-float single-float)) '(= (single-float-bits x) (single-float-bits y))) +#!-float-eql-vops (deftransform eql ((x y) (double-float double-float)) '(and (= (double-float-low-bits x) (double-float-low-bits y)) (= (double-float-high-bits x) (double-float-high-bits y))))