Commit 07e2d61f authored by Raymond Toy's avatar Raymond Toy
Browse files

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.
parent 622b5df4
......@@ -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)))
......
......@@ -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))
......
......@@ -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:
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment