X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ffloat.lisp;h=2196cc307f301ad484d89a72af4d110aca28cb23;hb=12b1dae1a1ed90c6ffe4d958f1281c1c04a8e89b;hp=621a1cd01256b3c27cc09b48180718fc454f30c2;hpb=0d871fd7a98fc4af92a8b942a1154761466ad8c9;p=sbcl.git diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index 621a1cd..2196cc3 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) @@ -42,9 +39,9 @@ (macrolet ((ea-for-xf-stack (tn kind) `(make-ea :dword :base ebp-tn - :disp (- (* (+ (tn-offset ,tn) - (ecase ,kind (:single 1) (:double 2) (:long 3))) - n-word-bytes))))) + :disp (frame-byte-offset + (+ (tn-offset ,tn) + (ecase ,kind (:single 0) (:double 1) (:long 2))))))) (defun ea-for-sf-stack (tn) (ea-for-xf-stack tn :single)) (defun ea-for-df-stack (tn) @@ -79,13 +76,14 @@ (macrolet ((ea-for-cxf-stack (tn kind slot &optional base) `(make-ea :dword :base ,base - :disp (- (* (+ (tn-offset ,tn) - (* (ecase ,kind - (:single 1) - (:double 2) - (:long 3)) - (ecase ,slot (:real 1) (:imag 2)))) - n-word-bytes))))) + :disp (frame-byte-offset + (+ (tn-offset ,tn) + -1 + (* (ecase ,kind + (:single 1) + (:double 2) + (:long 3)) + (ecase ,slot (:real 1) (:imag 2)))))))) (defun ea-for-csf-real-stack (tn &optional (base ebp-tn)) (ea-for-cxf-stack tn :single :real base)) (defun ea-for-csf-imag-stack (tn &optional (base ebp-tn)) @@ -189,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)) @@ -401,8 +415,10 @@ (with-fixed-allocation (y single-float-widetag single-float-size node) - (with-tn@fp-top(x) - (inst fst (ea-for-sf-desc y)))))) + ;; w-f-a checks for empty body + nil) + (with-tn@fp-top(x) + (inst fst (ea-for-sf-desc y))))) (define-move-vop move-from-single :move (single-reg) (descriptor-reg)) @@ -416,8 +432,9 @@ double-float-widetag double-float-size node) - (with-tn@fp-top(x) - (inst fstd (ea-for-df-desc y)))))) + nil) + (with-tn@fp-top(x) + (inst fstd (ea-for-df-desc y))))) (define-move-vop move-from-double :move (double-reg) (descriptor-reg)) @@ -432,8 +449,9 @@ long-float-widetag long-float-size node) - (with-tn@fp-top(x) - (store-long-float (ea-for-lf-desc y)))))) + nil) + (with-tn@fp-top(x) + (store-long-float (ea-for-lf-desc y))))) #!+long-float (define-move-vop move-from-long :move (long-reg) (descriptor-reg)) @@ -504,16 +522,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)) @@ -613,6 +631,7 @@ (inst fxch x))))) (,stack-sc (if (= (tn-offset fp) esp-offset) + ;; C-call (let* ((offset (* (tn-offset y) n-word-bytes)) (ea (make-ea :dword :base fp :disp offset))) (with-tn@fp-top(x) @@ -621,14 +640,15 @@ (:double '((inst fstd ea))) #!+long-float (:long '((store-long-float ea)))))) + ;; Lisp stack (let ((ea (make-ea :dword :base fp - :disp (- (* (+ (tn-offset y) - ,(case format - (:single 1) - (:double 2) - (:long 3))) - n-word-bytes))))) + :disp (frame-byte-offset + (+ (tn-offset y) + ,(case format + (:single 0) + (:double 1) + (:long 2))))))) (with-tn@fp-top(x) ,@(ecase format (:single '((inst fst ea))) @@ -1182,8 +1202,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) @@ -1210,8 +1229,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 =) @@ -1239,8 +1257,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) @@ -1280,8 +1297,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 >) @@ -1376,8 +1389,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) @@ -1417,8 +1429,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 >) @@ -1427,8 +1438,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) @@ -1468,8 +1478,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) @@ -1478,8 +1487,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) @@ -1503,16 +1511,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) @@ -1533,8 +1540,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 =) @@ -1646,11 +1652,12 @@ #!+long-float (frob %long-float/unsigned %long-float long-reg long-float)) -;;; These should be no-ops but the compiler might want to move some -;;; things around. -(macrolet ((frob (name translate from-sc from-type to-sc to-type) +(macrolet ((frob (name translate from-sc from-type to-sc to-type + &optional to-stack-sc store-inst load-inst) `(define-vop (,name) (:args (x :scs (,from-sc) :target y)) + ,@(and to-stack-sc + `((:temporary (:sc ,to-stack-sc) temp))) (:results (y :scs (,to-sc))) (:arg-types ,from-type) (:result-types ,to-type) @@ -1660,32 +1667,41 @@ (:vop-var vop) (:save-p :compute-only) (:generator 2 - (note-this-location vop :internal-error) - (unless (location= x y) - (cond - ((zerop (tn-offset x)) - ;; x is in ST0, y is in another reg. not ST0 - (inst fst y)) - ((zerop (tn-offset y)) - ;; y is in ST0, x is in another reg. not ST0 - (copy-fp-reg-to-fr0 x)) - (t - ;; Neither x or y are in ST0, and they are not in - ;; the same reg. - (inst fxch x) - (inst fst y) - (inst fxch x)))))))) - - (frob %single-float/double-float %single-float double-reg - double-float single-reg single-float) + (note-this-location vop :internal-error) + ,(if to-stack-sc + `(progn + (with-tn@fp-top (x) + (inst ,store-inst temp)) + (with-empty-tn@fp-top (y) + (inst ,load-inst temp))) + `(unless (location= x y) + (cond + ((zerop (tn-offset x)) + ;; x is in ST0, y is in another reg. not ST0 + (inst fst y)) + ((zerop (tn-offset y)) + ;; y is in ST0, x is in another reg. not ST0 + (copy-fp-reg-to-fr0 x)) + (t + ;; Neither x or y are in ST0, and they are not in + ;; the same reg. + (inst fxch x) + (inst fst y) + (inst fxch x))))))))) + + (frob %single-float/double-float %single-float double-reg double-float + single-reg single-float + single-stack fst fld) #!+long-float (frob %single-float/long-float %single-float long-reg - long-float single-reg single-float) + long-float single-reg single-float + single-stack fst fld) (frob %double-float/single-float %double-float single-reg single-float double-reg double-float) #!+long-float (frob %double-float/long-float %double-float long-reg long-float - double-reg double-float) + double-reg double-float + double-stack fstd fldd) #!+long-float (frob %long-float/single-float %long-float single-reg single-float long-reg long-float) @@ -1730,10 +1746,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 @@ -1777,10 +1793,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 @@ -1819,6 +1835,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))) @@ -1830,12 +1862,25 @@ (:policy :fast-safe) (:vop-var vop) (:generator 2 - (let ((offset (1+ (tn-offset temp)))) - (storew hi-bits ebp-tn (- offset)) - (storew lo-bits ebp-tn (- (1+ offset))) + (let ((offset (tn-offset temp))) + (storew hi-bits ebp-tn (frame-word-offset offset)) + (storew lo-bits ebp-tn (frame-word-offset (1+ offset))) (with-empty-tn@fp-top(res) (inst fldd (make-ea :dword :base ebp-tn - :disp (- (* (1+ offset) n-word-bytes)))))))) + :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) @@ -1850,13 +1895,13 @@ (:policy :fast-safe) (:vop-var vop) (:generator 3 - (let ((offset (1+ (tn-offset temp)))) - (storew exp-bits ebp-tn (- offset)) - (storew hi-bits ebp-tn (- (1+ offset))) - (storew lo-bits ebp-tn (- (+ offset 2))) + (let ((offset (tn-offset temp))) + (storew exp-bits ebp-tn (frame-word-offset offset)) + (storew hi-bits ebp-tn (frame-word-offset (1+ offset))) + (storew lo-bits ebp-tn (frame-word-offset (+ offset 2))) (with-empty-tn@fp-top(res) (inst fldl (make-ea :dword :base ebp-tn - :disp (- (* (+ offset 2) n-word-bytes)))))))) + :disp (frame-byte-offset (+ offset 2)))))))) (define-vop (single-float-bits) (:args (float :scs (single-reg descriptor-reg) @@ -1903,12 +1948,11 @@ (double-reg (with-tn@fp-top(float) (let ((where (make-ea :dword :base ebp-tn - :disp (- (* (+ 2 (tn-offset temp)) - n-word-bytes))))) + :disp (frame-byte-offset (1+ (tn-offset temp)))))) (inst fstd where))) - (loadw hi-bits ebp-tn (- (1+ (tn-offset temp))))) + (loadw hi-bits ebp-tn (frame-word-offset (tn-offset temp)))) (double-stack - (loadw hi-bits ebp-tn (- (1+ (tn-offset float))))) + (loadw hi-bits ebp-tn (frame-word-offset (tn-offset float)))) (descriptor-reg (loadw hi-bits float (1+ double-float-value-slot) other-pointer-lowtag))))) @@ -1928,12 +1972,11 @@ (double-reg (with-tn@fp-top(float) (let ((where (make-ea :dword :base ebp-tn - :disp (- (* (+ 2 (tn-offset temp)) - n-word-bytes))))) + :disp (frame-byte-offset (1+ (tn-offset temp)))))) (inst fstd where))) - (loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp))))) + (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset temp))))) (double-stack - (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float))))) + (loadw lo-bits ebp-tn (frame-word-offset (1+ (tn-offset float))))) (descriptor-reg (loadw lo-bits float double-float-value-slot other-pointer-lowtag))))) @@ -1954,22 +1997,19 @@ (long-reg (with-tn@fp-top(float) (let ((where (make-ea :dword :base ebp-tn - :disp (- (* (+ 3 (tn-offset temp)) - n-word-bytes))))) + :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) (store-long-float where))) (inst movsx exp-bits (make-ea :word :base ebp-tn - :disp (* (- (1+ (tn-offset temp))) n-word-bytes)))) + :disp (frame-byte-offset (tn-offset temp))))) (long-stack (inst movsx exp-bits (make-ea :word :base ebp-tn - :disp (* (- (1+ (tn-offset float))) n-word-bytes)))) + :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) @@ -1987,12 +2027,11 @@ (long-reg (with-tn@fp-top(float) (let ((where (make-ea :dword :base ebp-tn - :disp (- (* (+ 3 (tn-offset temp)) - n-word-bytes))))) + :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) (store-long-float where))) - (loadw hi-bits ebp-tn (- (+ (tn-offset temp) 2)))) + (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp))))) (long-stack - (loadw hi-bits ebp-tn (- (+ (tn-offset float) 2)))) + (loadw hi-bits ebp-tn (frame-word-offset (1+ (tn-offset temp))))) (descriptor-reg (loadw hi-bits float (1+ long-float-value-slot) other-pointer-lowtag))))) @@ -2013,12 +2052,11 @@ (long-reg (with-tn@fp-top(float) (let ((where (make-ea :dword :base ebp-tn - :disp (- (* (+ 3 (tn-offset temp)) - n-word-bytes))))) + :disp (frame-byte-offset (+ 2 (tn-offset temp)))))) (store-long-float where))) - (loadw lo-bits ebp-tn (- (+ (tn-offset temp) 3)))) + (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset temp) 2)))) (long-stack - (loadw lo-bits ebp-tn (- (+ (tn-offset float) 3)))) + (loadw lo-bits ebp-tn (frame-word-offset (+ (tn-offset float) 2)))) (descriptor-reg (loadw lo-bits float long-float-value-slot other-pointer-lowtag))))) @@ -2165,6 +2203,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))) @@ -2176,21 +2218,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)) @@ -2226,11 +2281,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)