X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Fmove.lisp;h=ad715a10d85304584d140892c4aeb5ac6e1ecd60;hb=bc46c8bcdd6ac8918df8ea9e9db49808e4924fcf;hp=5c6cab457590324895e0e0f534198509a2edc95b;hpb=a530bbe337109d898d5b4a001fc8f1afa3b5dc39;p=sbcl.git diff --git a/src/compiler/x86/move.lisp b/src/compiler/x86/move.lisp index 5c6cab4..ad715a1 100644 --- a/src/compiler/x86/move.lisp +++ b/src/compiler/x86/move.lisp @@ -11,10 +11,7 @@ (in-package "SB!VM") -(file-comment - "$Header$") - -(define-move-function (load-immediate 1) (vop x y) +(define-move-fun (load-immediate 1) (vop x y) ((immediate) (any-reg descriptor-reg)) (let ((val (tn-value x))) @@ -26,26 +23,26 @@ (symbol (load-symbol y val)) (character - (inst mov y (logior (ash (char-code val) type-bits) - base-char-type)))))) + (inst mov y (logior (ash (char-code val) n-widetag-bits) + base-char-widetag)))))) -(define-move-function (load-number 1) (vop x y) +(define-move-fun (load-number 1) (vop x y) ((immediate) (signed-reg unsigned-reg)) (inst mov y (tn-value x))) -(define-move-function (load-base-char 1) (vop x y) +(define-move-fun (load-base-char 1) (vop x y) ((immediate) (base-char-reg)) (inst mov y (char-code (tn-value x)))) -(define-move-function (load-system-area-pointer 1) (vop x y) +(define-move-fun (load-system-area-pointer 1) (vop x y) ((immediate) (sap-reg)) (inst mov y (sap-int (tn-value x)))) -(define-move-function (load-constant 5) (vop x y) +(define-move-fun (load-constant 5) (vop x y) ((constant) (descriptor-reg any-reg)) (inst mov y x)) -(define-move-function (load-stack 5) (vop x y) +(define-move-fun (load-stack 5) (vop x y) ((control-stack) (any-reg descriptor-reg) (base-char-stack) (base-char-reg) (sap-stack) (sap-reg) @@ -53,7 +50,7 @@ (unsigned-stack) (unsigned-reg)) (inst mov y x)) -(define-move-function (store-stack 5) (vop x y) +(define-move-fun (store-stack 5) (vop x y) ((any-reg descriptor-reg) (control-stack) (base-char-reg) (base-char-stack) (sap-reg) (sap-stack) @@ -82,28 +79,28 @@ (inst xor y y) (inst mov y (fixnumize val)))) (symbol - (inst mov y (+ *nil-value* (static-symbol-offset val)))) + (inst mov y (+ nil-value (static-symbol-offset val)))) (character - (inst mov y (logior (ash (char-code val) type-bits) - base-char-type))))) + (inst mov y (logior (ash (char-code val) n-widetag-bits) + base-char-widetag))))) (move y x)))) (define-move-vop move :move (any-reg descriptor-reg immediate) (any-reg descriptor-reg)) -;;; Make Move the check VOP for T so that type check generation +;;; Make MOVE the check VOP for T so that type check generation ;;; doesn't think it is a hairy type. This also allows checking of a ;;; few of the values in a continuation to fall out. (primitive-type-vop move (:check) t) -;;; The Move-Argument VOP is used for moving descriptor values into +;;; The MOVE-ARG VOP is used for moving descriptor values into ;;; another frame for argument or known value passing. ;;; ;;; Note: It is not going to be possible to move a constant directly ;;; to another frame, except if the destination is a register and in ;;; this case the loading works out. -(define-vop (move-argument) +(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)))) @@ -123,8 +120,8 @@ (symbol (load-symbol y val)) (character - (inst mov y (logior (ash (char-code val) type-bits) - base-char-type))))) + (inst mov y (logior (ash (char-code val) n-widetag-bits) + base-char-widetag))))) (move y x))) ((control-stack) (if (sc-is x immediate) @@ -135,22 +132,22 @@ (integer (storew (fixnumize val) fp (tn-offset y))) (symbol - (storew (+ *nil-value* (static-symbol-offset val)) + (storew (+ nil-value (static-symbol-offset val)) fp (tn-offset y))) (character - (storew (logior (ash (char-code val) type-bits) - base-char-type) + (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)) + (storew (+ nil-value (static-symbol-offset val)) fp (- (1+ (tn-offset y))))) (character - (storew (logior (ash (char-code val) type-bits) - base-char-type) + (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 @@ -158,7 +155,7 @@ ;; Lisp stack (storew x fp (- (1+ (tn-offset y)))))))))) -(define-move-vop move-argument :move-argument +(define-move-vop move-arg :move-arg (any-reg descriptor-reg) (any-reg descriptor-reg)) @@ -221,7 +218,7 @@ (move eax x) (inst test al-tn 3) (inst jmp :z fixnum) - (loadw y eax bignum-digits-offset other-pointer-type) + (loadw y eax bignum-digits-offset other-pointer-lowtag) (inst jmp done) FIXNUM (inst sar eax 2) @@ -283,7 +280,7 @@ (:note "signed word to integer coercion") (:node-var node) (:generator 20 - (assert (not (location= x y))) + (aver (not (location= x y))) (let ((bignum (gen-label)) (done (gen-label))) (inst mov y x) @@ -293,8 +290,9 @@ (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? + ;; 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 @@ -308,8 +306,8 @@ (assemble (*elsewhere*) (emit-label bignum) (with-fixed-allocation - (y bignum-type (+ bignum-digits-offset 1) node) - (storew x y bignum-digits-offset other-pointer-type)) + (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)) @@ -344,9 +342,9 @@ (:node-var node) (:note "unsigned word to integer coercion") (:generator 20 - (assert (not (location= x y))) - (assert (not (location= x alloc))) - (assert (not (location= y alloc))) + (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)) @@ -365,21 +363,21 @@ ;; 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. + ;; two word bignum (inst mov y (logior (ash (1- (+ bignum-digits-offset 2)) - sb!vm:type-bits) - bignum-type)) + n-widetag-bits) + bignum-widetag)) (inst jmp L1) (emit-label one-word-bignum) (inst mov y (logior (ash (1- (+ bignum-digits-offset 1)) - sb!vm:type-bits) - bignum-type)) + 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-type)) - (storew x y bignum-digits-offset other-pointer-type)) + (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)) @@ -402,7 +400,7 @@ (signed-reg unsigned-reg) (signed-reg unsigned-reg)) ;;; Move untagged number arguments/return-values. -(define-vop (move-word-argument) +(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)))) (:results (y)) @@ -415,10 +413,10 @@ (if (= (tn-offset fp) esp-offset) (storew x fp (tn-offset y)) ; c-call (storew x fp (- (1+ (tn-offset y))))))))) -(define-move-vop move-word-argument :move-argument +(define-move-vop move-word-arg :move-arg (descriptor-reg any-reg signed-reg unsigned-reg) (signed-reg unsigned-reg)) -;;; Use standard MOVE-ARGUMENT and coercion to move an untagged number +;;; Use standard MOVE-ARG and coercion to move an untagged number ;;; to a descriptor passing location. -(define-move-vop move-argument :move-argument +(define-move-vop move-arg :move-arg (signed-reg unsigned-reg) (any-reg descriptor-reg))