X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fgeneric%2Fvm-tran.lisp;h=f390c6f3e04f6b636d726efb964fc3e9e0ffbb4c;hb=HEAD;hp=2542c12cb224d5e4f03a6a299e64bdcddacd8584;hpb=f12f2c5a8ae794dc414dd6a42e0b25740d576aa1;p=sbcl.git diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp index 2542c12..f390c6f 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,51 @@ (deftransform abs ((x) (rational)) '(if (< x 0) (- x) x)) +;;; We don't want to clutter the bignum code. +#!+(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 + ;; 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)) + +#!+(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) + (destructuring-bind (x constant) index-args + (unless (and (constant-lvar-p constant) + ;; we lose if the remaining argument isn't a fixnum + (csubtypep (lvar-type x) (specifier-type 'fixnum))) + (give-up-ir1-transform)) + (let ((value (lvar-value constant)) + new-offset) + (unless (and (integerp value) + (sb!vm::foldable-constant-offset-p + element-size lowtag data-offset + (setf new-offset (funcall func (lvar-value offset) + value)))) + (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))) + (declare (ignore off1 off2)) + (,fun-name thing index ',new-offset ,@(when setter-p + '(value)))))))) + +#!+(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 + 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))) @@ -37,13 +87,6 @@ (define-source-transform %set-funcallable-instance-layout (x val) `(setf (%funcallable-instance-info ,x 0) (the layout ,val))) -;;;; character support - -;;; In our implementation there are really only BASE-CHARs. -#+nil -(define-source-transform characterp (obj) - `(base-char-p ,obj)) - ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET (deftransform hairy-data-vector-ref ((string index) (simple-string t)) @@ -52,15 +95,23 @@ ;; 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) *) +;;; This and the corresponding -SET transform work equally well on non-simple +;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases +;;; where it actually helped with non-simple arrays -- to the contrary, it +;;; only made for bigger and up to 100% slower code. +(deftransform hairy-data-vector-ref ((array index) (simple-array t) *) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array)) - (declared-element-ctype (extract-declared-element-type array))) + (let* ((type (lvar-type array)) + (element-ctype (array-type-upgraded-element-type type)) + (declared-element-ctype (array-type-declared-element-type type))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -69,7 +120,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,8 +130,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)) @@ -96,6 +148,33 @@ (%array-data-vector array)) index))))) +;;; Transform data vector access to a form that opens up optimization +;;; opportunities. On platforms that support DATA-VECTOR-REF-WITH-OFFSET +;;; DATA-VECTOR-REF is not supported at all. +#!+(or x86 x86-64) +(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)) + (let ((array-type (lvar-type array))) + (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))) + (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 + 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))) @@ -111,12 +190,17 @@ ((simple-array nil (*)) (data-vector-set string index new-value)))))) +;;; This and the corresponding -REF transform work equally well on non-simple +;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases +;;; where it actually helped with non-simple arrays -- to the contrary, it +;;; only made for bigger and up 1o 100% slower code. (deftransform hairy-data-vector-set ((array index new-value) - (array t t) + (simple-array t t) *) "avoid runtime dispatch on array element type" - (let ((element-ctype (extract-upgraded-element-type array)) - (declared-element-ctype (extract-declared-element-type array))) + (let* ((type (lvar-type array)) + (element-ctype (array-type-upgraded-element-type type)) + (declared-element-ctype (array-type-declared-element-type type))) (declare (type ctype element-ctype)) (when (eq *wild-type* element-ctype) (give-up-ir1-transform @@ -133,6 +217,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))) @@ -151,14 +237,58 @@ index new-value))))) -(defoptimizer (%data-vector-and-index derive-type) ((array index)) - (let ((atype (lvar-type array))) +;;; Transform data vector access to a form that opens up optimization +;;; opportunities. +#!+(or x86 x86-64) +(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)) + (let ((array-type (lvar-type array))) + (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))) + (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 + sb!vm:vector-data-offset + index offset t)))) + +(defun maybe-array-data-vector-type-specifier (array-lvar) + (let ((atype (lvar-type array-lvar))) (when (array-type-p atype) - (values-specifier-type - `(values (simple-array ,(type-specifier - (array-type-specialized-element-type atype)) - (*)) - index))))) + (let ((dims (array-type-dimensions atype))) + (if (or (array-type-complexp atype) + (eq '* dims) + (notevery #'integerp dims)) + `(simple-array ,(type-specifier + (array-type-specialized-element-type atype)) + (*)) + `(simple-array ,(type-specifier + (array-type-specialized-element-type atype)) + (,(apply #'* dims)))))))) + +(macrolet ((def (name) + `(defoptimizer (,name derive-type) ((array-lvar)) + (let ((spec (maybe-array-data-vector-type-specifier array-lvar))) + (when spec + (specifier-type spec)))))) + (def %array-data-vector) + (def array-storage-vector)) + +(defoptimizer (%data-vector-and-index derive-type) ((array index)) + (let ((spec (maybe-array-data-vector-type-specifier array))) + (when spec + (values-specifier-type `(values ,spec index))))) (deftransform %data-vector-and-index ((%array %index) (simple-array t) @@ -182,41 +312,6 @@ '(if (array-header-p %array) (values (%array-data-vector %array) %index) (values %array %index))) - -;;; transforms for getting at simple arrays of (UNSIGNED-BYTE N) when (< N 8) -;;; -;;; FIXME: In CMU CL, these were commented out with #+NIL. Why? Should -;;; we fix them or should we delete them? (Perhaps these definitions -;;; predate the various DATA-VECTOR-REF-FOO VOPs which have -;;; (:TRANSLATE DATA-VECTOR-REF), and are redundant now?) -#+nil -(macrolet - ((frob (type bits) - (let ((elements-per-word (truncate sb!vm:n-word-bits bits))) - `(progn - (deftransform data-vector-ref ((vector index) - (,type *)) - `(multiple-value-bind (word bit) - (floor index ,',elements-per-word) - (ldb ,(ecase sb!vm:target-byte-order - (:little-endian '(byte ,bits (* bit ,bits))) - (:big-endian '(byte ,bits (- sb!vm:n-word-bits - (* (1+ bit) ,bits))))) - (%raw-bits vector (+ word sb!vm:vector-data-offset))))) - (deftransform data-vector-set ((vector index new-value) - (,type * *)) - `(multiple-value-bind (word bit) - (floor index ,',elements-per-word) - (setf (ldb ,(ecase sb!vm:target-byte-order - (:little-endian '(byte ,bits (* bit ,bits))) - (:big-endian - '(byte ,bits (- sb!vm:n-word-bits - (* (1+ bit) ,bits))))) - (%raw-bits vector (+ word sb!vm:vector-data-offset))) - new-value))))))) - (frob simple-bit-vector 1) - (frob (simple-array (unsigned-byte 2) (*)) 2) - (frob (simple-array (unsigned-byte 4) (*)) 4)) ;;;; BIT-VECTOR hackery @@ -250,24 +345,23 @@ ;; are handled by the (1- length), below. ;; CSR, 2002-04-24 result-bit-array - (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 result-bit-array index) - (,',wordfun (%raw-bits bit-array-1 index) - (%raw-bits bit-array-2 index))) + (do ((index 0 (1+ index)) + ;; bit-vectors of length 1-32 need + ;; precisely one (SETF %VECTOR-RAW-BITS), + ;; done here in the epilogue. - CSR, + ;; 2002-04-24 + (end-1 (truncate (truly-the index (1- length)) + sb!vm:n-word-bits))) + ((>= index end-1) + (setf (%vector-raw-bits result-bit-array index) + (,',wordfun (%vector-raw-bits bit-array-1 index) + (%vector-raw-bits bit-array-2 index))) result-bit-array) (declare (optimize (speed 3) (safety 0)) (type index index end-1)) - (setf (%raw-bits result-bit-array index) - (,',wordfun (%raw-bits bit-array-1 index) - (%raw-bits bit-array-2 index)))))))))) + (setf (%vector-raw-bits result-bit-array index) + (,',wordfun (%vector-raw-bits bit-array-1 index) + (%vector-raw-bits bit-array-2 index)))))))))) (def bit-and word-logical-and) (def bit-ior word-logical-or) (def bit-xor word-logical-xor) @@ -297,30 +391,28 @@ ;; n-word-bits cases are handled by the (1- length), below. ;; CSR, 2002-04-24 result-bit-array - (do ((index sb!vm:vector-data-offset (1+ index)) - (end-1 (+ sb!vm:vector-data-offset - ;; bit-vectors of length 1 to n-word-bits 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 result-bit-array index) - (word-logical-not (%raw-bits bit-array index))) + (do ((index 0 (1+ index)) + ;; bit-vectors of length 1 to n-word-bits need precisely + ;; one (SETF %VECTOR-RAW-BITS), done here in the + ;; epilogue. - CSR, 2002-04-24 + (end-1 (truncate (truly-the index (1- length)) + sb!vm:n-word-bits))) + ((>= index end-1) + (setf (%vector-raw-bits result-bit-array index) + (word-logical-not (%vector-raw-bits bit-array index))) result-bit-array) (declare (optimize (speed 3) (safety 0)) (type index index end-1)) - (setf (%raw-bits result-bit-array index) - (word-logical-not (%raw-bits bit-array index)))))))) + (setf (%vector-raw-bits result-bit-array index) + (word-logical-not (%vector-raw-bits bit-array index)))))))) (deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector)) `(and (= (length x) (length y)) (let ((length (length x))) (or (= length 0) - (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) + (do* ((i 0 (+ i 1)) + (end-1 (floor (1- length) sb!vm:n-word-bits))) + ((>= 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))) @@ -331,7 +423,7 @@ (:little-endian 0) (:big-endian '(- sb!vm:n-word-bits extra)))) - (%raw-bits x i))) + (%vector-raw-bits x i))) (numy (logand (ash mask @@ -339,13 +431,13 @@ (:little-endian 0) (:big-endian '(- sb!vm:n-word-bits extra)))) - (%raw-bits y i)))) + (%vector-raw-bits y i)))) (declare (type (integer 1 #.sb!vm:n-word-bits) extra) (type sb!vm:word mask numx numy)) (= numx numy))) (declare (type index i end-1)) - (let ((numx (%raw-bits x i)) - (numy (%raw-bits y i))) + (let ((numx (%vector-raw-bits x i)) + (numy (%vector-raw-bits y i))) (declare (type sb!vm:word numx numy)) (unless (= numx numy) (return nil)))))))) @@ -355,12 +447,11 @@ `(let ((length (length sequence))) (if (zerop length) 0 - (do ((index sb!vm:vector-data-offset (1+ index)) + (do ((index 0 (1+ index)) (count 0) - (end-1 (+ sb!vm:vector-data-offset - (truncate (truly-the index (1- length)) - sb!vm:n-word-bits)))) - ((= index end-1) + (end-1 (truncate (truly-the index (1- length)) + sb!vm:n-word-bits))) + ((>= 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))) @@ -369,27 +460,20 @@ (:little-endian 0) (:big-endian '(- sb!vm:n-word-bits extra)))) - (%raw-bits sequence index)))) + (%vector-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 (%vector-raw-bits sequence index))))))) (deftransform fill ((sequence item) (simple-bit-vector bit) * :policy (>= speed space)) @@ -402,19 +486,18 @@ (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 to n-word-bits 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) + (do ((index 0 (1+ index)) + ;; bit-vectors of length 1 to n-word-bits need precisely + ;; one (SETF %VECTOR-RAW-BITS), done here in the + ;; epilogue. - CSR, 2002-04-24 + (end-1 (truncate (truly-the index (1- length)) + sb!vm:n-word-bits))) + ((>= index end-1) + (setf (%vector-raw-bits sequence index) value) sequence) (declare (optimize (speed 3) (safety 0)) (type index index end-1)) - (setf (%raw-bits sequence index) value)))))) + (setf (%vector-raw-bits sequence index) value)))))) (deftransform fill ((sequence item) (simple-base-string base-char) * :policy (>= speed space)) @@ -431,9 +514,9 @@ (value ,value)) (multiple-value-bind (times rem) (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) + (do ((index 0 (1+ index)) + (end times)) + ((>= index end) (let ((place (* times sb!vm:n-word-bytes))) (declare (fixnum place)) (dotimes (j rem sequence) @@ -441,7 +524,7 @@ (setf (schar sequence (the index (+ place j))) item)))) (declare (optimize (speed 3) (safety 0)) (type index index)) - (setf (%raw-bits sequence index) value)))))) + (setf (%vector-raw-bits sequence index) value)))))) ;;;; %BYTE-BLT @@ -476,57 +559,75 @@ ;; 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))) (values))) ;;;; transforms for EQL of floating point values - +#!-float-eql-vops (deftransform eql ((x y) (single-float single-float)) '(= (single-float-bits x) (single-float-bits y))) +#!-float-eql-vops (deftransform eql ((x y) (double-float double-float)) '(and (= (double-float-low-bits x) (double-float-low-bits y)) (= (double-float-high-bits x) (double-float-high-bits y)))) ;;;; 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)) - #!+#.(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))) - + #.`(progn + #!+(or x86 x86-64) + (def sb!vm::ash-left-modfx + :tagged ,(- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits) t) + (def ,(intern (format nil "ASH-LEFT-MOD~D" sb!vm:n-machine-word-bits) + "SB!VM") + :untagged ,sb!vm:n-machine-word-bits nil))) ;;;; word-wise logical operations @@ -615,3 +716,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)))