From: Paul Khuong <pvk@pvk.ca>
Date: Sat, 11 Jun 2011 05:41:27 +0000 (-0400)
Subject: Avoid constant folding NaNs from MAKE-{SINGLE,DOUBLE}-FLOAT
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=9e37bfc1ef0532a16a9ac8b1e48123ee19347f80;p=sbcl.git

Avoid constant folding NaNs from MAKE-{SINGLE,DOUBLE}-FLOAT

Perform it in a specialised transform that checks for NaNs, and
add VOPs for constant arguments to avoid any slowdown.

Fixes lp#486812.
---

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 882cc70..e0d6e93 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -102,10 +102,36 @@
 ;;;; float accessors
 
 (defknown make-single-float ((signed-byte 32)) single-float
-  (movable foldable flushable))
+  (movable flushable))
 
 (defknown make-double-float ((signed-byte 32) (unsigned-byte 32)) double-float
-  (movable foldable flushable))
+  (movable flushable))
+
+#-sb-xc-host
+(deftransform make-single-float ((bits)
+                                 ((signed-byte 32)))
+  "Conditional constant folding"
+  (unless (constant-lvar-p bits)
+    (give-up-ir1-transform))
+  (let* ((bits  (lvar-value bits))
+         (float (make-single-float bits)))
+    (when (float-nan-p float)
+      (give-up-ir1-transform))
+    float))
+
+#-sb-xc-host
+(deftransform make-double-float ((hi lo)
+                                 ((signed-byte 32) (unsigned-byte 32)))
+  "Conditional constant folding"
+  (unless (and (constant-lvar-p hi)
+               (constant-lvar-p lo))
+    (give-up-ir1-transform))
+  (let* ((hi    (lvar-value hi))
+         (lo    (lvar-value lo))
+         (float (make-double-float hi lo)))
+    (when (float-nan-p float)
+      (give-up-ir1-transform))
+    float))
 
 (defknown single-float-bits (single-float) (signed-byte 32)
   (movable foldable flushable))
diff --git a/src/compiler/x86-64/float.lisp b/src/compiler/x86-64/float.lisp
index c2c2d26..ec3fad0 100644
--- a/src/compiler/x86-64/float.lisp
+++ b/src/compiler/x86-64/float.lisp
@@ -1164,6 +1164,24 @@
           (signed-stack
            (inst movd res bits)))))))
 
+(define-vop (make-single-float-c)
+  (:results (res :scs (single-reg single-stack descriptor-reg)))
+  (:arg-types (:constant (signed-byte 32)))
+  (:result-types single-float)
+  (:info bits)
+  (:translate make-single-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 1
+    (sc-case res
+       (single-stack
+        (inst mov res bits))
+       (single-reg
+        (inst movss res (register-inline-constant :dword bits)))
+       (descriptor-reg
+        (inst mov res (logior (ash bits 32)
+                              single-float-widetag))))))
+
 (define-vop (make-double-float)
   (:args (hi-bits :scs (signed-reg))
          (lo-bits :scs (unsigned-reg)))
@@ -1180,6 +1198,17 @@
     (inst or temp lo-bits)
     (inst movd res temp)))
 
+(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
+    (inst movsd res (register-inline-constant :qword (logior (ash hi 32) lo)))))
+
 (define-vop (single-float-bits)
   (:args (float :scs (single-reg descriptor-reg)
                 :load-if (not (sc-is float single-stack))))
diff --git a/tests/compiler.pure.lisp b/tests/compiler.pure.lisp
index 7b2e915..19f6c96 100644
--- a/tests/compiler.pure.lisp
+++ b/tests/compiler.pure.lisp
@@ -3926,3 +3926,11 @@
     (assert (equal `(function ((single-float (0.0)))
                               (values (or (member 0.0) (single-float (0.0))) &optional))
                    (sb-kernel:%simple-fun-type f)))))
+
+(with-test (:name (:bug-486812 single-float))
+  (compile nil `(lambda ()
+                  (sb-kernel:make-single-float -1))))
+
+(with-test (:name (:bug-486812 double-float))
+  (compile nil `(lambda ()
+                  (sb-kernel:make-double-float -1 0))))