X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=9d1108a5d294f7b62432d8f3b0d3a857ee9fd709;hb=5c41b6d95580938db33efd4640c2947b9e51e723;hp=d616f0976bff9552b4b2f2db1392d640862a009d;hpb=51e63f301624e39febdd85b5feba19b7c980f307;p=sbcl.git diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index d616f09..9d1108a 100644 --- a/src/compiler/generic/vm-tran.lisp +++ b/src/compiler/generic/vm-tran.lisp @@ -33,7 +33,7 @@ '(if (< x 0) (- x) x)) ;;; We don't want to clutter the bignum code. -#!+x86 +#!+(or x86 x86-64) (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 @@ -45,7 +45,7 @@ `(sb!bignum:%bignum-ref-with-offset ,bignum (truly-the bignum-index ,index) 0)) -#!+x86 +#!+(or x86 x86-64) (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) @@ -60,13 +60,12 @@ (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 +#!+(or x86 x86-64) (deftransform sb!bignum:%bignum-ref-with-offset ((bignum index offset) * * :node node) (fold-index-addressing 'sb!bignum:%bignum-ref-with-offset @@ -74,6 +73,31 @@ sb!vm:bignum-digits-offset index offset)) +#!+x86 +(progn +(define-source-transform sb!kernel:%vector-raw-bits (thing index) + `(sb!kernel:%raw-bits-with-offset ,thing ,index 2)) + +(define-source-transform sb!kernel:%raw-bits (thing index) + `(sb!kernel:%raw-bits-with-offset ,thing ,index 0)) + +(define-source-transform sb!kernel:%set-vector-raw-bits (thing index value) + `(sb!kernel:%set-raw-bits-with-offset ,thing ,index 2 ,value)) + +(define-source-transform sb!kernel:%set-raw-bits (thing index value) + `(sb!kernel:%set-raw-bits-with-offset ,thing ,index 0 ,value)) + +(deftransform sb!kernel:%raw-bits-with-offset ((thing index offset) * * :node node) + (fold-index-addressing 'sb!kernel:%raw-bits-with-offset + sb!vm:n-word-bits sb!vm:other-pointer-lowtag + 0 index offset)) + +(deftransform sb!kernel:%set-raw-bits-with-offset ((thing index offset value) * *) + (fold-index-addressing 'sb!kernel:%set-raw-bits-with-offset + sb!vm:n-word-bits sb!vm:other-pointer-lowtag + 0 index offset t)) +) ; PROGN + ;;; The layout is stored in slot 0. (define-source-transform %instance-layout (x) `(truly-the layout (%instance-ref ,x 0))) @@ -149,33 +173,29 @@ ;;; Transform data vector access to a form that opens up optimization ;;; opportunities. -#!+x86 -(deftransform data-vector-ref ((array index) ((or simple-unboxed-array +#!+(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 element-type - sb!vm:*specialized-array-element-type-properties* - :key #'sb!vm:saetp-specifier :test #'equal))) + (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)))) -#!+x86 +#!+(or x86 x86-64) (deftransform data-vector-ref-with-offset ((array index offset) - ((or simple-unboxed-array + ((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))) + (saetp (find-saetp element-type))) (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) @@ -242,33 +262,29 @@ ;;; Transform data vector access to a form that opens up optimization ;;; opportunities. -#!+x86 +#!+(or x86 x86-64) (deftransform data-vector-set ((array index new-value) - ((or simple-unboxed-array simple-vector) + ((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))) + (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)))) -#!+x86 +#!+(or x86 x86-64) (deftransform data-vector-set-with-offset ((array index offset new-value) - ((or simple-unboxed-array + ((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))) + (saetp (find-saetp element-type))) (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) @@ -733,3 +749,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)))