X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=d616f0976bff9552b4b2f2db1392d640862a009d;hb=51e63f301624e39febdd85b5feba19b7c980f307;hp=4d29fcf65b56a54f352dda7ed5c1c3e96a9c731a;hpb=8ef3aa533aba5ac5760e83b798cd6b2388a807a6;p=sbcl.git diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 4d29fcf..d616f09 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -19,7 +19,12 @@ (define-source-transform long-float-p (x) `(double-float-p ,x)) (define-source-transform compiled-function-p (x) - `(functionp ,x)) + #!-sb-eval + `(functionp ,x) + #!+sb-eval + (once-only ((x x)) + `(and (functionp ,x) + (not (sb!eval:interpreted-function-p ,x))))) (define-source-transform char-int (x) `(char-code ,x)) @@ -27,6 +32,48 @@ (deftransform abs ((x) (rational)) '(if (< x 0) (- x) x)) +;;; We don't want to clutter the bignum code. +#!+x86 +(define-source-transform sb!bignum:%bignum-ref (bignum index) + ;; KLUDGE: We use TRULY-THE here because even though the bignum code + ;; is (currently) compiled with (SAFETY 0), the compiler insists on + ;; inserting CAST nodes to ensure that INDEX is of the correct type. + ;; These CAST nodes do not generate any type checks, but they do + ;; interfere with the operation of FOLD-INDEX-ADDRESSING, below. + ;; This scenario is a problem for the more user-visible case of + ;; folding as well. --njf, 2006-12-01 + `(sb!bignum:%bignum-ref-with-offset ,bignum + (truly-the bignum-index ,index) 0)) + +#!+x86 +(defun fold-index-addressing (fun-name element-size lowtag data-offset + index offset &optional setter-p) + (multiple-value-bind (func index-args) (extract-fun-args index '(+ -) 2) + (destructuring-bind (x constant) index-args + (declare (ignorable x)) + (unless (constant-lvar-p constant) + (give-up-ir1-transform)) + (let ((value (lvar-value constant))) + (unless (and (integerp value) + (sb!vm::foldable-constant-offset-p + element-size lowtag data-offset + (funcall func value (lvar-value offset)))) + (give-up-ir1-transform "constant is too large for inlining")) + (splice-fun-args index func 2) + (format t "preparing to transform with ~A ~D~%" func value) + `(lambda (thing index off1 off2 ,@(when setter-p + '(value))) + (,fun-name thing index (,func off2 off1) ,@(when setter-p + '(value)))))))) + +#!+x86 +(deftransform sb!bignum:%bignum-ref-with-offset + ((bignum index offset) * * :node node) + (fold-index-addressing 'sb!bignum:%bignum-ref-with-offset + sb!vm:n-word-bits sb!vm:other-pointer-lowtag + sb!vm:bignum-digits-offset + index offset)) + ;;; The layout is stored in slot 0. (define-source-transform %instance-layout (x) `(truly-the layout (%instance-ref ,x 0))) @@ -52,10 +99,13 @@ ;; 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 character (*)) + (data-vector-ref string index)) #!+sb-unicode - ((simple-array base-char (*)) (data-vector-ref string index)) - ((simple-array nil (*)) (data-vector-ref string index)))))) + ((simple-array base-char (*)) + (data-vector-ref string index)) + ((simple-array nil (*)) + (data-vector-ref string index)))))) (deftransform hairy-data-vector-ref ((array index) (array t) *) "avoid runtime dispatch on array element type" @@ -69,7 +119,7 @@ ;; WITH-ARRAY-DATA. Since WITH-ARRAY-DATA is implemented as a ;; macro, and macros aren't expanded in transform output, we have ;; to hand-expand it ourselves.) - (let ((element-type-specifier (type-specifier element-ctype))) + (let* ((element-type-specifier (type-specifier element-ctype))) `(multiple-value-bind (array index) (%data-vector-and-index array index) (declare (type (simple-array ,element-type-specifier 1) array)) @@ -79,10 +129,9 @@ `(the ,(type-specifier declared-element-ctype) ,bare-form))))))) -;;; Transform multi-dimensional to one dimensional SIMPLE-ARRAY +;;; Transform multi-dimensional array to one dimensional data vector ;;; access. -(deftransform data-vector-ref ((array index) - (simple-array t)) +(deftransform data-vector-ref ((array index) (simple-array t)) (let ((array-type (lvar-type array))) (unless (array-type-p array-type) (give-up-ir1-transform)) @@ -98,6 +147,42 @@ (%array-data-vector array)) index))))) +;;; Transform data vector access to a form that opens up optimization +;;; opportunities. +#!+x86 +(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 element-type + sb!vm:*specialized-array-element-type-properties* + :key #'sb!vm:saetp-specifier :test #'equal))) + (unless (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits) + (give-up-ir1-transform)) + `(data-vector-ref-with-offset array index 0)))) + +#!+x86 +(deftransform data-vector-ref-with-offset ((array index offset) + ((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 element-type + sb!vm:*specialized-array-element-type-properties* + :key #'sb!vm:saetp-specifier :test #'equal))) + (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)) + (fold-index-addressing 'data-vector-ref-with-offset + (sb!vm:saetp-n-bits saetp) + sb!vm:other-pointer-lowtag + sb!vm:vector-data-offset + index offset)))) + (deftransform hairy-data-vector-set ((string index new-value) (simple-string t t)) (let ((ctype (lvar-type string))) @@ -135,6 +220,8 @@ (the ,(type-specifier declared-element-ctype) new-value)))))))) +;;; Transform multi-dimensional array to one dimensional data vector +;;; access. (deftransform data-vector-set ((array index new-value) (simple-array t t)) (let ((array-type (lvar-type array))) @@ -153,6 +240,42 @@ index new-value))))) +;;; Transform data vector access to a form that opens up optimization +;;; opportunities. +#!+x86 +(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 element-type + sb!vm:*specialized-array-element-type-properties* + :key #'sb!vm:saetp-specifier :test #'equal))) + (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)))) + +#!+x86 +(deftransform data-vector-set-with-offset ((array index offset new-value) + ((or simple-unboxed-array + simple-vector) + t 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 element-type + sb!vm:*specialized-array-element-type-properties* + :key #'sb!vm:saetp-specifier :test #'equal))) + (aver (>= (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)) + (fold-index-addressing 'data-vector-set-with-offset + (sb!vm:saetp-n-bits saetp) + sb!vm:other-pointer-lowtag + sb!vm:vector-data-offset + index offset t)))) + (defoptimizer (%data-vector-and-index derive-type) ((array index)) (let ((atype (lvar-type array))) (when (array-type-p atype) @@ -260,7 +383,7 @@ ;; epilogue. - CSR, 2002-04-24 (truncate (truly-the index (1- length)) sb!vm:n-word-bits)))) - ((= index end-1) + ((>= index end-1) (setf (%raw-bits result-bit-array index) (,',wordfun (%raw-bits bit-array-1 index) (%raw-bits bit-array-2 index))) @@ -306,7 +429,7 @@ ;; the epilogue. - CSR, 2002-04-24 (truncate (truly-the index (1- length)) sb!vm:n-word-bits)))) - ((= index end-1) + ((>= index end-1) (setf (%raw-bits result-bit-array index) (word-logical-not (%raw-bits bit-array index))) result-bit-array) @@ -322,7 +445,7 @@ (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) + ((>= i end-1) (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits))) (mask (ash #.(1- (ash 1 sb!vm:n-word-bits)) (- extra sb!vm:n-word-bits))) @@ -362,7 +485,7 @@ (end-1 (+ sb!vm:vector-data-offset (truncate (truly-the index (1- length)) sb!vm:n-word-bits)))) - ((= index end-1) + ((>= index end-1) (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits))) (mask (ash #.(1- (ash 1 sb!vm:n-word-bits)) (- extra sb!vm:n-word-bits))) @@ -374,24 +497,17 @@ (%raw-bits sequence index)))) (declare (type (integer 1 #.sb!vm:n-word-bits) extra)) (declare (type sb!vm:word mask bits)) - ;; could consider LOGNOT for the zero case instead of - ;; doing the subtraction... - (incf count ,(if (constant-lvar-p item) - (if (zerop (lvar-value item)) - '(- extra (logcount bits)) - '(logcount bits)) - '(if (zerop item) - (- extra (logcount bits)) - (logcount bits)))))) + (incf count (logcount bits)) + ,(if (constant-lvar-p item) + (if (zerop (lvar-value item)) + '(- length count) + 'count) + '(if (zerop item) + (- length count) + count)))) (declare (type index index count end-1) (optimize (speed 3) (safety 0))) - (incf count ,(if (constant-lvar-p item) - (if (zerop (lvar-value item)) - '(- sb!vm:n-word-bits (logcount (%raw-bits sequence index))) - '(logcount (%raw-bits sequence index))) - '(if (zerop item) - (- sb!vm:n-word-bits (logcount (%raw-bits sequence index))) - (logcount (%raw-bits sequence index))))))))) + (incf count (logcount (%raw-bits sequence index))))))) (deftransform fill ((sequence item) (simple-bit-vector bit) * :policy (>= speed space)) @@ -411,7 +527,7 @@ ;; in the epilogue. - CSR, 2002-04-24 (truncate (truly-the index (1- length)) sb!vm:n-word-bits)))) - ((= index end-1) + ((>= index end-1) (setf (%raw-bits sequence index) value) sequence) (declare (optimize (speed 3) (safety 0)) @@ -435,7 +551,7 @@ (truncate length sb!vm:n-word-bytes) (do ((index sb!vm:vector-data-offset (1+ index)) (end (+ times sb!vm:vector-data-offset))) - ((= index end) + ((>= index end) (let ((place (* times sb!vm:n-word-bytes))) (declare (fixnum place)) (dotimes (j rem sequence)