X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fmove.lisp;h=2c198a995774890560a556bec5442b7948cbb367;hb=a6b91f356da1b5ae2987f79db9bd137970512959;hp=ad715a10d85304584d140892c4aeb5ac6e1ecd60;hpb=0bca0cb1bf5ce5572ab5cd7ba59f87fed1f2edb0;p=sbcl.git diff --git a/src/compiler/x86/move.lisp b/src/compiler/x86/move.lisp index ad715a1..2c198a9 100644 --- a/src/compiler/x86/move.lisp +++ b/src/compiler/x86/move.lisp @@ -14,24 +14,20 @@ (define-move-fun (load-immediate 1) (vop x y) ((immediate) (any-reg descriptor-reg)) - (let ((val (tn-value x))) - (etypecase val - (integer - (if (zerop val) - (inst xor y y) - (inst mov y (fixnumize val)))) - (symbol - (load-symbol y val)) - (character - (inst mov y (logior (ash (char-code val) n-widetag-bits) - base-char-widetag)))))) + (let ((val (encode-value-if-immediate x))) + (if (zerop val) + (inst xor y y) + (inst mov y val)))) (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) + (inst xor y y) + (inst mov y val)))) -(define-move-fun (load-base-char 1) (vop x y) - ((immediate) (base-char-reg)) +(define-move-fun (load-character 1) (vop x y) + ((immediate) (character-reg)) (inst mov y (char-code (tn-value x)))) (define-move-fun (load-system-area-pointer 1) (vop x y) @@ -44,7 +40,7 @@ (define-move-fun (load-stack 5) (vop x y) ((control-stack) (any-reg descriptor-reg) - (base-char-stack) (base-char-reg) + (character-stack) (character-reg) (sap-stack) (sap-reg) (signed-stack) (signed-reg) (unsigned-stack) (unsigned-reg)) @@ -52,7 +48,7 @@ (define-move-fun (store-stack 5) (vop x y) ((any-reg descriptor-reg) (control-stack) - (base-char-reg) (base-char-stack) + (character-reg) (character-stack) (sap-reg) (sap-stack) (signed-reg) (signed-stack) (unsigned-reg) (unsigned-stack)) @@ -61,28 +57,21 @@ ;;;; 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)))))) (: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) - (inst mov y (fixnumize val)))) - (symbol - (inst mov y (+ nil-value (static-symbol-offset val)))) - (character - (inst mov y (logior (ash (char-code val) n-widetag-bits) - base-char-widetag))))) + (sc-is y any-reg descriptor-reg control-stack)) + (let ((val (encode-value-if-immediate x))) + (if (and (zerop val) (sc-is y any-reg descriptor-reg)) + (inst xor y y) + (inst mov y val))) (move y x)))) (define-move-vop move :move @@ -102,58 +91,27 @@ ;;; 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 - (if (zerop val) - (inst xor y y) - (inst mov y (fixnumize val)))) - (symbol - (load-symbol y val)) - (character - (inst mov y (logior (ash (char-code val) n-widetag-bits) - base-char-widetag))))) - (move y x))) + (let ((val (encode-value-if-immediate x))) + (if (zerop val) + (inst xor y y) + (inst mov y val))) + (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) - base-char-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) - base-char-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 ((frame-offset (if (= (tn-offset fp) esp-offset) + ;; C-call + (tn-offset y) + ;; Lisp stack + (frame-word-offset (tn-offset y))))) + (storew (encode-value-if-immediate x) fp frame-offset)))))) (define-move-vop move-arg :move-arg (any-reg descriptor-reg) @@ -172,7 +130,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 @@ -185,9 +143,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 @@ -213,7 +171,7 @@ (: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 3) @@ -232,165 +190,90 @@ ;;; 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 :dword :index x :scale 4))) - (t - ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes - (move y x) - (inst shl y 2))))) + (not (location= x y))) + ;; Uses 7 bytes, but faster on the Pentium + (inst lea y (make-ea :dword :index x :scale 4))) + (t + ;; Uses: If x is a reg 2 + 3; if x = y uses only 3 bytes + (move y x) + (inst shl y 2))))) (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. -;;; -;;; KLUDGE: I assume this is suppressed in favor of the "faster inline -;;; version" below. (See also mysterious comment "we don't want a VOP -;;; on this one" on DEFINE-ASSEMBLY-ROUTINE (MOVE-FROM-SIGNED) in -;;; "src/assembly/x86/alloc.lisp".) -- WHN 19990916 -#+nil -(define-vop (move-from-signed) - (:args (x :scs (signed-reg unsigned-reg) :target eax)) - (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax) - (:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y) - ebx) - (:temporary (:sc unsigned-reg :offset ecx-offset - :from (:argument 0) :to (:result 0)) ecx) - (:ignore ecx) - (:results (y :scs (any-reg descriptor-reg))) - (:note "signed word to integer coercion") - (:generator 20 - (move eax x) - (inst call (make-fixup 'move-from-signed :assembly-routine)) - (move y ebx))) -;;; Faster inline version, -;;; KLUDGE: Do we really want the faster inline version? It's sorta big. -;;; It is nice that it doesn't use any temporaries, though. -- WHN 19990916 +;;; 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))) + (let ((done (gen-label))) + (inst imul y x (ash 1 n-fixnum-tag-bits)) + (inst jmp :no done) (inst mov y x) - (inst shl y 1) - (inst jmp :o bignum) - (inst shl y 1) - (inst jmp :o bignum) - (emit-label done) - ;; KLUDGE: The sequence above leaves a DESCRIPTOR-REG Y in a - ;; non-descriptor state for a while. Does that matter? Does it - ;; matter in GENGC but not in GENCGC? Is this written down - ;; anywhere? - ;; -- WHN 19990916 - ;; - ;; Also, the sequence above seems rather twisty. Why not something - ;; more obvious along the lines of - ;; inst move y x - ;; inst tst x #xc0000000 - ;; inst jmp :nz bignum - ;; inst shl y 2 - ;; 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))))) + (inst call (make-fixup (ecase (tn-offset y) + (#.eax-offset 'alloc-signed-bignum-in-eax) + (#.ebx-offset 'alloc-signed-bignum-in-ebx) + (#.ecx-offset 'alloc-signed-bignum-in-ecx) + (#.edx-offset 'alloc-signed-bignum-in-edx) + (#.esi-offset 'alloc-signed-bignum-in-esi) + (#.edi-offset 'alloc-signed-bignum-in-edi)) + :assembly-routine)) + (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. -#+nil -(define-vop (move-from-unsigned) - (:args (x :scs (signed-reg unsigned-reg) :target eax)) - (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 0)) eax) - (:temporary (:sc unsigned-reg :offset ebx-offset :to (:result 0) :target y) - ebx) - (:temporary (:sc unsigned-reg :offset ecx-offset - :from (:argument 0) :to (:result 0)) ecx) - (:ignore ecx) - (:results (y :scs (any-reg descriptor-reg))) - (:note "unsigned word to integer coercion") - (:generator 20 - (move eax x) - (inst call (make-fixup 'move-from-unsigned :assembly-routine)) - (move y ebx))) -;;; Faster inline version. -;;; KLUDGE: Do we really want the faster inline version? It seems awfully big.. -;;; If we really want speed, most likely it's only important in the non-consing -;;; case, so how about about making the *ELSEWHERE* stuff into a subroutine? -- -;;; WHN 19990916 +;;; 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 test x #xe0000000) - (inst jmp :nz bignum) - ;; Fixnum. - (inst lea y (make-ea :dword :index x :scale 4)) ; Faster but bigger. - ;(inst mov y x) - ;(inst shl y 2) - (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 jmp :ns 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))) + ;; 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 #.(ash lowtag-mask (- n-word-bits n-fixnum-tag-bits 1))) + ;; Faster but bigger then SHL Y 2. The cost of doing this speculatively + ;; is noise compared to bignum consing if that is needed. + (inst lea y (make-ea :dword :index x :scale 4)) + (inst jmp :z done) + (inst mov y x) + (inst call (make-fixup (ecase (tn-offset y) + (#.eax-offset 'alloc-unsigned-bignum-in-eax) + (#.ebx-offset 'alloc-unsigned-bignum-in-ebx) + (#.ecx-offset 'alloc-unsigned-bignum-in-ecx) + (#.edx-offset 'alloc-unsigned-bignum-in-edx) + (#.edi-offset 'alloc-unsigned-bignum-in-edi) + (#.esi-offset 'alloc-unsigned-bignum-in-esi)) + :assembly-routine)) + (emit-label 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") @@ -402,7 +285,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 @@ -411,8 +294,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 (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))