X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=86efb42b77e26ececea35f1d3174932563f004d5;hb=dcf8b8ccc1e15a5c1c6aba00204b7d3a81827acc;hp=06009ee8e2059555632f2a856def0c6b5e2bc50c;hpb=f1ffbf976aaa50b7b22f126b97e34afe06a91210;p=sbcl.git diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 06009ee..86efb42 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,11 +32,56 @@ (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) + `(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))) (define-source-transform %set-instance-layout (x val) `(%instance-set ,x 0 (the layout ,val))) +(define-source-transform %funcallable-instance-layout (x) + `(truly-the layout (%funcallable-instance-info ,x 0))) +(define-source-transform %set-funcallable-instance-layout (x val) + `(setf (%funcallable-instance-info ,x 0) (the layout ,val))) ;;;; character support @@ -48,10 +98,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" @@ -65,7 +118,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)) @@ -75,8 +128,9 @@ `(the ,(type-specifier declared-element-ctype) ,bare-form))))))) -(deftransform data-vector-ref ((array index) - (simple-array t)) +;;; Transform multi-dimensional array to one dimensional data vector +;;; access. +(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)) @@ -92,6 +146,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))) @@ -129,6 +219,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))) @@ -147,6 +239,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) @@ -254,7 +382,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))) @@ -300,7 +428,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) @@ -316,7 +444,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))) @@ -356,7 +484,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))) @@ -368,24 +496,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)) @@ -405,7 +526,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)) @@ -429,7 +550,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) @@ -611,3 +732,14 @@ result) adds shifts))) + + +;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal +;;; VOP can't handle them. + +(deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg fixnum))) + (ash (lvar-value obj) sb!vm::n-fixnum-tag-bits)) + +(deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg character))) + (logior sb!vm::character-widetag + (ash (char-code (lvar-value obj)) sb!vm::n-widetag-bits)))