From ad9090dc91fc922a2d7edb256411c1593d12b33a Mon Sep 17 00:00:00 2001 From: Paul Khuong Date: Mon, 26 Apr 2010 21:38:19 +0000 Subject: [PATCH] 1.0.37.65: Perform range reduction on x87 transcendentals * ... instead of returning 0.0 arbitrarily. --- NEWS | 2 ++ src/compiler/x86/float.lisp | 70 ++++++++++++++++++++++++++++++------------- tests/float.pure.lisp | 34 +++++++++++++++++++++ version.lisp-expr | 2 +- 4 files changed, 87 insertions(+), 21 deletions(-) diff --git a/NEWS b/NEWS index d1c8e99..9c3df33 100644 --- a/NEWS +++ b/NEWS @@ -41,6 +41,8 @@ changes relative to sbcl-1.0.37: incurred an off-by-one miscount. * enhancement: improved MAKE-HASH-TABLE documentation (lp#543473) * enhancement: improved DEFMETHOD pretty-printing. + * enhancement: perform range reduction when arguments are too large for + x87's transcendentals (instead of returning 0). (lp#327192) * bug fix: correct restart text for the continuable error in MAKE-PACKAGE. * bug fix: a rare case of startup-time page table corruption. * bug fix: a semaphore with multiple waiters and some of them unwinding due diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp index f0c0921..03963ce 100644 --- a/src/compiler/x86/float.lisp +++ b/src/compiler/x86/float.lisp @@ -2160,6 +2160,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))) @@ -2171,21 +2175,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)) @@ -2221,11 +2238,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) diff --git a/tests/float.pure.lisp b/tests/float.pure.lisp index f0d9a5d..01d7ae1 100644 --- a/tests/float.pure.lisp +++ b/tests/float.pure.lisp @@ -244,3 +244,37 @@ (eql #c(1.0 2.0) (the (eql #c(1.0 2.0)) x)))))))) + +;; The x86 port used not to reduce the arguments of transcendentals +;; correctly. On other platforms, we trust libm to DTRT. +#+x86 +(with-test (:name :range-reduction) + (flet ((almost= (x y) + (< (abs (- x y)) 1d-5))) + (macrolet ((foo (op value) + `(assert (almost= (,op (mod ,value (* 2 pi))) + (,op ,value))))) + (let ((big (* pi (expt 2d0 70))) + (mid (coerce most-positive-fixnum 'double-float)) + (odd (* pi most-positive-fixnum))) + (foo sin big) + (foo sin mid) + (foo sin odd) + (foo sin (/ odd 2d0)) + + (foo cos big) + (foo cos mid) + (foo cos odd) + (foo cos (/ odd 2d0)) + + (foo tan big) + (foo tan mid) + (foo tan odd))))) + +;; Leakage from the host could result in wrong values for truncation. +(with-test (:name :truncate) + (assert (plusp (sb-kernel:%unary-truncate/single-float (expt 2f0 33)))) + (assert (plusp (sb-kernel:%unary-truncate/double-float (expt 2d0 33)))) + ;; That'd be one strange host, but just in case + (assert (plusp (sb-kernel:%unary-truncate/single-float (expt 2f0 65)))) + (assert (plusp (sb-kernel:%unary-truncate/double-float (expt 2d0 65))))) diff --git a/version.lisp-expr b/version.lisp-expr index 8ae5003..a76db2c 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.37.64" +"1.0.37.65" -- 1.7.10.4