X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=3f17ce6023117a60b487f793185fab5687d45fab;hb=174feb792c8082846666e1218c58d5b0ab3b85b0;hp=7c4cc00da832822b447fa959637e725d2d98e50d;hpb=b870615b146940f661e5d0e9069ca4e16e9f483d;p=sbcl.git diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 7c4cc00..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 @@ -56,7 +66,11 @@ `(multiple-value-bind (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)) @@ -75,12 +89,25 @@ (%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 @@ -90,9 +117,12 @@ (%data-vector-and-index array index) (declare (type (simple-array ,element-type-specifier 1) array) (type ,element-type-specifier new-value)) - (data-vector-set array - index - 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)) @@ -310,6 +340,38 @@ (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 @@ -348,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 @@ -359,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)