From: Paul Khuong <pvk@pvk.ca>
Date: Fri, 28 Jun 2013 05:45:49 +0000 (-0400)
Subject: double->single float conversion isn't a no-op on x87 anymore
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=74cf7a4d01664fbf72a662ba093ad67ca243b524;p=sbcl.git

double->single float conversion isn't a no-op on x87 anymore

 The conversion can result in overflow, so pass through a stack
 temporary to force a truncation.

 Test case by Peter Keller on sbcl-devel, 2013-06-26.
---

diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp
index 0d20e7f..5372116 100644
--- a/src/compiler/x86/float.lisp
+++ b/src/compiler/x86/float.lisp
@@ -1648,11 +1648,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)
@@ -1662,32 +1663,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)
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 8f8d4c3..48d413d 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -4656,3 +4656,15 @@
                         ((some (lambda (c)
                                  (digit-char-p c))
                                string))))))
+
+;; the x87 backend used to sometimes signal FP errors during boxing,
+;; because converting between double and single float values was a
+;; noop (fixed), and no doubt many remaining issues.  We now store
+;; the value outside pseudo-atomic, so any SIGFPE should be handled
+;; corrrectly.
+;;
+;; When it fails, this test lands into ldb.
+(with-test (:name :no-overflow-during-allocation)
+  (handler-case (eval '(cosh 90))
+    (floating-point-overflow ()
+      t)))