X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=3f17ce6023117a60b487f793185fab5687d45fab;hb=174feb792c8082846666e1218c58d5b0ab3b85b0;hp=e155ac2620be8c7b5f3ec67d1c5ae7a71456bbd7;hpb=fb1c04c157b26dd973fdf57e8319159eff04d98f;p=sbcl.git diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index e155ac2..3f17ce6 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -41,9 +41,19 @@ ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET +(deftransform hairy-data-vector-ref ((string index) (simple-string t)) + (let ((ctype (continuation-type string))) + (if (array-type-p ctype) + ;; the other transform will kick in, so that's OK + (give-up-ir1-transform) + `(etypecase string + ((simple-array character (*)) (data-vector-ref string index)) + ((simple-array nil (*)) (data-vector-ref string index)))))) + (deftransform hairy-data-vector-ref ((array index) (array t) * :important t) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array))) + (let ((element-ctype (extract-upgraded-element-type array)) + (declared-element-ctype (extract-declared-element-type array))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -54,21 +64,13 @@ ;; to hand-expand it ourselves.) (let ((element-type-specifier (type-specifier element-ctype))) `(multiple-value-bind (array index) - ;; FIXME: All this noise should move into a - ;; %DATA-VECTOR-AND-INDEX function, and there should be - ;; DEFTRANSFORMs for %DATA-VECTOR-AND-INDEX to optimize the - ;; function call away when the array is known to be simple, - ;; and to specialize to - ;; %DATA-VECTOR-AND-INDEX-IN-VECTOR-CASE when the array is - ;; known to have only one dimension. - (if (array-header-p array) - (%with-array-data array index nil) - (let ((array array)) - (declare (type (simple-array ,element-type-specifier 1) - array)) - (values array index))) + (%data-vector-and-index array index) (declare (type (simple-array ,element-type-specifier 1) array)) - (data-vector-ref array index))))) + ,(let ((bare-form '(data-vector-ref array index))) + (if (type= element-ctype declared-element-ctype) + bare-form + `(the ,(type-specifier declared-element-ctype) + ,bare-form))))))) (deftransform data-vector-ref ((array index) (simple-array t)) @@ -87,35 +89,40 @@ (%array-data-vector array)) index))))) +(deftransform hairy-data-vector-set ((string index new-value) + (simple-string t t)) + (let ((ctype (continuation-type string))) + (if (array-type-p ctype) + ;; the other transform will kick in, so that's OK + (give-up-ir1-transform) + `(etypecase string + ((simple-array character (*)) + (data-vector-set string index new-value)) + ((simple-array nil (*)) + (data-vector-set string index new-value)))))) + (deftransform hairy-data-vector-set ((array index new-value) (array t t) * :important t) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array))) + (let ((element-ctype (extract-upgraded-element-type array)) + (declared-element-ctype (extract-declared-element-type array))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform "Upgraded element type of array is not known at compile time.")) (let ((element-type-specifier (type-specifier element-ctype))) `(multiple-value-bind (array index) - ;; FIXME: All this noise should move into a - ;; %DATA-VECTOR-AND-INDEX function, and there should be - ;; DEFTRANSFORMs for %DATA-VECTOR-AND-INDEX to optimize the - ;; function call away when the array is known to be simple, - ;; and to specialize to - ;; %DATA-VECTOR-AND-INDEX-IN-VECTOR-CASE when the array is - ;; known to have only one dimension. - (if (array-header-p array) - (%with-array-data array index nil) - (let ((array array)) - (declare (type (simple-array ,element-type-specifier 1) - array)) - (values array index))) - (data-vector-set (truly-the (simple-array ,element-type-specifier 1) - array) - index - new-value))))) + (%data-vector-and-index array index) + (declare (type (simple-array ,element-type-specifier 1) array) + (type ,element-type-specifier new-value)) + ,(if (type= element-ctype declared-element-ctype) + '(data-vector-set array index new-value) + `(truly-the ,(type-specifier declared-element-ctype) + (data-vector-set array index + (the ,(type-specifier declared-element-ctype) + new-value)))))))) (deftransform data-vector-set ((array index new-value) (simple-array t t)) @@ -135,6 +142,39 @@ index new-value))))) +(defoptimizer (%data-vector-and-index derive-type) ((array index)) + (let ((atype (continuation-type array))) + (when (array-type-p atype) + (values-specifier-type + `(values (simple-array ,(type-specifier + (array-type-specialized-element-type atype)) + (*)) + index))))) + +(deftransform %data-vector-and-index ((%array %index) + (simple-array t) + * + :important t) + ;; KLUDGE: why the percent signs? Well, ARRAY and INDEX are + ;; respectively exported from the CL and SB!INT packages, which + ;; means that they're visible to all sorts of things. If the + ;; compiler can prove that the call to ARRAY-HEADER-P, below, either + ;; returns T or NIL, it will delete the irrelevant branch. However, + ;; user code might have got here with a variable named CL:ARRAY, and + ;; quite often compiler code with a variable named SB!INT:INDEX, so + ;; this can generate code deletion notes for innocuous user code: + ;; (DEFUN F (ARRAY I) (DECLARE (SIMPLE-VECTOR ARRAY)) (AREF ARRAY I)) + ;; -- CSR, 2003-04-01 + + ;; We do this solely for the -OR-GIVE-UP side effect, since we want + ;; to know that the type can be figured out in the end before we + ;; proceed, but we don't care yet what the type will turn out to be. + (upgraded-element-type-specifier-or-give-up %array) + + '(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 @@ -264,6 +304,74 @@ (type index index end-1)) (setf (%raw-bits result-bit-array index) (32bit-logical-not (%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)))) + ((= i end-1) + (let* ((extra (mod length sb!vm:n-word-bits)) + (mask (1- (ash 1 extra))) + (numx + (logand + (ash mask + ,(ecase sb!c:*backend-byte-order* + (:little-endian 0) + (:big-endian + '(- sb!vm:n-word-bits extra)))) + (%raw-bits x i))) + (numy + (logand + (ash mask + ,(ecase sb!c:*backend-byte-order* + (:little-endian 0) + (:big-endian + '(- sb!vm:n-word-bits extra)))) + (%raw-bits y i)))) + (declare (type (integer 0 31) extra) + (type (unsigned-byte 32) mask numx numy)) + (= numx numy))) + (declare (type index i end-1)) + (let ((numx (%raw-bits x i)) + (numy (%raw-bits y i))) + (declare (type (unsigned-byte 32) numx numy)) + (unless (= numx numy) + (return nil)))))))) + +;;; FIXME: it is probably worth doing something like this for +;;; SIMPLE-BASE-STRINGs too, if only so that (MAKE-STRING 100000 +;;; :INITIAL-ELEMENT #\Space) doesn't surprise the user with its +;;; performance characteristics. Getting it right is harder than with +;;; bit-vectors, though, as one needs to be more careful with the loop +;;; epilogue so as not to overwrite the convenient extra null byte +;;; (for SB-ALIEN/C termination convention convenience). +(deftransform fill ((sequence item) (simple-bit-vector bit) * + :policy (>= speed space)) + (let ((value (if (constant-continuation-p item) + (if (= (continuation-value item) 0) + 0 + #.(1- (ash 1 32))) + `(if (= item 0) 0 #.(1- (ash 1 32)))))) + `(let ((length (length sequence)) + (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-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)))) + ((= index end-1) + (setf (%raw-bits sequence index) value) + sequence) + (declare (optimize (speed 3) (safety 0)) + (type index index end-1)) + (setf (%raw-bits sequence index) value)))))) ;;;; %BYTE-BLT @@ -302,7 +410,7 @@ (memmove (sap+ (sapify dst) dst-start) (sap+ (sapify src) src-start) (- dst-end dst-start))) - nil)) + (values))) ;;;; transforms for EQL of floating point values @@ -313,3 +421,26 @@ '(and (= (double-float-low-bits x) (double-float-low-bits y)) (= (double-float-high-bits x) (double-float-high-bits y)))) + +;;;; 32-bit operations +#!-x86 ; on X86 it is a modular function +(deftransform lognot ((x) ((unsigned-byte 32)) * + :node node + :result result) + "32-bit implementation" + (let ((dest (continuation-dest result))) + (unless (and (combination-p dest) + (eq (continuation-fun-name (combination-fun dest)) + 'logand)) + (give-up-ir1-transform)) + (unless (some (lambda (arg) + (csubtypep (continuation-type arg) + (specifier-type '(unsigned-byte 32)))) + (combination-args dest)) + (give-up-ir1-transform)) + (setf (node-derived-type node) + (values-specifier-type '(values (unsigned-byte 32) &optional))) + '(32bit-logical-not x))) + +(define-good-modular-fun logand) +(define-good-modular-fun logior)