[cmucl-commit] [git] CMU Common Lisp branch master updated. snapshot-2014-09-30-g8f5f6ab

[Raymond Toy]

This is an automated email from the git hooks/post-receive script. It was
generated because a ref change was pushed to the repository containing
the project "CMU Common Lisp".

The branch, master has been updated
       via  8f5f6abc07afeb0822ae48b3615c83734960dda6 (commit)
      from  3ff38ffa166153b7266ecdb04a3ff59b85b4c0b4 (commit)

Those revisions listed above that are new to this repository have
not appeared on any other notification email; so we list those
revisions in full, below.

- Log -----------------------------------------------------------------
commit 8f5f6abc07afeb0822ae48b3615c83734960dda6
Author: Raymond Toy <toy.raymond at gmail.com>
Date:   Wed Oct 1 21:25:58 2014 -0700

    Micro-optimize SCALE-FLOAT to use multiplication when possible.
    
    If the exponent (second arg of SCALE-FLOAT) is such that 2^exponent
    can be represented as a float (single or double), we can implement
    SCALE-FLOAT using a multiplication by 2^exponent, since multiplication
    by 2^exponent is exact.
    
     * src/compiler/float-tran.lisp:
       * Update deftransforms for SCALE-FLOAT to do a multiply when
         possible.
     * tests/float-tran.lisp:
       * Add tests to make sure the deftransforms for SCALE-FLOAT are
         applied appropriately.

diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp
index 23aa93f..6efe701 100644
--- a/src/compiler/float-tran.lisp
+++ b/src/compiler/float-tran.lisp
@@ -488,21 +488,50 @@
   '(integer-decode-double-float x))
 
 (deftransform scale-float ((f ex) (single-float *) * :when :both)
-  (if (and (backend-featurep :x86)
-	   (not (backend-featurep :sse2))
-	   (csubtypep (continuation-type ex)
-		      (specifier-type '(signed-byte 32)))
-	   (not (byte-compiling)))
-      '(coerce (%scalbn (coerce f 'double-float) ex) 'single-float)
-      '(scale-single-float f ex)))
+  (cond ((and (backend-featurep :x86)
+	      (not (backend-featurep :sse2))
+	      (csubtypep (continuation-type ex)
+			 (specifier-type '(signed-byte 32)))
+	      (not (byte-compiling)))
+	 '(coerce (%scalbn (coerce f 'double-float) ex) 'single-float))
+	((csubtypep (continuation-type ex)
+		    (specifier-type `(integer #.(- vm:single-float-normal-exponent-min
+						   vm:single-float-bias
+						   vm:single-float-digits)
+					      #.(- vm:single-float-normal-exponent-max
+						   vm:single-float-bias
+						   1))))
+	 ;; The exponent is such that 2^ex will fit in a single-float.
+	 ;; Thus, scale-float can be done multiplying by a suitable
+	 ;; constant.
+	 `(* f (kernel:make-single-float (dpb (+ ex (1+ vm:single-float-bias))
+					      vm:single-float-exponent-byte
+					      (kernel:single-float-bits 1f0)))))
+	(t
+	 '(scale-single-float f ex))))
 
 (deftransform scale-float ((f ex) (double-float *) * :when :both)
-  (if (and (backend-featurep :x86)
-	   (not (backend-featurep :sse2))
-	   (csubtypep (continuation-type ex)
-		      (specifier-type '(signed-byte 32))))
-      '(%scalbn f ex)
-      '(scale-double-float f ex)))
+  (cond ((and (backend-featurep :x86)
+	      (not (backend-featurep :sse2))
+	      (csubtypep (continuation-type ex)
+			 (specifier-type '(signed-byte 32))))
+	 '(%scalbn f ex))
+	((csubtypep (continuation-type ex)
+		    (specifier-type `(integer #.(- vm:double-float-normal-exponent-min
+						   vm:double-float-bias
+						   vm:double-float-digits)
+					      #.(- vm:double-float-normal-exponent-max
+						   vm:double-float-bias
+						   1))))
+	 ;; The exponent is such that 2^ex will fit in a double-float.
+	 ;; Thus, scale-float can be done multiplying by a suitable
+	 ;; constant.
+	 `(* f (kernel:make-double-float (dpb (+ ex (1+ vm:double-float-bias))
+					      vm:double-float-exponent-byte
+					      (kernel::double-float-bits 1d0))
+					 0)))
+	(t
+	 '(scale-double-float f ex))))
 
 ;;; toy at rtp.ericsson.se:
 ;;;
diff --git a/tests/float-tran.lisp b/tests/float-tran.lisp
index 9b84659..8eb1990 100644
--- a/tests/float-tran.lisp
+++ b/tests/float-tran.lisp
@@ -152,3 +152,61 @@
     ;; test-fun should have transformed (log x 10) to kernel:%log10
     (assert-true (search "log10" (with-output-to-string (*standard-output*)
 				   (disassemble test-fun-good-2))))))
+
+(define-test scale-float-transform.single
+  (let ((xfrm-scale
+	  (compile nil
+		   (lambda (x n)
+		     (declare (single-float x)
+			      (type (integer -149 127) n))
+		     (scale-float x n))))
+	(scale
+	  (compile nil
+		   (lambda (x n)
+		     (declare (single-float x)
+			      (type (signed-byte 32) n))
+		     (scale-float x n)))))
+    ;; If the deftransform for scale-float was applied, (scale-float
+    ;; most-positive-single-float 2) is done as a multiplication which
+    ;; will overflow.  The operation will be '*.  If the deftransform
+    ;; was not applied, the overflow will still be signaled, but the
+    ;; operation will be 'scale-float.
+    (assert-eql '*
+		(handler-case 
+		    (funcall xfrm-scale most-positive-single-float 2)
+		  (arithmetic-error (c)
+	            (arithmetic-error-operation c))))
+    (assert-eql 'scale-float
+		(handler-case
+		    (funcall scale most-positive-single-float 2)
+		  (arithmetic-error (c)
+		    (arithmetic-error-operation c))))))
+
+(define-test scale-float-transform.double
+  (let ((xfrm-scale
+	  (compile nil
+		   (lambda (x n)
+		     (declare (double-float x)
+			      (type (integer -1074 1023) n))
+		     (scale-float x n))))
+	(scale
+	  (compile nil
+		   (lambda (x n)
+		     (declare (double-float x)
+			      (type (signed-byte 32) n))
+		     (scale-float x n)))))
+    ;; If the deftransform for scale-float was applied, (scale-float
+    ;; most-positive-double-float 2) is done as a multiplication which
+    ;; will overflow.  The operation will be '*.  If the deftransform
+    ;; was not applied, the overflow will still be signaled, but the
+    ;; operation will be 'scale-float.
+    (assert-eql '*
+		(handler-case 
+		    (funcall xfrm-scale most-positive-double-float 2)
+		  (arithmetic-error (c)
+	            (arithmetic-error-operation c))))
+    (assert-eql 'scale-float
+		(handler-case
+		    (funcall scale most-positive-double-float 2)
+		  (arithmetic-error (c)
+		    (arithmetic-error-operation c))))))

-----------------------------------------------------------------------

Summary of changes:
 src/compiler/float-tran.lisp |   55 +++++++++++++++++++++++++++++----------
 tests/float-tran.lisp        |   58 ++++++++++++++++++++++++++++++++++++++++++
 2 files changed, 100 insertions(+), 13 deletions(-)


hooks/post-receive
-- 
CMU Common Lisp