CMUCL commit: src (code/float.lisp compiler/float-tran.lisp)

[Raymond Toy]

    Date: Friday, February 5, 2010 @ 13:10:59
  Author: rtoy
    Path: /project/cmucl/cvsroot/src

Modified: code/float.lisp compiler/float-tran.lisp

Implement a fast fround for single and double floats.  This is enabled
everywhere except for x87 builds since there is a possible roundoff
issue due to the 80-bit registers for x87.

This is some 2-3 times faster than the existing fround function.

code/float.lisp:
o Implementations of %unary-fround/single-float,
  %unary-fround/double-float, and %unary-fround.  Declare the first
  two as inline too.

compiler/float-tran.lisp:
o Tell compiler about %unary-fround.
o Transform fround to a call to %unary-fround.
o Transform %unary-fround to special versions for single and double
  float arguments.


--------------------------+
 code/float.lisp          |   54 +++++++++++++++++++++++++++++++++++++++++++--
 compiler/float-tran.lisp |   28 ++++++++++++++++++++++-
 2 files changed, 79 insertions(+), 3 deletions(-)


Index: src/code/float.lisp
diff -u src/code/float.lisp:1.43 src/code/float.lisp:1.44
--- src/code/float.lisp:1.43	Mon Dec 22 18:24:28 2008
+++ src/code/float.lisp	Fri Feb  5 13:10:58 2010
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/code/float.lisp,v 1.43 2008-12-22 23:24:28 rtoy Rel $")
+  "$Header: /project/cmucl/cvsroot/src/code/float.lisp,v 1.44 2010-02-05 18:10:58 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -20,6 +20,9 @@
 (export '(%unary-truncate %unary-round %unary-ftruncate
 	  %unary-ftruncate/single-float %unary-ftruncate/double-float))
 
+#-x87
+(export '(%unary-fround/single-float %unary-fround/double-float))
+
 (in-package "LISP")
 (export '(least-positive-normalized-short-float
 	  least-positive-normalized-single-float
@@ -1412,9 +1415,56 @@
     #+double-double
     ((double-double-float)
      (%unary-ftruncate/double-double-float number))))
-	     
 
 
+;; %UNARY-FROUND not implemented for x87.  I think there are potential
+;; roundoff problems due to the 80-bit FPU registers.
+#-x87
+(progn
+(declaim (inline %unary-fround/single-float %unary-fround/double-float))
+
+;; %UNARY-FROUND/DOUBLE-FLOAT
+;;
+;; Basically the same as fround, but specialized to handle only
+;; double-floats and to return the first value.  This is the algorithm
+;; given by Anton Ertl in comp.arch.arithmetic, Oct 26, 2002.
+(defun %unary-fround/double-float (x)
+  (declare (double-float x))
+  (let ((const (scale-float 1d0 53)))
+    (if (>= x 0)
+	(+ (- x const) const)
+	(- (+ x const) const))))
+
+
+;; %UNARY-FROUND/SINLGE-FLOAT
+;;
+;; Same as %UNARY-FROUND/DOUBLE-FLOAT, except specialized for single-float.
+(defun %unary-fround/single-float (x)
+  (declare (single-float x))
+  (let ((const (scale-float 1f0 24)))
+    (if (>= x 0)
+	(+ (- x const) const)
+	(- (+ x const) const))))
+
+;;; %UNARY-FROUND  --  Interface
+;;;
+;;; This function is called when we are doing an fround without any
+;;; funky divisor.  Note that we do *not* return the second value of
+;;; round, so it must be computed by the caller if needed.
+;;;
+(defun %unary-fround (number)
+  (number-dispatch ((number real))
+    ((integer)
+     (float number))
+    ((ratio)
+     (float (round (numerator number) (denominator number))))
+    ((single-float)
+     (%unary-fround/single-float number))
+    ((double-float)
+     (%unary-fround/double-float number))))
+
+) ; not x87
+
 (defun rational (x)
   "RATIONAL produces a rational number for any real numeric argument.  This is
   more efficient than RATIONALIZE, but it assumes that floating-point is
Index: src/compiler/float-tran.lisp
diff -u src/compiler/float-tran.lisp:1.135 src/compiler/float-tran.lisp:1.136
--- src/compiler/float-tran.lisp:1.135	Mon Nov  2 10:05:06 2009
+++ src/compiler/float-tran.lisp	Fri Feb  5 13:10:59 2010
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /project/cmucl/cvsroot/src/compiler/float-tran.lisp,v 1.135 2009-11-02 15:05:06 rtoy Exp $")
+  "$Header: /project/cmucl/cvsroot/src/compiler/float-tran.lisp,v 1.136 2010-02-05 18:10:59 rtoy Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -235,6 +235,32 @@
   (frob single-float %unary-ftruncate/single-float)
   (frob double-float %unary-ftruncate/double-float))
 
+;;; FROUND
+#-x87
+(progn
+(deftransform fround ((x &optional (y 1))
+		      ((or single-float double-float)
+		       &optional (or single-float double-float integer)))
+  '(let ((res (%unary-fround (/ x y))))
+    (values res (- x (* y res)))))
+
+(defknown %unary-fround (real) float
+  (movable foldable flushable))
+
+(defknown %unary-fround/single-float (single-float) single-float
+  (movable foldable flushable))
+
+(defknown %unary-fround/double-float (double-float) double-float
+  (movable foldable flushable))
+
+(deftransform %unary-fround ((x) (single-float))
+  '(%unary-fround/single-float x))
+
+(deftransform %unary-fround ((x) (double-float))
+  '(%unary-fround/double-float x))
+
+); not x87
+
 ;;; Random:
 ;;;
 (macrolet ((frob (fun type)