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