X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fmove.lisp;h=7872710c01304c7b84894f239e789c25c9a79816;hb=18775b5e3c9a75f5301e09ddef649f2f35ab9752;hp=4caf11f995520e210952ca20d8714a204a8c3321;hpb=06928f553de251ab19f163a23d39b78c80a8ed2f;p=sbcl.git diff --git a/src/compiler/x86-64/move.lisp b/src/compiler/x86-64/move.lisp index 4caf11f..7872710 100644 --- a/src/compiler/x86-64/move.lisp +++ b/src/compiler/x86-64/move.lisp @@ -11,6 +11,30 @@ (in-package "SB!VM") +(defun make-byte-tn (tn) + (aver (sc-is tn any-reg descriptor-reg unsigned-reg signed-reg)) + (make-random-tn :kind :normal + :sc (sc-or-lose 'byte-reg) + :offset (tn-offset tn))) + +(defun make-dword-tn (tn) + (aver (sc-is tn any-reg descriptor-reg character-reg + unsigned-reg signed-reg)) + (make-random-tn :kind :normal + :sc (sc-or-lose 'dword-reg) + :offset (tn-offset tn))) + +(defun zeroize (tn) + (let ((offset (tn-offset tn))) + ;; Using the 32-bit instruction accomplishes the same thing and is + ;; one byte shorter. + (if (<= offset edi-offset) + (let ((tn (make-random-tn :kind :normal + :sc (sc-or-lose 'dword-reg) + :offset offset))) + (inst xor tn tn)) + (inst xor tn tn)))) + (define-move-fun (load-immediate 1) (vop x y) ((immediate) (any-reg descriptor-reg)) @@ -18,7 +42,7 @@ (etypecase val (integer (if (zerop val) - (inst xor y y) + (zeroize y) (inst mov y (fixnumize val)))) (symbol (load-symbol y val)) @@ -30,7 +54,7 @@ ((immediate) (signed-reg unsigned-reg)) (let ((val (tn-value x))) (if (zerop val) - (inst xor y y) + (zeroize y) (inst mov y val)))) (define-move-fun (load-character 1) (vop x y) @@ -80,7 +104,7 @@ (etypecase val (integer (if (and (zerop val) (sc-is y any-reg descriptor-reg)) - (inst xor y y) + (zeroize y) (move-immediate y (fixnumize val) temp))) (symbol (inst mov y (+ nil-value (static-symbol-offset val)))) @@ -134,7 +158,7 @@ (let ((val (tn-value x))) (etypecase val ((integer 0 0) - (inst xor y y)) + (zeroize y)) ((or (signed-byte 29) (unsigned-byte 29)) (inst mov y (fixnumize val))) (integer @@ -163,19 +187,19 @@ ;; Lisp stack (etypecase val (integer - (storew (fixnumize val) fp (- (1+ (tn-offset y))))) + (storew (fixnumize val) fp (frame-word-offset (tn-offset y)))) (symbol (storew (+ nil-value (static-symbol-offset val)) - fp (- (1+ (tn-offset y))))) + fp (frame-word-offset (tn-offset y)))) (character (storew (logior (ash (char-code val) n-widetag-bits) character-widetag) - fp (- (1+ (tn-offset y)))))))) + fp (frame-word-offset (tn-offset y))))))) (if (= (tn-offset fp) esp-offset) ;; C-call (storew x fp (tn-offset y)) ;; Lisp stack - (storew x fp (- (1+ (tn-offset y)))))))))) + (storew x fp (frame-word-offset (tn-offset y))))))))) (define-move-vop move-arg :move-arg (any-reg descriptor-reg) @@ -194,7 +218,7 @@ (:vop-var vop) (:save-p :compute-only) (:generator 666 - (error-call vop object-not-type-error x type))) + (error-call vop 'object-not-type-error x type))) ;;;; moves and coercions @@ -214,7 +238,7 @@ (:note "fixnum untagging") (:generator 1 (move y x) - (inst sar y (1- n-lowtag-bits)))) + (inst sar y n-fixnum-tag-bits))) (define-move-vop move-to-word/fixnum :move (any-reg descriptor-reg) (signed-reg unsigned-reg)) @@ -224,7 +248,11 @@ (:results (y :scs (signed-reg unsigned-reg))) (:note "constant load") (:generator 1 - (inst mov y (tn-value x)))) + (cond ((sb!c::tn-leaf x) + (inst mov y (tn-value x))) + (t + (inst mov y x) + (inst sar y n-fixnum-tag-bits))))) (define-move-vop move-to-word-c :move (constant) (signed-reg unsigned-reg)) @@ -238,12 +266,12 @@ :from (:argument 0) :to (:result 0) :target y) eax) (:generator 4 (move eax x) - (inst test al-tn 7) ; a symbolic constant for this - (inst jmp :z FIXNUM) ; would be nice + (inst test al-tn fixnum-tag-mask) + (inst jmp :z FIXNUM) (loadw y eax bignum-digits-offset other-pointer-lowtag) (inst jmp DONE) FIXNUM - (inst sar eax (1- n-lowtag-bits)) + (inst sar eax n-fixnum-tag-bits) (move y eax) DONE)) (define-move-vop move-to-word/integer :move @@ -262,94 +290,99 @@ (:generator 1 (cond ((and (sc-is x signed-reg unsigned-reg) (not (location= x y))) - ;; Uses 7 bytes, but faster on the Pentium - (inst lea y (make-ea :qword :index x :scale 8))) + (if (= n-fixnum-tag-bits 1) + (inst lea y (make-ea :qword :base x :index x)) + (inst lea y (make-ea :qword :index x + :scale (ash 1 n-fixnum-tag-bits))))) (t ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes (move y x) - (inst shl y (1- n-lowtag-bits)))))) + (inst shl y n-fixnum-tag-bits))))) (define-move-vop move-from-word/fixnum :move (signed-reg unsigned-reg) (any-reg descriptor-reg)) -;;; Result may be a bignum, so we have to check. Use a worst-case cost -;;; to make sure people know they may be number consing. +;;; Convert an untagged signed word to a lispobj -- fixnum or bignum +;;; as the case may be. Fixnum case inline, bignum case in an assembly +;;; routine. (define-vop (move-from-signed) (:args (x :scs (signed-reg unsigned-reg) :to :result)) (:results (y :scs (any-reg descriptor-reg) :from :argument)) (:note "signed word to integer coercion") - (:node-var node) + ;; Worst case cost to make sure people know they may be number consing. (:generator 20 (aver (not (location= x y))) - (let ((bignum (gen-label)) - (done (gen-label))) - ;; We can't do the overflow check with SHL Y, 3, since the - ;; state of the overflow flag is only reliably set when - ;; shifting by 1. There used to be code here for doing "shift - ;; by one, check whether it overflowed" three times. But on all - ;; x86-64 processors IMUL is a reasonably fast instruction, so - ;; we can just do a straight multiply instead of trying to - ;; optimize it to a shift. This is both faster and smaller. - ;; -- JES, 2006-07-08 - (inst imul y x (ash 1 n-fixnum-tag-bits)) - (inst jmp :o bignum) - (emit-label done) - - (assemble (*elsewhere*) - (emit-label bignum) - (with-fixed-allocation - (y bignum-widetag (+ bignum-digits-offset 1) node) - (storew x y bignum-digits-offset other-pointer-lowtag)) - (inst jmp done))))) + (let ((done (gen-label))) + (inst imul y x #.(ash 1 n-fixnum-tag-bits)) + (inst jmp :no done) + (inst mov y x) + (inst lea temp-reg-tn + (make-ea :qword :disp + (make-fixup (ecase (tn-offset y) + (#.rax-offset 'alloc-signed-bignum-in-rax) + (#.rcx-offset 'alloc-signed-bignum-in-rcx) + (#.rdx-offset 'alloc-signed-bignum-in-rdx) + (#.rbx-offset 'alloc-signed-bignum-in-rbx) + (#.rsi-offset 'alloc-signed-bignum-in-rsi) + (#.rdi-offset 'alloc-signed-bignum-in-rdi) + (#.r8-offset 'alloc-signed-bignum-in-r8) + (#.r9-offset 'alloc-signed-bignum-in-r9) + (#.r10-offset 'alloc-signed-bignum-in-r10) + (#.r12-offset 'alloc-signed-bignum-in-r12) + (#.r13-offset 'alloc-signed-bignum-in-r13) + (#.r14-offset 'alloc-signed-bignum-in-r14) + (#.r15-offset 'alloc-signed-bignum-in-r15)) + :assembly-routine))) + (inst call temp-reg-tn) + (emit-label done)))) (define-move-vop move-from-signed :move (signed-reg) (descriptor-reg)) -;;; Check for fixnum, and possibly allocate one or two word bignum -;;; result. Use a worst-case cost to make sure people know they may be -;;; number consing. - +;;; Convert an untagged unsigned word to a lispobj -- fixnum or bignum +;;; as the case may be. Fixnum case inline, bignum case in an assembly +;;; routine. (define-vop (move-from-unsigned) - (:args (x :scs (signed-reg unsigned-reg) :to :save)) - (:temporary (:sc unsigned-reg) alloc) - (:results (y :scs (any-reg descriptor-reg))) - (:node-var node) + (:args (x :scs (signed-reg unsigned-reg) :to :result)) + (:results (y :scs (any-reg descriptor-reg) :from :argument)) (:note "unsigned word to integer coercion") + ;; Worst case cost to make sure people know they may be number consing. (:generator 20 (aver (not (location= x y))) - (aver (not (location= x alloc))) - (aver (not (location= y alloc))) - (let ((bignum (gen-label)) - (done (gen-label)) - (one-word-bignum (gen-label)) - (L1 (gen-label))) - (inst bsr y x) ;find msb - (inst cmov :z y x) - (inst cmp y 60) - (inst jmp :ae bignum) - (inst lea y (make-ea :qword :index x :scale 8)) - (emit-label done) - (assemble (*elsewhere*) - (emit-label bignum) - ;; Note: As on the mips port, space for a two word bignum is - ;; always allocated and the header size is set to either one - ;; or two words as appropriate. - (inst cmp y 63) - (inst jmp :l one-word-bignum) - ;; two word bignum - (inst mov y (logior (ash (1- (+ bignum-digits-offset 2)) - n-widetag-bits) - bignum-widetag)) - (inst jmp L1) - (emit-label one-word-bignum) - (inst mov y (logior (ash (1- (+ bignum-digits-offset 1)) - n-widetag-bits) - bignum-widetag)) - (emit-label L1) - (pseudo-atomic - (allocation alloc (pad-data-block (+ bignum-digits-offset 2)) node) - (storew y alloc) - (inst lea y (make-ea :byte :base alloc :disp other-pointer-lowtag)) - (storew x y bignum-digits-offset other-pointer-lowtag)) - (inst jmp done))))) + (let ((done (gen-label))) + (inst mov y #.(ash (1- (ash 1 (1+ n-fixnum-tag-bits))) + n-positive-fixnum-bits)) + ;; The assembly routines test the sign flag from this one, so if + ;; you change stuff here, make sure the sign flag doesn't get + ;; overwritten before the CALL! + (inst test x y) + ;; Using LEA is faster but bigger than MOV+SHL; it also doesn't + ;; twiddle the sign flag. The cost of doing this speculatively + ;; should be noise compared to bignum consing if that is needed + ;; and saves one branch. + (if (= n-fixnum-tag-bits 1) + (inst lea y (make-ea :qword :base x :index x)) + (inst lea y (make-ea :qword :index x + :scale (ash 1 n-fixnum-tag-bits)))) + (inst jmp :z done) + (inst mov y x) + (inst lea temp-reg-tn + (make-ea :qword :disp + (make-fixup (ecase (tn-offset y) + (#.rax-offset 'alloc-unsigned-bignum-in-rax) + (#.rcx-offset 'alloc-unsigned-bignum-in-rcx) + (#.rdx-offset 'alloc-unsigned-bignum-in-rdx) + (#.rbx-offset 'alloc-unsigned-bignum-in-rbx) + (#.rsi-offset 'alloc-unsigned-bignum-in-rsi) + (#.rdi-offset 'alloc-unsigned-bignum-in-rdi) + (#.r8-offset 'alloc-unsigned-bignum-in-r8) + (#.r9-offset 'alloc-unsigned-bignum-in-r9) + (#.r10-offset 'alloc-unsigned-bignum-in-r10) + (#.r12-offset 'alloc-unsigned-bignum-in-r12) + (#.r13-offset 'alloc-unsigned-bignum-in-r13) + (#.r14-offset 'alloc-unsigned-bignum-in-r14) + (#.r15-offset 'alloc-unsigned-bignum-in-r15)) + :assembly-routine))) + (inst call temp-reg-tn) + (emit-label done)))) (define-move-vop move-from-unsigned :move (unsigned-reg) (descriptor-reg)) @@ -383,7 +416,7 @@ ((signed-stack unsigned-stack) (if (= (tn-offset fp) esp-offset) (storew x fp (tn-offset y)) ; c-call - (storew x fp (- (1+ (tn-offset y))))))))) + (storew x fp (frame-word-offset (tn-offset y)))))))) (define-move-vop move-word-arg :move-arg (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))