X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Ffloat.lisp;h=ec3fad0e56d7638a3e3abcf7cd632c6b6d93e3ea;hb=97dd06859cae90c8ef9021dafe1beebb78b1547f;hp=b0d1b771c6b9262a187e95336ac3da7261474623;hpb=c4b30c86e3dd1d1cc70c572a6cfffe8b84e9c34a;p=sbcl.git diff --git a/src/compiler/x86-64/float.lisp b/src/compiler/x86-64/float.lisp index b0d1b77..ec3fad0 100644 --- a/src/compiler/x86-64/float.lisp +++ b/src/compiler/x86-64/float.lisp @@ -51,9 +51,7 @@ (+ (tn-offset ,tn) (cond ((= (tn-offset ,base) rsp-offset) sp->fp-offset) - ((= (tn-offset ,base) rbp-offset) - 0) - (t (error "Unexpected offset."))) + (t 0)) (ecase ,kind (:single (ecase ,slot @@ -191,17 +189,39 @@ (double-reg) (descriptor-reg)) ;;; Move from a descriptor to a float register. -(define-vop (move-to-single) +(define-vop (move-to-single-reg) + (:args (x :scs (descriptor-reg) :target tmp + :load-if (not (sc-is x control-stack)))) + (:temporary (:sc unsigned-reg :from :argument :to :result) tmp) + (:results (y :scs (single-reg))) + (:note "pointer to float coercion") + (:generator 2 + (sc-case x + (descriptor-reg + (move tmp x) + (inst shr tmp 32) + (inst movd y tmp)) + (control-stack + ;; When the single-float descriptor is in memory, the untagging + ;; is done in the target XMM register. This is faster than going + ;; through a general-purpose register and the code is smaller. + (inst movq y x) + (inst shufps y y #4r3331))))) +(define-move-vop move-to-single-reg :move (descriptor-reg) (single-reg)) + +;;; Move from a descriptor to a float stack. +(define-vop (move-to-single-stack) (:args (x :scs (descriptor-reg) :target tmp)) - (:temporary (:sc unsigned-reg) tmp) - (:results (y :scs (single-reg))) + (:temporary (:sc unsigned-reg :from :argument :to :result) tmp) + (:results (y :scs (single-stack))) (:note "pointer to float coercion") (:generator 2 (move tmp x) (inst shr tmp 32) - (inst movd y tmp))) - -(define-move-vop move-to-single :move (descriptor-reg) (single-reg)) + (let ((slot (make-ea :dword :base rbp-tn + :disp (frame-byte-offset (tn-offset y))))) + (inst mov slot (reg-in-size tmp :dword))))) +(define-move-vop move-to-single-stack :move (descriptor-reg) (single-stack)) (define-vop (move-to-double) (:args (x :scs (descriptor-reg))) @@ -633,7 +653,7 @@ `(progn (move dup real) (inst unpcklps dup dup))) - ,single-inst movss movaps + ,single-inst movss movq single-reg fp-single-immediate single-float complex-single-reg fp-complex-single-immediate complex-single-float ,single-real-complex-name ,single-complex-real-name) @@ -772,6 +792,8 @@ (:vop-var vop) (:save-p :compute-only) (:generator 1 + (unless (location= x y) + (inst xorpd y y)) (note-this-location vop :internal-error) (inst sqrtsd y x))) @@ -1039,8 +1061,7 @@ (macrolet ((frob (name translate inst to-sc to-type) `(define-vop (,name) - (:args (x :scs (signed-stack signed-reg) :target temp)) - (:temporary (:sc signed-stack) temp) + (:args (x :scs (signed-stack signed-reg))) (:results (y :scs (,to-sc))) (:arg-types signed-num) (:result-types ,to-type) @@ -1050,20 +1071,17 @@ (:vop-var vop) (:save-p :compute-only) (:generator 5 - (sc-case x - (signed-reg - (inst mov temp x) - (note-this-location vop :internal-error) - (inst ,inst y temp)) - (signed-stack - (note-this-location vop :internal-error) - (inst ,inst y x))))))) + (sc-case y + (single-reg (inst xorps y y)) + (double-reg (inst xorpd y y))) + (note-this-location vop :internal-error) + (inst ,inst y x))))) (frob %single-float/signed %single-float cvtsi2ss single-reg single-float) (frob %double-float/signed %double-float cvtsi2sd double-reg double-float)) -(macrolet ((frob (name translate inst from-sc from-type to-sc to-type) +(macrolet ((frob (name translate inst from-scs from-type ea-func to-sc to-type) `(define-vop (,name) - (:args (x :scs (,from-sc) :target y)) + (:args (x :scs ,from-scs :target y)) (:results (y :scs (,to-sc))) (:arg-types ,from-type) (:result-types ,to-type) @@ -1073,19 +1091,29 @@ (:vop-var vop) (:save-p :compute-only) (:generator 2 + (unless (location= x y) + (sc-case y + (single-reg (inst xorps y y)) + (double-reg (inst xorpd y y)))) (note-this-location vop :internal-error) - (inst ,inst y x))))) - (frob %single-float/double-float %single-float cvtsd2ss double-reg - double-float single-reg single-float) + (inst ,inst y (sc-case x + (,(first from-scs) x) + (,(second from-scs) (,ea-func x)))) + ,(when (and (eq from-type 'double-float) ; if the input is wider + (eq to-type 'single-float)) ; than the output, clear + `(when (location= x y) ; noise in the high part + (inst shufps y y #4r3330))))))) + (frob %single-float/double-float %single-float cvtsd2ss + (double-reg double-stack) double-float ea-for-df-stack + single-reg single-float) (frob %double-float/single-float %double-float cvtss2sd - single-reg single-float double-reg double-float)) + (single-reg single-stack) single-float ea-for-sf-stack + double-reg double-float)) -(macrolet ((frob (trans inst from-sc from-type round-p) - (declare (ignore round-p)) +(macrolet ((frob (trans inst from-scs from-type ea-func) `(define-vop (,(symbolicate trans "/" from-type)) - (:args (x :scs (,from-sc))) - (:temporary (:sc any-reg) temp-reg) + (:args (x :scs ,from-scs)) (:results (y :scs (signed-reg))) (:arg-types ,from-type) (:result-types signed-num) @@ -1095,18 +1123,18 @@ (:vop-var vop) (:save-p :compute-only) (:generator 5 - (sc-case y - (signed-stack - (inst ,inst temp-reg x) - (move y temp-reg)) - (signed-reg - (inst ,inst y x) - )))))) - (frob %unary-truncate cvttss2si single-reg single-float nil) - (frob %unary-truncate cvttsd2si double-reg double-float nil) - - (frob %unary-round cvtss2si single-reg single-float t) - (frob %unary-round cvtsd2si double-reg double-float t)) + (inst ,inst y (sc-case x + (,(first from-scs) x) + (,(second from-scs) (,ea-func x)))))))) + (frob %unary-truncate/single-float cvttss2si + (single-reg single-stack) single-float ea-for-sf-stack) + (frob %unary-truncate/double-float cvttsd2si + (double-reg double-stack) double-float ea-for-df-stack) + + (frob %unary-round cvtss2si + (single-reg single-stack) single-float ea-for-sf-stack) + (frob %unary-round cvtsd2si + (double-reg double-stack) double-float ea-for-df-stack)) (define-vop (make-single-float) (:args (bits :scs (signed-reg) :target res @@ -1136,6 +1164,24 @@ (signed-stack (inst movd res bits))))))) +(define-vop (make-single-float-c) + (:results (res :scs (single-reg single-stack descriptor-reg))) + (:arg-types (:constant (signed-byte 32))) + (:result-types single-float) + (:info bits) + (:translate make-single-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 1 + (sc-case res + (single-stack + (inst mov res bits)) + (single-reg + (inst movss res (register-inline-constant :dword bits))) + (descriptor-reg + (inst mov res (logior (ash bits 32) + single-float-widetag)))))) + (define-vop (make-double-float) (:args (hi-bits :scs (signed-reg)) (lo-bits :scs (unsigned-reg))) @@ -1152,35 +1198,37 @@ (inst or temp lo-bits) (inst movd res temp))) +(define-vop (make-double-float-c) + (:results (res :scs (double-reg))) + (:arg-types (:constant (signed-byte 32)) (:constant (unsigned-byte 32))) + (:result-types double-float) + (:info hi lo) + (:translate make-double-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 1 + (inst movsd res (register-inline-constant :qword (logior (ash hi 32) lo))))) + (define-vop (single-float-bits) (:args (float :scs (single-reg descriptor-reg) :load-if (not (sc-is float single-stack)))) (:results (bits :scs (signed-reg))) - (:temporary (:sc signed-stack :from :argument :to :result) stack-temp) (:arg-types single-float) (:result-types signed-num) (:translate single-float-bits) (:policy :fast-safe) - (:vop-var vop) (:generator 4 - (sc-case bits - (signed-reg - (sc-case float - (single-reg - (inst movss stack-temp float) - (move bits stack-temp)) - (single-stack - (move bits float)) - (descriptor-reg - (move bits float) - (inst shr bits 32)))) - (signed-stack - (sc-case float - (single-reg - (inst movss bits float))))) - ;; Sign-extend - (inst shl bits 32) - (inst sar bits 32))) + (sc-case float + (single-reg + (inst movd bits float) + (inst movsxd bits (reg-in-size bits :dword))) + (single-stack + (inst movsxd bits (make-ea :dword ; c.f. ea-for-sf-stack + :base rbp-tn + :disp (frame-byte-offset (tn-offset float))))) + (descriptor-reg + (move bits float) + (inst sar bits 32))))) (define-vop (double-float-high-bits) (:args (float :scs (double-reg descriptor-reg)