From 07e2d61f67dbd0e099c256052ba70358125cc008 Mon Sep 17 00:00:00 2001
From: Raymond Toy <toy.raymond@gmail.com>
Date: Mon, 21 Oct 2013 18:10:13 -0700
Subject: [PATCH] Enable micro-optimization of fast-unary-ftruncate and
 double-float-bits for x86/sse2. This gives x86 the same micro-optimizations
 that were available for sparc and ppc.

 o code/kernel.lisp:
   o Enable fast double-float-bits using the vop instead of calling
     double-float-high-bits/double-float-low-bits.

 o compiler/float-tran.lisp:
   o Make fast-unary-ftruncate known to compiler and enable optimizer
     for it.
   o Make double-float-bits known to compiler

 o compiler/x86/float-sse2.lisp:
   o Implement fast-unary-ftruncate for singles and doubles.
   o Implement double-float-bits.
---
 src/code/kernel.lisp             |  4 +--
 src/compiler/float-tran.lisp     | 24 +++++++-------
 src/compiler/x86/float-sse2.lisp | 54 ++++++++++++++++++++++++++++++++
 3 files changed, 69 insertions(+), 13 deletions(-)

diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp
index eaac29b94..a67f7f7ac 100644
--- a/src/code/kernel.lisp
+++ b/src/code/kernel.lisp
@@ -180,10 +180,10 @@
 #+long-float
 (defun long-float-low-bits (x) (long-float-low-bits x))
 
-#+(or sparc ppc)
+#+(or sparc ppc (and x86 sse2))
 (defun double-float-bits (x) (double-float-bits x))
 
-#-(or sparc ppc)
+#-(or sparc ppc (and x86 sse2))
 (defun double-float-bits (x)
   (values (double-float-high-bits x) (double-float-low-bits x)))
 
diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 639ac8a4e..a107e7937 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -192,12 +192,12 @@
   '(let ((res (%unary-ftruncate (/ x y))))
      (values res (- x (* y res)))))
 
-#+sparc
+#+(or sparc (and x86 sse2))
 (defknown fast-unary-ftruncate ((or single-float double-float))
   (or single-float double-float)
   (movable foldable flushable))
 
-#+sparc
+#+(or sparc (and x86 sse2))
 (defoptimizer (fast-unary-ftruncate derive-type) ((f))
   (one-arg-derive-type f
 		       #'(lambda (n)
@@ -224,14 +224,16 @@
 		 (if (and (numberp lo) (numberp hi)
 			  (< limit-lo lo)
 			  (< hi limit-hi))
-		     #-sparc '(let ((result (coerce (%unary-truncate x) ',ftype)))
-			        (if (zerop result)
-				    (* result x)
-				    result))
-		     #+sparc '(let ((result (fast-unary-ftruncate x)))
-			        (if (zerop result)
-				    (* result x)
-				    result))
+		     #-(or sparc (and x86 sse2))
+		     '(let ((result (coerce (%unary-truncate x) ',ftype)))
+		       (if (zerop result)
+			   (* result x)
+			   result))
+		     #+(or sparc (and x86 sse2))
+		     '(let ((result (fast-unary-ftruncate x)))
+		       (if (zerop result)
+			   (* result x)
+			   result))
 		     '(,func x))))))
   (frob single-float %unary-ftruncate/single-float)
   (frob double-float %unary-ftruncate/double-float))
@@ -355,7 +357,7 @@
 (defknown double-float-low-bits (double-float) (unsigned-byte 32)
   (movable foldable flushable))
 
-#+(or sparc ppc)
+#+(or sparc ppc (and x86 sse2))
 (defknown double-float-bits (double-float)
   (values (signed-byte 32) (unsigned-byte 32))
   (movable foldable flushable))
diff --git a/src/compiler/x86/float-sse2.lisp b/src/compiler/x86/float-sse2.lisp
index f54f0721d..27fddca27 100644
--- a/src/compiler/x86/float-sse2.lisp
+++ b/src/compiler/x86/float-sse2.lisp
@@ -1038,6 +1038,32 @@
   (frob %unary-round cvtss2si single-reg single-float t)
   (frob %unary-round cvtsd2si double-reg double-float t))
 
+(define-vop (fast-unary-ftruncate/single-float)
+  (:args (x :scs (single-reg)))
+  (:arg-types single-float)
+  (:results (r :scs (single-reg)))
+  (:result-types single-float)
+  (:policy :fast-safe)
+  (:translate c::fast-unary-ftruncate)
+  (:temporary (:sc signed-reg) temp)
+  (:note _N"inline ftruncate")
+  (:generator 2
+    (inst cvttss2si temp x)
+    (inst cvtsi2ss r temp)))
+
+(define-vop (fast-unary-ftruncate/double-float)
+  (:args (x :scs (double-reg) :target r))
+  (:arg-types double-float)
+  (:results (r :scs (double-reg)))
+  (:result-types double-float)
+  (:policy :fast-safe)
+  (:translate c::fast-unary-ftruncate)
+  (:temporary (:sc signed-reg) temp)
+  (:note _N"inline ftruncate")
+  (:generator 2
+    (inst cvttsd2si temp x)
+    (inst cvtsi2sd r temp)))
+
 (define-vop (make-single-float)
   (:args (bits :scs (signed-reg) :target res
                :load-if (not (or (and (sc-is bits signed-stack)
@@ -1159,6 +1185,34 @@
         (loadw lo-bits float vm:double-float-value-slot
 	       vm:other-pointer-type)))))
 
+(define-vop (double-float-bits)
+  (:args (float :scs (double-reg descriptor-reg)
+		:load-if (not (sc-is float double-stack))))
+  (:results (hi-bits :scs (signed-reg))
+	    (lo-bits :scs (unsigned-reg)))
+  (:arg-types double-float)
+  (:result-types signed-num unsigned-num)
+  (:temporary (:sc double-stack) temp)
+  (:translate kernel::double-float-bits)
+  (:policy :fast-safe)
+  (:vop-var vop)
+  (:generator 5
+    (sc-case float
+      (double-reg
+	(let ((where (make-ea :dword :base ebp-tn
+			      :disp (- (* (+ 2 (tn-offset temp))
+					  word-bytes)))))
+	  (inst movsd where float))
+	(loadw hi-bits ebp-tn (- (+ 1 (tn-offset temp))))
+	(loadw lo-bits ebp-tn (- (+ 2 (tn-offset temp)))))
+      (double-stack
+       (loadw hi-bits ebp-tn (- (+ 1 (tn-offset float))))
+       (loadw lo-bits ebp-tn (- (+ 2 (tn-offset float)))))
+      (descriptor-reg
+       (loadw hi-bits float (1+ double-float-value-slot)
+	   vm:other-pointer-type)
+       (loadw lo-bits float vm:double-float-value-slot
+	       vm:other-pointer-type)))))
 
 ;;;; Float mode hackery:
 
-- 
GitLab