X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ffloat.lisp;h=2196cc307f301ad484d89a72af4d110aca28cb23;hb=b2ed34b667665e52609cf431c00179b136be450d;hp=03963ce37a4de1a0a156322b5177f8604e5f3974;hpb=ad9090dc91fc922a2d7edb256411c1593d12b33a;p=sbcl.git

diff --git a/src/compiler/x86/float.lisp b/src/compiler/x86/float.lisp
index 03963ce..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))
@@ -1648,11 +1652,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 +1667,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)
@@ -1821,6 +1835,22 @@
            (with-empty-tn@fp-top(res)
               (inst fld bits))))))))
 
+(define-vop (make-single-float-c)
+  (:results (res :scs (single-reg single-stack)))
+  (:arg-types (:constant (signed-byte 32)))
+  (:result-types single-float)
+  (:info bits)
+  (:translate make-single-float)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 2
+    (sc-case res
+      (single-stack
+       (inst mov res bits))
+      (single-reg
+       (with-empty-tn@fp-top (res)
+         (inst fld (register-inline-constant :dword bits)))))))
+
 (define-vop (make-double-float)
   (:args (hi-bits :scs (signed-reg))
          (lo-bits :scs (unsigned-reg)))
@@ -1839,6 +1869,19 @@
         (inst fldd (make-ea :dword :base ebp-tn
                             :disp (frame-byte-offset (1+ offset))))))))
 
+(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
+    (with-empty-tn@fp-top(res)
+      (inst fldd (register-inline-constant
+                  :double-float-bits (logior (ash hi 32) lo))))))
+
 #!+long-float
 (define-vop (make-long-float)
   (:args (exp-bits :scs (signed-reg))