X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=26d7855d2402968264457b01e47f4092d5388572;hb=dcd86042bba514f5dfc39246de9cdbb030648569;hp=9d1108a5d294f7b62432d8f3b0d3a857ee9fd709;hpb=906ecd4ef2d10aca23e1081f03c13fe2f932ed89;p=sbcl.git diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 9d1108a..26d7855 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -172,31 +172,26 @@ index))))) ;;; Transform data vector access to a form that opens up optimization -;;; opportunities. +;;; opportunities. On platforms that support DATA-VECTOR-REF-WITH-OFFSET +;;; DATA-VECTOR-REF is not supported at all. #!+(or x86 x86-64) -(deftransform data-vector-ref ((array index) ((or (simple-unboxed-array (*)) - simple-vector) - t)) - (let ((array-type (lvar-type array))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let* ((element-type (type-specifier (array-type-specialized-element-type array-type))) - (saetp (find-saetp element-type))) - (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits) - (give-up-ir1-transform)) - `(data-vector-ref-with-offset array index 0)))) +(define-source-transform data-vector-ref (array index) + `(data-vector-ref-with-offset ,array ,index 0)) #!+(or x86 x86-64) -(deftransform data-vector-ref-with-offset ((array index offset) - ((or (simple-unboxed-array (*)) - simple-vector) - t t)) +(deftransform data-vector-ref-with-offset ((array index offset)) (let ((array-type (lvar-type array))) - (unless (array-type-p array-type) + (when (or (not (array-type-p array-type)) + (eql (array-type-specialized-element-type array-type) + *wild-type*)) (give-up-ir1-transform)) + ;; It shouldn't be possible to get here with anything but a non-complex + ;; vector. + (aver (not (array-type-complexp array-type))) (let* ((element-type (type-specifier (array-type-specialized-element-type array-type))) (saetp (find-saetp element-type))) - (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)) + (when (< (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits) + (give-up-ir1-transform)) (fold-index-addressing 'data-vector-ref-with-offset (sb!vm:saetp-n-bits saetp) sb!vm:other-pointer-lowtag @@ -263,29 +258,23 @@ ;;; Transform data vector access to a form that opens up optimization ;;; opportunities. #!+(or x86 x86-64) -(deftransform data-vector-set ((array index new-value) - ((or (simple-unboxed-array (*)) simple-vector) - t t)) - (let ((array-type (lvar-type array))) - (unless (array-type-p array-type) - (give-up-ir1-transform)) - (let* ((element-type (type-specifier (array-type-specialized-element-type array-type))) - (saetp (find-saetp element-type))) - (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits) - (give-up-ir1-transform)) - `(data-vector-set-with-offset array index 0 new-value)))) +(define-source-transform data-vector-set (array index new-value) + `(data-vector-set-with-offset ,array ,index 0 ,new-value)) #!+(or x86 x86-64) -(deftransform data-vector-set-with-offset ((array index offset new-value) - ((or (simple-unboxed-array (*)) - simple-vector) - t t t)) +(deftransform data-vector-set-with-offset ((array index offset new-value)) (let ((array-type (lvar-type array))) - (unless (array-type-p array-type) + (when (or (not (array-type-p array-type)) + (eql (array-type-specialized-element-type array-type) + *wild-type*)) + ;; We don't yet know the exact element type, but will get that + ;; knowledge after some more type propagation. (give-up-ir1-transform)) + (aver (not (array-type-complexp array-type))) (let* ((element-type (type-specifier (array-type-specialized-element-type array-type))) (saetp (find-saetp element-type))) - (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)) + (when (< (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits) + (give-up-ir1-transform)) (fold-index-addressing 'data-vector-set-with-offset (sb!vm:saetp-n-bits saetp) sb!vm:other-pointer-lowtag @@ -610,7 +599,7 @@ ;; declare it in the DEFKNOWN too.) ((simple-unboxed-array (*)) (vector-sap thing))))) (declare (inline sapify)) - (without-gcing + (with-pinned-objects (dst src) (memmove (sap+ (sapify dst) dst-start) (sap+ (sapify src) src-start) (- dst-end dst-start))) @@ -627,40 +616,58 @@ ;;;; modular functions -(define-good-modular-fun logand :unsigned) -(define-good-modular-fun logior :unsigned) -;;; FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16 +;;; +;;; FIXME: I think that the :GOODness of a modular function boils down +;;; to whether the normal definition can be used in the middle of a +;;; modular arrangement. LOGAND and LOGIOR can be for all unsigned +;;; modular implementations, I believe, because for all unsigned +;;; arguments of a given size the result of the ordinary definition is +;;; the right one. This should follow through to other logical +;;; functions, such as LOGXOR, should it not? -- CSR, 2007-12-29, +;;; trying to understand a comment he wrote over four years +;;; previously: "FIXME: XOR? ANDC1, ANDC2? -- CSR, 2003-09-16" +(define-good-modular-fun logand :untagged nil) +(define-good-modular-fun logior :untagged nil) +(define-good-modular-fun logxor :untagged nil) +(macrolet ((define-good-signed-modular-funs (&rest funs) + (let (result) + `(progn + ,@(dolist (fun funs (nreverse result)) + (push `(define-good-modular-fun ,fun :untagged t) result) + (push `(define-good-modular-fun ,fun :tagged t) result)))))) + (define-good-signed-modular-funs + logand logandc1 logandc2 logeqv logior lognand lognor lognot + logorc1 logorc2 logxor)) (macrolet - ((def (name class width) - (let ((type (ecase class - (:unsigned 'unsigned-byte) - (:signed 'signed-byte)))) + ((def (name kind width signedp) + (let ((type (ecase signedp + ((nil) 'unsigned-byte) + ((t) 'signed-byte)))) `(progn (defknown ,name (integer (integer 0)) (,type ,width) (foldable flushable movable)) - (define-modular-fun-optimizer ash ((integer count) ,class :width width) + (define-modular-fun-optimizer ash ((integer count) ,kind ,signedp :width width) (when (and (<= width ,width) (or (and (constant-lvar-p count) (plusp (lvar-value count))) (csubtypep (lvar-type count) (specifier-type '(and unsigned-byte fixnum))))) - (cut-to-width integer ,class width) + (cut-to-width integer ,kind width ,signedp) ',name)) - (setf (gethash ',name (modular-class-versions (find-modular-class ',class))) + (setf (gethash ',name (modular-class-versions (find-modular-class ',kind ',signedp))) `(ash ,',width)))))) ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we ;; don't have a true Alpha64 port yet, we'll have to stick to ;; SB!VM:N-MACHINE-WORD-BITS for the time being. --njf, 2004-08-14 #!+#.(cl:if (cl:= 32 sb!vm:n-machine-word-bits) '(and) '(or)) (progn - #!+x86 (def sb!vm::ash-left-smod30 :signed 30) - (def sb!vm::ash-left-mod32 :unsigned 32)) + #!+x86 (def sb!vm::ash-left-smod30 :tagged 30 t) + (def sb!vm::ash-left-mod32 :untagged 32 nil)) #!+#.(cl:if (cl:= 64 sb!vm:n-machine-word-bits) '(and) '(or)) (progn - #!+x86-64 (def sb!vm::ash-left-smod61 :signed 61) - (def sb!vm::ash-left-mod64 :unsigned 64))) - + #!+x86-64 (def sb!vm::ash-left-smod61 :tagged 61 t) + (def sb!vm::ash-left-mod64 :untagged 64 nil))) ;;;; word-wise logical operations