X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ffloat.lisp;h=f0c0921f74393b615e6837ef537ccd7b92dca55d;hb=49e8403800426f37a54d9b87353a31af36e7af40;hp=cd2c3bab7f136ccab6d15682303a45e7969f047e;hpb=48ff891135e403e49037940bbad18d262e23df5e;p=sbcl.git diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index cd2c3ba..f0c0921 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -12,10 +12,7 @@ (in-package "SB!VM") (macrolet ((ea-for-xf-desc (tn slot) - `(make-ea - :dword :base ,tn - :disp (- (* ,slot n-word-bytes) - other-pointer-lowtag)))) + `(make-ea-for-object-slot ,tn ,slot other-pointer-lowtag))) (defun ea-for-sf-desc (tn) (ea-for-xf-desc tn single-float-value-slot)) (defun ea-for-df-desc (tn) @@ -190,23 +187,39 @@ #!+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 ((zerop value) + (cond ((or (eql value 0f0) (eql value 0d0) #!+long-float (eql value 0l0)) (inst fldz)) ((= value 1e0) (inst fld1)) + #!+long-float ((= value (coerce pi *read-default-float-format*)) (inst fldpi)) + #!+long-float ((= value (log 10e0 2e0)) (inst fldl2t)) + #!+long-float ((= value (log 2.718281828459045235360287471352662e0 2e0)) (inst fldl2e)) + #!+long-float ((= value (log 2e0 10e0)) (inst fldlg2)) + #!+long-float ((= 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)) @@ -505,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)) @@ -1185,8 +1198,7 @@ (define-vop (=/float) (:args (x) (y)) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p) + (:conditional :e) (:policy :fast-safe) (:vop-var vop) (:save-p :compute-only) @@ -1213,8 +1225,7 @@ (inst fxch x))) (inst fnstsw) ; status word to ax (inst and ah-tn #x45) ; C3 C2 C0 - (inst cmp ah-tn #x40) - (inst jmp (if not-p :ne :e) target))) + (inst cmp ah-tn #x40))) (define-vop (=/single-float =/float) (:translate =) @@ -1242,8 +1253,7 @@ (:arg-types single-float single-float) (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p) + (:conditional :e) (:policy :fast-safe) (:note "inline float comparison") (:ignore temp) @@ -1283,8 +1293,7 @@ (inst fcom (ea-for-sf-desc y))))) (inst fnstsw) ; status word to ax (inst and ah-tn #x45) ; C3 C2 C0 - (inst cmp ah-tn #x01))) - (inst jmp (if not-p :ne :e) target))) + (inst cmp ah-tn #x01))))) (define-vop (single-float) (:translate >) @@ -1379,8 +1385,7 @@ (:arg-types single-float single-float) (:temporary (:sc single-reg :offset fr0-offset :from :eval) fr0) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p) + (:conditional :e) (:policy :fast-safe) (:note "inline float comparison") (:ignore temp) @@ -1420,8 +1425,7 @@ (inst fcom (ea-for-sf-stack y)) (inst fcom (ea-for-sf-desc y))))) (inst fnstsw) ; status word to ax - (inst and ah-tn #x45))) - (inst jmp (if not-p :ne :e) target))) + (inst and ah-tn #x45))))) (define-vop (>double-float) (:translate >) @@ -1430,8 +1434,7 @@ (:arg-types double-float double-float) (:temporary (:sc double-reg :offset fr0-offset :from :eval) fr0) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p) + (:conditional :e) (:policy :fast-safe) (:note "inline float comparison") (:ignore temp) @@ -1471,8 +1474,7 @@ (inst fcomd (ea-for-df-stack y)) (inst fcomd (ea-for-df-desc y))))) (inst fnstsw) ; status word to ax - (inst and ah-tn #x45))) - (inst jmp (if not-p :ne :e) target))) + (inst and ah-tn #x45))))) #!+long-float (define-vop (>long-float) @@ -1481,8 +1483,7 @@ (y :scs (long-reg))) (:arg-types long-float long-float) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p) + (:conditional :e) (:policy :fast-safe) (:note "inline float comparison") (:ignore temp) @@ -1506,16 +1507,15 @@ (inst fcomd y) (inst fxch x) (inst fnstsw) ; status word to ax - (inst and ah-tn #x45))) - (inst jmp (if not-p :ne :e) target))) + (inst and ah-tn #x45))))) ;;; Comparisons with 0 can use the FTST instruction. (define-vop (float-test) (:args (x)) (:temporary (:sc word-reg :offset eax-offset :from :eval) temp) - (:conditional) - (:info target not-p y) + (:conditional :e) + (:info y) (:variant-vars code) (:policy :fast-safe) (:vop-var vop) @@ -1536,8 +1536,7 @@ (inst fnstsw) ; status word to ax (inst and ah-tn #x45) ; C3 C2 C0 (unless (zerop code) - (inst cmp ah-tn code)) - (inst jmp (if not-p :ne :e) target))) + (inst cmp ah-tn code)))) (define-vop (=0/single-float float-test) (:translate =) @@ -1733,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 @@ -1780,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 @@ -1966,10 +1965,8 @@ :disp (frame-byte-offset (tn-offset temp))))) (descriptor-reg (inst movsx exp-bits - (make-ea :word :base float - :disp (- (* (+ 2 long-float-value-slot) - n-word-bytes) - other-pointer-lowtag))))))) + (make-ea-for-object-slot float (+ 2 long-float-value-slot) + other-pointer-lowtag :word)))))) #!+long-float (define-vop (long-float-high-bits)