X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Ffloat.lisp;h=397ffdf19922a2cb6aeb946e1b7c0892f6771e4c;hb=HEAD;hp=227e1f96b2f70ef8ce12cb0b4313e7e8c7da2557;hpb=a93f828030465bfc0fb85957693f1c3c2ab0a539;p=sbcl.git diff --git a/src/compiler/x86-64/float.lisp b/src/compiler/x86-64/float.lisp index 227e1f9..397ffdf 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 @@ -392,27 +390,31 @@ complex-double-float)) (macrolet ((generate (opinst commutative constant-sc load-inst) - `(flet ((get-constant (tn) - (register-inline-constant - ,@(and (eq constant-sc 'fp-single-immediate) - '(:aligned)) - (tn-value tn)))) + `(flet ((get-constant (tn &optional maybe-aligned) + (declare (ignorable maybe-aligned)) + (let ((value (tn-value tn))) + ,(if (eq constant-sc 'fp-complex-single-immediate) + `(if maybe-aligned + (register-inline-constant + :aligned value) + (register-inline-constant value)) + `(register-inline-constant value))))) (declare (ignorable #'get-constant)) (cond ((location= x r) (when (sc-is y ,constant-sc) - (setf y (get-constant y))) + (setf y (get-constant y t))) (inst ,opinst x y)) ((and ,commutative (location= y r)) (when (sc-is x ,constant-sc) - (setf x (get-constant x))) + (setf x (get-constant x t))) (inst ,opinst y x)) ((not (location= r y)) (if (sc-is x ,constant-sc) (inst ,load-inst r (get-constant x)) (move r x)) (when (sc-is y ,constant-sc) - (setf y (get-constant y))) + (setf y (get-constant y t))) (inst ,opinst r y)) (t (if (sc-is x ,constant-sc) @@ -794,6 +796,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))) @@ -809,12 +813,9 @@ (:vop-var vop) (:save-p :compute-only) (:generator 1 - (note-this-location vop :internal-error) - ;; we should be able to do this better. what we - ;; really would like to do is use the target as the - ;; temp whenever it's not also the source - (move y x) - ,@body)))) + (note-this-location vop :internal-error) + (move y x) + ,@body)))) (frob (%negate/double-float %negate double-reg double-float) (inst xorpd y (register-inline-constant :oword (ash 1 63)))) (frob (%negate/complex-double-float %negate complex-double-reg complex-double-float) @@ -855,7 +856,7 @@ :load-if (not (sc-is y ,constant-sc)))) (:arg-types ,type ,type) (:temporary (:sc ,sc :from :eval) mask) - (:temporary (:sc any-reg) bits) + (:temporary (:sc dword-reg) bits) (:conditional :e) (:generator ,cost (when (or (location= y mask) @@ -867,7 +868,8 @@ (setf y (register-inline-constant :aligned (tn-value y)))) (inst pcmpeqd mask y) (inst movmskps bits mask) - (inst cmp bits #b1111))))) + (inst cmp (if (location= bits eax-tn) al-tn bits) + #b1111))))) (define-float-eql eql/single-float 4 single-reg fp-single-immediate single-float) (define-float-eql eql/double-float 4 @@ -979,7 +981,7 @@ :load-if (not (sc-is y ,complex-constant-sc)))) (:arg-types ,complex-type ,complex-type) (:temporary (:sc ,complex-sc :from :eval) cmp) - (:temporary (:sc unsigned-reg) bits) + (:temporary (:sc dword-reg) bits) (:info) (:conditional :e) (:generator 3 @@ -999,7 +1001,8 @@ (note-this-location vop :internal-error) (inst ,cmp-inst :eq cmp y) (inst ,mask-inst bits cmp) - (inst cmp bits ,mask))) + (inst cmp (if (location= bits eax-tn) al-tn bits) + ,mask))) (define-vop (,complex-real-name ,complex-complex-name) (:args (x :scs (,complex-sc ,complex-constant-sc) :target cmp @@ -1071,6 +1074,9 @@ (:vop-var vop) (:save-p :compute-only) (:generator 5 + (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) @@ -1088,10 +1094,18 @@ (: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 (sc-case x (,(first from-scs) x) - (,(second from-scs) (,ea-func 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) @@ -1153,6 +1167,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))) @@ -1169,35 +1201,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) @@ -1232,17 +1266,21 @@ (:policy :fast-safe) (:vop-var vop) (:generator 5 - (sc-case float - (double-reg - (inst movsd temp float) - (move lo-bits temp)) - (double-stack - (loadw lo-bits ebp-tn (frame-word-offset (tn-offset float)))) - (descriptor-reg - (loadw lo-bits float double-float-value-slot - other-pointer-lowtag))) - (inst shl lo-bits 32) - (inst shr lo-bits 32))) + (let ((dword-lo-bits (reg-in-size lo-bits :dword))) + (sc-case float + (double-reg + (inst movsd temp float) + (inst mov dword-lo-bits + (make-ea :dword :base rbp-tn + :disp (frame-byte-offset (tn-offset temp))))) + (double-stack + (inst mov dword-lo-bits + (make-ea :dword :base rbp-tn + :disp (frame-byte-offset (tn-offset float))))) + (descriptor-reg + (inst mov dword-lo-bits + (make-ea-for-object-slot-half float double-float-value-slot + other-pointer-lowtag)))))))