X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ffloat.lisp;h=0d20e7fef697803f425e3490f95915aad3bdabea;hb=57fe836373e2ecb56e6d497320b01c83447a01fc;hp=183f97945ad98d8e00554a0dd6d39ded6a0e699d;hpb=9510443d0bd00fcbd0213e07a5340e66d9ce7301;p=sbcl.git diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index 183f979..0d20e7f 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -187,7 +187,7 @@ #!+long-float 'long-float #!-long-float 'double-float)) (define-move-fun (load-fp-constant 2) (vop x y) ((fp-constant) (single-reg double-reg #!+long-float long-reg)) - (let ((value (sb!c::constant-value (sb!c::tn-leaf x)))) + (let ((value (tn-value x))) (with-empty-tn@fp-top(y) (cond ((or (eql value 0f0) (eql value 0d0) #!+long-float (eql value 0l0)) (inst fldz)) @@ -209,6 +209,17 @@ ((= value (log 2e0 2.718281828459045235360287471352662e0)) (inst fldln2)) (t (warn "ignoring bogus i387 constant ~A" value)))))) + +(define-move-fun (load-fp-immediate 2) (vop x y) + ((fp-single-immediate) (single-reg) + (fp-double-immediate) (double-reg)) + (let ((value (register-inline-constant (tn-value x)))) + (with-empty-tn@fp-top(y) + (sc-case y + (single-reg + (inst fld value)) + (double-reg + (inst fldd value)))))) (eval-when (:compile-toplevel :execute) (setf *read-default-float-format* 'single-float)) @@ -507,16 +518,16 @@ (:node-var node) (:note "complex float to pointer coercion") (:generator 13 - (with-fixed-allocation (y - complex-single-float-widetag - complex-single-float-size - node) - (let ((real-tn (complex-single-reg-real-tn x))) - (with-tn@fp-top(real-tn) - (inst fst (ea-for-csf-real-desc y)))) - (let ((imag-tn (complex-single-reg-imag-tn x))) - (with-tn@fp-top(imag-tn) - (inst fst (ea-for-csf-imag-desc y))))))) + (with-fixed-allocation (y + complex-single-float-widetag + complex-single-float-size + node) + (let ((real-tn (complex-single-reg-real-tn x))) + (with-tn@fp-top(real-tn) + (inst fst (ea-for-csf-real-desc y)))) + (let ((imag-tn (complex-single-reg-imag-tn x))) + (with-tn@fp-top(imag-tn) + (inst fst (ea-for-csf-imag-desc y))))))) (define-move-vop move-from-complex-single :move (complex-single-reg) (descriptor-reg)) @@ -1721,10 +1732,10 @@ (inst mov y stack-temp))) ,@(unless round-p '((inst fldcw scw))))))))) - (frob %unary-truncate single-reg single-float nil) - (frob %unary-truncate double-reg double-float nil) + (frob %unary-truncate/single-float single-reg single-float nil) + (frob %unary-truncate/double-float double-reg double-float nil) #!+long-float - (frob %unary-truncate long-reg long-float nil) + (frob %unary-truncate/long-float long-reg long-float nil) (frob %unary-round single-reg single-float t) (frob %unary-round double-reg double-float t) #!+long-float @@ -1768,10 +1779,10 @@ (inst add esp-tn 4) ,@(unless round-p '((inst fldcw scw))))))) - (frob %unary-truncate single-reg single-float nil) - (frob %unary-truncate double-reg double-float nil) + (frob %unary-truncate/single-float single-reg single-float nil) + (frob %unary-truncate/double-float double-reg double-float nil) #!+long-float - (frob %unary-truncate long-reg long-float nil) + (frob %unary-truncate/long-float long-reg long-float nil) (frob %unary-round single-reg single-float t) (frob %unary-round double-reg double-float t) #!+long-float @@ -1810,6 +1821,22 @@ (with-empty-tn@fp-top(res) (inst fld bits)))))))) +(define-vop (make-single-float-c) + (:results (res :scs (single-reg single-stack))) + (:arg-types (:constant (signed-byte 32))) + (:result-types single-float) + (:info bits) + (:translate make-single-float) + (:policy :fast-safe) + (:vop-var vop) + (:generator 2 + (sc-case res + (single-stack + (inst mov res bits)) + (single-reg + (with-empty-tn@fp-top (res) + (inst fld (register-inline-constant :dword bits))))))) + (define-vop (make-double-float) (:args (hi-bits :scs (signed-reg)) (lo-bits :scs (unsigned-reg))) @@ -1828,6 +1855,19 @@ (inst fldd (make-ea :dword :base ebp-tn :disp (frame-byte-offset (1+ offset)))))))) +(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 + (with-empty-tn@fp-top(res) + (inst fldd (register-inline-constant + :double-float-bits (logior (ash hi 32) lo)))))) + #!+long-float (define-vop (make-long-float) (:args (exp-bits :scs (signed-reg)) @@ -2149,6 +2189,10 @@ (:args (x :scs (double-reg) :target fr0)) (:temporary (:sc double-reg :offset fr0-offset :from :argument :to :result) fr0) + ;; FIXME: make that an arbitrary location and + ;; FXCH only when range reduction needed + (:temporary (:sc double-reg :offset fr1-offset + :from :argument :to :result) fr1) (:temporary (:sc unsigned-reg :offset eax-offset :from :argument :to :result) eax) (:results (y :scs (double-reg))) @@ -2160,21 +2204,34 @@ (:save-p :compute-only) (:ignore eax) (:generator 5 - (note-this-location vop :internal-error) - (unless (zerop (tn-offset x)) - (inst fxch x) ; x to top of stack - (unless (location= x y) - (inst fst x))) ; maybe save it - (inst ,op) - (inst fnstsw) ; status word to ax - (inst and ah-tn #x04) ; C2 - (inst jmp :z DONE) - ;; Else x was out of range so reduce it; ST0 is unchanged. - (inst fstp fr0) ; Load 0.0 - (inst fldz) - DONE - (unless (zerop (tn-offset y)) - (inst fstd y)))))) + (let ((DONE (gen-label)) + (REDUCE (gen-label)) + (REDUCE-LOOP (gen-label))) + (note-this-location vop :internal-error) + (unless (zerop (tn-offset x)) + (inst fxch x) ; x to top of stack + (unless (location= x y) + (inst fst x))) ; maybe save it + (inst ,op) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :nz REDUCE) + (emit-label DONE) + (unless (zerop (tn-offset y)) + (inst fstd y)) + (assemble (*elsewhere*) + (emit-label REDUCE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (with-empty-tn@fp-top (fr1) + (inst fldpi) + (inst fadd fr0)) + (emit-label REDUCE-LOOP) + (inst fprem1) + (inst fnstsw) + (inst and ah-tn #x04) + (inst jmp :nz REDUCE-LOOP) + (inst ,op) + (inst jmp DONE))))))) (frob fsin %sin fsin) (frob fcos %cos fcos)) @@ -2210,11 +2267,24 @@ :sc (sc-or-lose 'double-reg) :offset (- (tn-offset x) 2))))) (inst fptan) - (inst fnstsw) ; status word to ax - (inst and ah-tn #x04) ; C2 - (inst jmp :z DONE) - ;; Else x was out of range so load 0.0 - (inst fxch fr1) + (let ((REDUCE (gen-label)) + (REDUCE-LOOP (gen-label))) + (inst fnstsw) ; status word to ax + (inst and ah-tn #x04) ; C2 + (inst jmp :nz REDUCE) + (assemble (*elsewhere*) + (emit-label REDUCE) + ;; Else x was out of range so reduce it; ST0 is unchanged. + (with-empty-tn@fp-top (fr1) + (inst fldpi) + (inst fadd fr0)) + (emit-label REDUCE-LOOP) + (inst fprem1) + (inst fnstsw) + (inst and ah-tn #x04) + (inst jmp :nz REDUCE-LOOP) + (inst fptan) + (inst jmp DONE))) DONE ;; Result is in fr1 (case (tn-offset y)