1.0.37.65: Perform range reduction on x87 transcendentals

  * ... instead of returning 0.0 arbitrarily.

diff --git a/NEWS b/NEWS
index d1c8e99..9c3df33 100644 (file)
--- 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 (file)
--- 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 (file)
--- 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 (file)
--- 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"