X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Fmove.lisp;h=1a5279c1e1387deb2c7e367119d56876ef2c21e4;hb=fb2d70782a537348895f6a04f257d1f1fcc7942d;hp=3a1e22e6f12a3f9f862e93b3d1aa3f632933e491;hpb=4dc4761909992ceb346d003f3fb19e5c837ee985;p=sbcl.git diff --git a/src/compiler/x86-64/move.lisp b/src/compiler/x86-64/move.lisp index 3a1e22e..1a5279c 100644 --- a/src/compiler/x86-64/move.lisp +++ b/src/compiler/x86-64/move.lisp @@ -1,4 +1,4 @@ -;;;; the x86 VM definition of operand loading/saving and the MOVE vop +;;;; the x86-64 VM definition of operand loading/saving and the MOVE vop ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -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,17 +42,20 @@ (etypecase val (integer (if (zerop val) - (inst xor y y) - (inst mov y (fixnumize val)))) + (zeroize y) + (inst mov y (fixnumize val)))) (symbol (load-symbol y val)) (character (inst mov y (logior (ash (char-code val) n-widetag-bits) - character-widetag)))))) + character-widetag)))))) (define-move-fun (load-number 1) (vop x y) ((immediate) (signed-reg unsigned-reg)) - (inst mov y (tn-value x))) + (let ((val (tn-value x))) + (if (zerop val) + (zeroize y) + (inst mov y val)))) (define-move-fun (load-character 1) (vop x y) ((immediate) (character-reg)) @@ -61,30 +88,30 @@ ;;;; the MOVE VOP (define-vop (move) (:args (x :scs (any-reg descriptor-reg immediate) :target y - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:results (y :scs (any-reg descriptor-reg) - :load-if - (not (or (location= x y) - (and (sc-is x any-reg descriptor-reg immediate) - (sc-is y control-stack)))))) + :load-if + (not (or (location= x y) + (and (sc-is x any-reg descriptor-reg immediate) + (sc-is y control-stack)))))) (:temporary (:sc unsigned-reg) temp) (:effects) (:affected) (:generator 0 (if (and (sc-is x immediate) - (sc-is y any-reg descriptor-reg control-stack)) - (let ((val (tn-value x))) - (etypecase val - (integer - (if (and (zerop val) (sc-is y any-reg descriptor-reg)) - (inst xor y y) - (move-immediate y (fixnumize val) temp))) - (symbol - (inst mov y (+ nil-value (static-symbol-offset val)))) - (character - (inst mov y (logior (ash (char-code val) n-widetag-bits) - character-widetag))))) - (move y x)))) + (sc-is y any-reg descriptor-reg control-stack)) + (let ((val (tn-value x))) + (etypecase val + (integer + (if (and (zerop val) (sc-is y any-reg descriptor-reg)) + (zeroize y) + (move-immediate y (fixnumize val) temp))) + (symbol + (inst mov y (+ nil-value (static-symbol-offset val)))) + (character + (inst mov y (logior (ash (char-code val) n-widetag-bits) + character-widetag))))) + (move y x)))) (define-move-vop move :move (any-reg descriptor-reg immediate) @@ -99,7 +126,7 @@ (cond ;; If target is a register, we can just mov it there directly ((and (tn-p target) - (sc-is target signed-reg unsigned-reg descriptor-reg any-reg)) + (sc-is target signed-reg unsigned-reg descriptor-reg any-reg)) (inst mov target val)) ;; Likewise if the value is small enough. ((typep val '(signed-byte 31)) @@ -119,60 +146,60 @@ ;;; this case the loading works out. (define-vop (move-arg) (:args (x :scs (any-reg descriptor-reg immediate) :target y - :load-if (not (and (sc-is y any-reg descriptor-reg) - (sc-is x control-stack)))) - (fp :scs (any-reg) - :load-if (not (sc-is y any-reg descriptor-reg)))) + :load-if (not (and (sc-is y any-reg descriptor-reg) + (sc-is x control-stack)))) + (fp :scs (any-reg) + :load-if (not (sc-is y any-reg descriptor-reg)))) (:results (y)) (:generator 0 (sc-case y ((any-reg descriptor-reg) (if (sc-is x immediate) - (let ((val (tn-value x))) - (etypecase val - ((integer 0 0) - (inst xor y y)) - ((or (signed-byte 29) (unsigned-byte 29)) - (inst mov y (fixnumize val))) - (integer - (move-immediate y (fixnumize val))) - (symbol - (load-symbol y val)) - (character - (inst mov y (logior (ash (char-code val) n-widetag-bits) - character-widetag))))) - (move y x))) + (let ((val (tn-value x))) + (etypecase val + ((integer 0 0) + (zeroize y)) + ((or (signed-byte 29) (unsigned-byte 29)) + (inst mov y (fixnumize val))) + (integer + (move-immediate y (fixnumize val))) + (symbol + (load-symbol y val)) + (character + (inst mov y (logior (ash (char-code val) n-widetag-bits) + character-widetag))))) + (move y x))) ((control-stack) (if (sc-is x immediate) - (let ((val (tn-value x))) - (if (= (tn-offset fp) esp-offset) - ;; C-call - (etypecase val - (integer - (storew (fixnumize val) fp (tn-offset y))) - (symbol - (storew (+ nil-value (static-symbol-offset val)) - fp (tn-offset y))) - (character - (storew (logior (ash (char-code val) n-widetag-bits) - character-widetag) - fp (tn-offset y)))) - ;; Lisp stack - (etypecase val - (integer - (storew (fixnumize val) fp (- (1+ (tn-offset y))))) - (symbol - (storew (+ nil-value (static-symbol-offset val)) - fp (- (1+ (tn-offset y))))) - (character - (storew (logior (ash (char-code val) n-widetag-bits) - character-widetag) - fp (- (1+ (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)))))))))) + (let ((val (tn-value x))) + (if (= (tn-offset fp) esp-offset) + ;; C-call + (etypecase val + (integer + (storew (fixnumize val) fp (tn-offset y))) + (symbol + (storew (+ nil-value (static-symbol-offset val)) + fp (tn-offset y))) + (character + (storew (logior (ash (char-code val) n-widetag-bits) + character-widetag) + fp (tn-offset y)))) + ;; Lisp stack + (etypecase val + (integer + (storew (fixnumize val) fp (- (1+ (tn-offset y))))) + (symbol + (storew (+ nil-value (static-symbol-offset val)) + fp (- (1+ (tn-offset y))))) + (character + (storew (logior (ash (char-code val) n-widetag-bits) + character-widetag) + fp (- (1+ (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)))))))))) (define-move-vop move-arg :move-arg (any-reg descriptor-reg) @@ -204,9 +231,9 @@ ;;; possible bignum arg SCs. (define-vop (move-to-word/fixnum) (:args (x :scs (any-reg descriptor-reg) :target y - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:results (y :scs (signed-reg unsigned-reg) - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:arg-types tagged-num) (:note "fixnum untagging") (:generator 1 @@ -232,11 +259,11 @@ (:results (y :scs (signed-reg unsigned-reg))) (:note "integer to untagged word coercion") (:temporary (:sc unsigned-reg :offset eax-offset - :from (:argument 0) :to (:result 0) :target y) eax) + :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 7) ; a symbolic constant for this + (inst jmp :z FIXNUM) ; would be nice (loadw y eax bignum-digits-offset other-pointer-lowtag) (inst jmp DONE) FIXNUM @@ -251,20 +278,20 @@ ;;; restriction because of the control-stack ambiguity noted above. (define-vop (move-from-word/fixnum) (:args (x :scs (signed-reg unsigned-reg) :target y - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:results (y :scs (any-reg descriptor-reg) - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:result-types tagged-num) (:note "fixnum tagging") (: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))) - (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)))))) + (not (location= x y))) + ;; Uses 7 bytes, but faster on the Pentium + (inst lea y (make-ea :qword :index x :scale 8))) + (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)))))) (define-move-vop move-from-word/fixnum :move (signed-reg unsigned-reg) (any-reg descriptor-reg)) @@ -278,22 +305,25 @@ (:generator 20 (aver (not (location= x y))) (let ((bignum (gen-label)) - (done (gen-label))) - (inst mov y x) - (inst shl y 1) - (inst jmp :o bignum) - (inst shl y 1) - (inst jmp :o bignum) - (inst shl y 1) + (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))))) + (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))))) (define-move-vop move-from-signed :move (signed-reg) (descriptor-reg)) @@ -312,50 +342,50 @@ (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 + (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))))) + (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))))) (define-move-vop move-from-unsigned :move (unsigned-reg) (descriptor-reg)) ;;; Move untagged numbers. (define-vop (word-move) (:args (x :scs (signed-reg unsigned-reg) :target y - :load-if (not (location= x y)))) + :load-if (not (location= x y)))) (:results (y :scs (signed-reg unsigned-reg) - :load-if - (not (or (location= x y) - (and (sc-is x signed-reg unsigned-reg) - (sc-is y signed-stack unsigned-stack)))))) + :load-if + (not (or (location= x y) + (and (sc-is x signed-reg unsigned-reg) + (sc-is y signed-stack unsigned-stack)))))) (:effects) (:affected) (:note "word integer move") @@ -367,7 +397,7 @@ ;;; Move untagged number arguments/return-values. (define-vop (move-word-arg) (:args (x :scs (signed-reg unsigned-reg) :target y) - (fp :scs (any-reg) :load-if (not (sc-is y sap-reg)))) + (fp :scs (any-reg) :load-if (not (sc-is y sap-reg)))) (:results (y)) (:note "word integer argument move") (:generator 0 @@ -376,8 +406,8 @@ (move y x)) ((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 (tn-offset y)) ; c-call + (storew x fp (- (1+ (tn-offset y))))))))) (define-move-vop move-word-arg :move-arg (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg))