[Git][cmucl/cmucl][master] 2 commits: Fix #175: Simplify branching in x86 float compare vops
Raymond Toy (@rtoy)
gitlab at common-lisp.net
Sun Mar 12 19:05:51 UTC 2023
Raymond Toy pushed to branch master at cmucl / cmucl
Commits:
d51eb4b8 by Raymond Toy at 2023-03-12T19:05:39+00:00
Fix #175: Simplify branching in x86 float compare vops
- - - - -
a7237e1d by Raymond Toy at 2023-03-12T19:05:39+00:00
Merge branch 'issue-175-simplify-float-compare-vops' into 'master'
Fix #175: Simplify branching in x86 float compare vops
Closes #175
See merge request cmucl/cmucl!129
- - - - -
2 changed files:
- src/compiler/x86/float-sse2.lisp
- + tests/nan.lisp
Changes:
=====================================
src/compiler/x86/float-sse2.lisp
=====================================
@@ -945,7 +945,7 @@
(frob double ucomisd))
(macrolet
- ((frob (op size inst yep nope)
+ ((frob (op size inst)
(let ((ea (ecase size
(single
'ea-for-sf-desc)
@@ -953,28 +953,52 @@
'ea-for-df-desc)))
(name (symbolicate op "/" size "-FLOAT"))
(sc-type (symbolicate size "-REG"))
- (inherit (symbolicate size "-FLOAT-COMPARE")))
+ (inherit (symbolicate size "-FLOAT-COMPARE"))
+ (reverse-args-p (eq op '<)))
`(define-vop (,name ,inherit)
+ ;; The compare instructions take a reg argument for the
+ ;; first arg and reg or mem argument for the second. When
+ ;; inverting the arguments we must also invert which of
+ ;; the argument can be a mem argument.
+ (:args (x :scs (,sc-type ,@(when reverse-args-p 'descriptor-reg)))
+ (y :scs (,sc-type ,@(unless reverse-args-p 'descriptor-reg))))
(:translate ,op)
(:info target not-p)
(:generator 3
- (sc-case y
- (,sc-type
- (inst ,inst x y))
- (descriptor-reg
- (inst ,inst x (,ea y))))
- (cond (not-p
- (inst jmp :p target)
- (inst jmp ,nope target))
- (t
- (let ((not-lab (gen-label)))
- (inst jmp :p not-lab)
- (inst jmp ,yep target)
- (emit-label not-lab)))))))))
- (frob < single comiss :b :nb)
- (frob > single comiss :a :na)
- (frob < double comisd :b :nb)
- (frob > double comisd :a :na))
+ ;; Note: x < y is the same as y > x. We reverse the
+ ;; args to reduce the number of jump instructions
+ ;; needed.
+ ,(if reverse-args-p
+ `(sc-case x
+ (,sc-type
+ (inst ,inst y x))
+ (descriptor-reg
+ (inst ,inst y (,ea x))))
+ `(sc-case y
+ (,sc-type
+ (inst ,inst x y))
+ (descriptor-reg
+ (inst ,inst x (,ea y)))))
+ ;; Consider the case of x > y.
+ ;;
+ ;; When a NaN occurs, comis sets ZF, PF, and CF = 1. In
+ ;; the normal case (not-p false), we want to jump to the
+ ;; target when x > y. This happens when CF = 0. Hence,
+ ;; we won't jump to the target when there's a NaN, as
+ ;; desired.
+ ;;
+ ;; For the not-p case, we want to jump to target when x
+ ;; <= y. This means CF = 1 or ZF = 1. But NaN sets
+ ;; these bits too, so we jump to the target for NaN or x
+ ;; <= y, as desired.
+ ;;
+ ;; For the case of x < y, we can use the equivalent y >
+ ;; x. Thus if we swap the args, the same logic applies.
+ (inst jmp (if (not not-p) :a :be) target))))))
+ (frob > single comiss)
+ (frob > double comisd)
+ (frob < single comiss)
+ (frob < double comisd))
;;;; Conversion:
=====================================
tests/nan.lisp
=====================================
@@ -0,0 +1,209 @@
+;;; Tests for NaN comparisons.
+(defpackage :nan-tests
+ (:use :cl :lisp-unit))
+
+(in-package :nan-tests)
+
+(defparameter *single-float-nan*
+ (ext:with-float-traps-masked (:invalid :divide-by-zero)
+ (/ 0d0 0d0)))
+
+(defparameter *double-float-nan*
+ (ext:with-float-traps-masked (:invalid :divide-by-zero)
+ (/ 0d0 0d0)))
+
+
+(eval-when (:compile-toplevel :load-toplevel :execute)
+ (macrolet
+ ((frob (ntype op)
+ (let* ((name (ext:symbolicate (if (eq ntype 'single-float)
+ "S"
+ "D")
+ "TST-" op))
+ (name3 (ext:symbolicate name "3")))
+
+ `(progn
+ (defun ,name (x y)
+ (declare (,ntype x y))
+ (,op x y))
+ (defun ,name3 (x y z)
+ (declare (,ntype x y z))
+ (,op x y z))))))
+ (frob single-float <)
+ (frob single-float >)
+ (frob double-float <)
+ (frob double-float >)
+ (frob single-float =)
+ (frob double-float =)))
+
+(define-test nan-single.<
+ (:tag :nan)
+ ;; First just make sure it works with regular single-floats
+ (assert-true (stst-< 1f0 2f0))
+ (assert-false (stst-< 1f0 1f0))
+ (assert-false (stst-< 1f0 0f0))
+ ;; Now try NaN. All comparisons should be false.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (stst-< *single-float-nan* 1f0))
+ (assert-false (stst-< 1f0 *single-float-nan*))
+ (assert-false (stst-< *single-float-nan* *single-float-nan*))))
+
+(define-test nan-double.<
+ (:tag :nan)
+ ;; First just make sure it works with regular single-floats
+ (assert-true (dtst-< 1d0 2d0))
+ (assert-false (dtst-< 1d0 1d0))
+ (assert-false (dtst-< 1d0 0d0))
+ ;; Now try NaN. All comparisons should be false.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (dtst-< *double-float-nan* 1d0))
+ (assert-false (dtst-< 1d0 *double-float-nan*))
+ (assert-false (dtst-< *double-float-nan* *double-float-nan*))))
+
+(define-test nan-single.>
+ (:tag :nan)
+ ;; First just make sure it works with regular single-floats
+ (assert-true (stst-> 2f0 1f0))
+ (assert-false (stst-> 1f0 1f0))
+ (assert-false (stst-> 0f0 1f0))
+ ;; Now try NaN. All comparisons should be false.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (stst-> *single-float-nan* 1f0))
+ (assert-false (stst-> 1f0 *single-float-nan*))
+ (assert-false (stst-> *single-float-nan* *single-float-nan*))))
+
+(define-test nan-double.>
+ (:tag :nan)
+ ;; First just make sure it works with regular single-floats
+ (assert-true (dtst-> 2d0 1d0))
+ (assert-false (dtst-> 1d0 1d0))
+ (assert-false (dtst-> 0d0 1d0))
+ ;; Now try NaN. All comparisons should be false.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (dtst-> *double-float-nan* 1d0))
+ (assert-false (dtst-> 1d0 *double-float-nan*))
+ (assert-false (dtst-> *double-float-nan* *double-float-nan*))))
+
+(define-test nan-single.<3
+ (:tag :nan)
+ ;; First just make sure it works with regular single-floats
+ (assert-true (stst-<3 1f0 2f0 3f0))
+ (assert-false (stst-<3 1f0 2f0 2f0))
+ (assert-false (stst-<3 1f0 1f0 2f0))
+ (assert-false (stst-<3 1f0 0f0 2f0))
+ ;; Now try NaN. Currently we can only test if there's NaN in the
+ ;; first two args. When NaN is the last arg, we return the
+ ;; incorrect value because of how multi-compare converts multiple
+ ;; args into paris of comparisons.
+ ;;
+ ;; When that is fixed, we can add additional tests. Nevertheless,
+ ;; this is useful because it tests the not-p case of the vops.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (stst-<3 *single-float-nan* 2f0 3f0))
+ (assert-false (stst-<3 1f0 *single-float-nan* 3f0))
+ (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0))))
+
+(define-test nan-double.<3
+ (:tag :nan)
+ ;; First just make sure it works with regular double-floats
+ (assert-true (dtst-<3 1d0 2d0 3d0))
+ (assert-false (dtst-<3 1d0 2d0 2d0))
+ (assert-false (dtst-<3 1d0 1d0 2d0))
+ (assert-false (dtst-<3 1d0 0d0 2d0))
+ ;; Now try NaN. Currently we can only test if there's NaN in the
+ ;; first two args. When NaN is the last arg, we return the
+ ;; incorrect value because of how multi-compare converts multiple
+ ;; args into paris of comparisons.
+ ;;
+ ;; When that is fixed, we can add additional tests. Nevertheless,
+ ;; this is useful because it tests the not-p case of the vops.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (dtst-<3 *double-float-nan* 2d0 3d0))
+ (assert-false (dtst-<3 1d0 *double-float-nan* 3d0))
+ (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0))))
+
+(define-test nan-single.>3
+ (:tag :nan)
+ ;; First just make sure it works with regular single-floats
+ (assert-true (stst->3 3f0 2f0 1f0))
+ (assert-false (stst->3 3f0 1f0 1f0))
+ (assert-false (stst->3 2f0 2f0 1f0))
+ (assert-false (stst->3 0f0 2f0 1f0))
+ ;; Now try NaN. Currently we can only test if there's NaN in the
+ ;; first two args. When NaN is the last arg, we return the
+ ;; incorrect value because of how multi-compare converts multiple
+ ;; args into paris of comparisons.
+ ;;
+ ;; When that is fixed, we can add additional tests. Nevertheless,
+ ;; this is useful because it tests the not-p case of the vops.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (stst->3 *single-float-nan* 2f0 3f0))
+ (assert-false (stst->3 1f0 *single-float-nan* 3f0))
+ (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0))))
+
+(define-test nan-double.>3
+ (:tag :nan)
+ ;; First just make sure it works with regular double-floats
+ (assert-true (dtst->3 3d0 2d0 1d0))
+ (assert-false (dtst->3 3d0 1d0 1d0))
+ (assert-false (dtst->3 2d0 2d0 1d0))
+ (assert-false (dtst->3 0d0 2d0 1d0))
+ ;; Now try NaN. Currently we can only test if there's NaN in the
+ ;; first two args. When NaN is the last arg, we return the
+ ;; incorrect value because of how multi-compare converts multiple
+ ;; args into paris of comparisons.
+ ;;
+ ;; When that is fixed, we can add additional tests. Nevertheless,
+ ;; this is useful because it tests the not-p case of the vops.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (dtst->3 *double-float-nan* 2d0 3d0))
+ (assert-false (dtst->3 1d0 *double-float-nan* 3d0))
+ (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0))))
+
+(define-test nan-single.=
+ (:tag :nan)
+ ;; Basic tests with regular numbers.
+ (assert-true (stst-= 1f0 1f0))
+ (assert-false (stst-= 2f0 1f0))
+ (assert-false (stst-= 0f0 1f0))
+ ;; Tests with NaN, where = should fail.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (stst-= *single-float-nan* 1f0))
+ (assert-false (stst-= 1f0 *single-float-nan*))
+ (assert-false (stst-= *single-float-nan* *single-float-nan*))))
+
+(define-test nan-double.=
+ (:tag :nan)
+ ;; Basic tests with regular numbers.
+ (assert-true (stst-= 1d0 1d0))
+ (assert-false (stst-= 2d0 1d0))
+ (assert-false (stst-= 0d0 1d0))
+ ;; Tests with NaN, where = should fail.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (stst-= *double-float-nan* 1d0))
+ (assert-false (stst-= 1d0 *double-float-nan*))
+ (assert-false (stst-= *double-float-nan* *double-float-nan*))))
+
+(define-test nan-single.=3
+ (:tag :nan)
+ ;; Basic tests with regular numbers.
+ (assert-true (stst-=3 1f0 1f0 1f0))
+ (assert-false (stst-=3 1f0 1f0 0f0))
+ (assert-false (stst-=3 0f0 1f0 1f0))
+ ;; Tests with NaN, where = should fail.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (stst-=3 *single-float-nan* 1f0 1f0))
+ (assert-false (stst-=3 1f0 *single-float-nan* 1f0))
+ (assert-false (stst-=3 1f0 1f0 *single-float-nan*))))
+
+(define-test nan-double.=3
+ (:tag :nan)
+ ;; Basic tests with regular numbers.
+ (assert-true (dtst-=3 1d0 1d0 1d0))
+ (assert-false (dtst-=3 1d0 1d0 0d0))
+ (assert-false (dtst-=3 0d0 1d0 1d0))
+ ;; Tests with NaN, where = should fail.
+ (ext:with-float-traps-masked (:invalid)
+ (assert-false (dtst-=3 *double-float-nan* 1d0 1d0))
+ (assert-false (dtst-=3 1d0 *double-float-nan* 1d0))
+ (assert-false (dtst-=3 1d0 1d0 *double-float-nan*))))
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/0038d3d9a489ffcf47bb155252627102d65f2927...a7237e1d632c5d13ed5266563a9e6c1b35c6a351
--
View it on GitLab: https://gitlab.common-lisp.net/cmucl/cmucl/-/compare/0038d3d9a489ffcf47bb155252627102d65f2927...a7237e1d632c5d13ed5266563a9e6c1b35c6a351
You're receiving this email because of your account on gitlab.common-lisp.net.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <https://mailman.common-lisp.net/pipermail/cmucl-cvs/attachments/20230312/a4c96332/attachment-0001.html>
More information about the cmucl-cvs
mailing list