X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Ffloat.lisp;h=601dabd8cafe1858b277b54d1c98962a47fbb6c0;hb=33a45339444f8418c8c537c43d59fc3d5ea3098b;hp=6943574f89bafb110dfb4ab3b590311767879df8;hpb=20954a1e7add5779b855d9d6e6444314e77df3f5;p=sbcl.git

diff --git a/src/compiler/x86-64/float.lisp b/src/compiler/x86-64/float.lisp
index 6943574..601dabd 100644
--- a/src/compiler/x86-64/float.lisp
+++ b/src/compiler/x86-64/float.lisp
@@ -51,9 +51,7 @@
                       (+ (tn-offset ,tn)
                        (cond ((= (tn-offset ,base) rsp-offset)
                               sp->fp-offset)
-                             ((= (tn-offset ,base) rbp-offset)
-                              0)
-                             (t (error "Unexpected offset.")))
+                             (t 0))
                        (ecase ,kind
                          (:single
                             (ecase ,slot
@@ -191,17 +189,39 @@
   (double-reg) (descriptor-reg))
 
 ;;; Move from a descriptor to a float register.
-(define-vop (move-to-single)
+(define-vop (move-to-single-reg)
+   (:args (x :scs (descriptor-reg) :target tmp
+             :load-if (not (sc-is x control-stack))))
+   (:temporary (:sc unsigned-reg :from :argument :to :result) tmp)
+   (:results (y :scs (single-reg)))
+   (:note "pointer to float coercion")
+   (:generator 2
+     (sc-case x
+       (descriptor-reg
+        (move tmp x)
+        (inst shr tmp 32)
+        (inst movd y tmp))
+       (control-stack
+        ;; When the single-float descriptor is in memory, the untagging
+        ;; is done in the target XMM register. This is faster than going
+        ;; through a general-purpose register and the code is smaller.
+        (inst movq y x)
+        (inst shufps y y #4r3331)))))
+(define-move-vop move-to-single-reg :move (descriptor-reg) (single-reg))
+
+;;; Move from a descriptor to a float stack.
+(define-vop (move-to-single-stack)
   (:args (x :scs (descriptor-reg) :target tmp))
-  (:temporary (:sc unsigned-reg) tmp)
-  (:results (y :scs (single-reg)))
+  (:temporary (:sc unsigned-reg :from :argument :to :result) tmp)
+  (:results (y :scs (single-stack)))
   (:note "pointer to float coercion")
   (:generator 2
     (move tmp x)
     (inst shr tmp 32)
-    (inst movd y tmp)))
-
-(define-move-vop move-to-single :move (descriptor-reg) (single-reg))
+    (let ((slot (make-ea :dword :base rbp-tn
+                         :disp (frame-byte-offset (tn-offset y)))))
+      (inst mov slot (reg-in-size tmp :dword)))))
+(define-move-vop move-to-single-stack :move (descriptor-reg) (single-stack))
 
 (define-vop (move-to-double)
   (:args (x :scs (descriptor-reg)))
@@ -772,6 +792,8 @@
   (:vop-var vop)
   (:save-p :compute-only)
   (:generator 1
+     (unless (location= x y)
+       (inst xorpd y y))
      (note-this-location vop :internal-error)
      (inst sqrtsd y x)))
 
@@ -1049,6 +1071,9 @@
                 (:vop-var vop)
                 (:save-p :compute-only)
                 (:generator 5
+                  (sc-case y
+                    (single-reg (inst xorps y y))
+                    (double-reg (inst xorpd y y)))
                   (note-this-location vop :internal-error)
                   (inst ,inst y x)))))
   (frob %single-float/signed %single-float cvtsi2ss single-reg single-float)
@@ -1066,10 +1091,18 @@
                (:vop-var vop)
                (:save-p :compute-only)
                (:generator 2
+                (unless (location= x y)
+                  (sc-case y
+                    (single-reg (inst xorps y y))
+                    (double-reg (inst xorpd y y))))
                 (note-this-location vop :internal-error)
                 (inst ,inst y (sc-case x
                                 (,(first from-scs) x)
-                                (,(second from-scs) (,ea-func x))))))))
+                                (,(second from-scs) (,ea-func x))))
+                ,(when (and (eq from-type 'double-float) ; if the input is wider
+                            (eq to-type 'single-float))  ; than the output, clear
+                   `(when (location= x y)                ; noise in the high part
+                      (inst shufps y y #4r3330)))))))
   (frob %single-float/double-float %single-float cvtsd2ss
         (double-reg double-stack) double-float ea-for-df-stack
         single-reg single-float)