From 8fee78e20e0ca4081f7551cea496feeaad8484cf Mon Sep 17 00:00:00 2001
From: Paul Khuong <pvk@pvk.ca>
Date: Fri, 28 Jun 2013 02:01:06 -0400
Subject: [PATCH] Store FP values from x87 to the heap outside pseudo-atomic

 It suffices to get the header right, and that way we avoid signaling
 FPEs in PA, when, as is bound to happen, a value is only truncated
 when it's boxed.
---
 NEWS                        |    2 ++
 src/compiler/x86/float.lisp |   16 ++++++++++------
 2 files changed, 12 insertions(+), 6 deletions(-)

diff --git a/NEWS b/NEWS
index d5644be..aa61374 100644
--- a/NEWS
+++ b/NEWS
@@ -47,6 +47,8 @@ changes relative to sbcl-1.1.8:
   * bug fix: Remove GPL-licensed files from source distribution. (lp#1185668)
   * bug fix: backtrace printer no longer tries to create very large lists when
     the arg-count register is clobberred by other code. (lp#1192929)
+  * bug fix: x86 should never signal an FP exception while boxing an FP value,
+    a situation that lands us into ldb.
 
 changes in sbcl-1.1.8 relative to sbcl-1.1.7:
   * notice: The implementation of MAP-ALLOCATED-OBJECTS (the heart of
diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp
index 5372116..2196cc3 100644
--- a/src/compiler/x86/float.lisp
+++ b/src/compiler/x86/float.lisp
@@ -415,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))
 
@@ -430,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))
 
@@ -446,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))
-- 
1.7.10.4