diff --git a/src/code/kernel.lisp b/src/code/kernel.lisp index eaac29b9429913c388f0d8dbc8f5c9056c7a3bee..a67f7f7ac7f2244a5d2158b568978de83dd0ce0c 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 639ac8a4e528c131fdda1c1c99ad2a42b6d7f25e..a107e79372972257566762f1f461cdf9cf13a617 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 f54f0721d2765d373c8426157a1f7d1b714fe37f..27fddca2737b133ca87d01fda08f2e3433323a1e 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: