[cmucl-commit] [git] CMU Common Lisp branch master updated. 20e-4-g07e2d61
Raymond Toy
rtoy at common-lisp.net
Tue Oct 22 01:10:23 UTC 2013
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 07e2d61f67dbd0e099c256052ba70358125cc008 (commit)
from 622b5df431a87ae3c8a816b7c569f5c5ef85a6d7 (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 07e2d61f67dbd0e099c256052ba70358125cc008
Author: Raymond Toy <toy.raymond at gmail.com>
Date: Mon Oct 21 18:10:13 2013 -0700
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.
diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp
index eaac29b..a67f7f7 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 639ac8a..a107e79 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 f54f072..27fddca 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:
-----------------------------------------------------------------------
Summary of changes:
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(-)
hooks/post-receive
--
CMU Common Lisp
More information about the cmucl-commit
mailing list