Raymond Toy pushed to branch issue-175-simplify-float-compare-vops at cmucl / cmucl

Commits:

2 changed files:

Changes:

  • src/compiler/x86/float-sse2.lisp
    ... ... @@ -964,18 +964,23 @@
    964 964 
     		(descriptor-reg
    965 965 
     		 (inst ,inst x (,ea y))))
    966 966 
     	      (cond (not-p
    967 
    -		     (inst jmp :p target)
    968 
    -		     (inst jmp :na target))
    967 
    +		     ;; Instead of x > y, we're doing x <= y and want
    968 
    +		     ;; to jmp when x <= y.  If NaN occurrs we also
    969 
    +		     ;; want to jump.  x <= y means CF = 1 or ZF = 1.
    970 
    +		     ;; When NaN occurs, ZF, PF, and CF are all set.
    971 
    +		     ;; Hence, we can just test for x <= y.
    972 
    +		     (inst jmp :be target))
    969 973 
     		    (t
    970 
    -		     (let ((not-lab (gen-label)))
    971 
    -		       (inst jmp :p not-lab)
    972 
    -		       (inst jmp :a target)
    973 
    -		       (emit-label not-lab)))))))))
    974 
    +		     ;; If there's NaN, the ZF, PF, and CF bits are
    975 
    +		     ;; set.  We only want to jmp to the target when
    976 
    +		     ;; x > y.  This happens if CF = 0.  Hence, we
    977 
    +		     ;; will not jmp to the target if NaN occurred.
    978 
    +		     (inst jmp :a target))))))))
    974 979 
       (frob > single comiss)
    975 980 
       (frob > double comisd))
    976 981
    977 982 
     (macrolet
    978 
    -    ((frob (op size inst)
    983 
    +    ((frob (op size inst mover)
    979 984 
            (let ((ea (ecase size
    980 985 
     		   (single
    981 986 
     		    'ea-for-sf-desc)
    ... ... @@ -987,22 +992,29 @@
    987 992 
     	 `(define-vop (,name ,inherit)
    988 993 
     	    (:translate ,op)
    989 994 
     	    (:info target not-p)
    995 
    +	    (:temporary (:sc ,sc-type) load-y)
    990 996 
     	    (:generator 3
    991 997 
     	      (sc-case y
    992 998 
     		(,sc-type
    993 
    -		 (inst ,inst x y))
    999 
    +		 (inst ,inst y x))
    994 1000 
     		(descriptor-reg
    995 
    -		 (inst ,inst x (,ea y))))
    1001 
    +		 (inst ,mover load-y (,ea y))
    1002 
    +		 (inst ,inst load-y x)))
    996 1003 
     	      (cond (not-p
    997 
    -		     (inst jmp :p target)
    998 
    -		     (inst jmp :nb target))
    1004 
    +		     ;; Instead of x < y, we're doing x >= y and want
    1005 
    +		     ;; to jmp when x >= y.  But x >=y is the same as
    1006 
    +		     ;; y <= x, so if we swap the args, we can apply
    1007 
    +		     ;; the same logic we use for > not-p case above.
    1008 
    +		     (inst jmp :be target))
    999 1009 
     		    (t
    1000 
    -		     (let ((not-lab (gen-label)))
    1001 
    -		       (inst jmp :p not-lab)
    1002 
    -		       (inst jmp :b target)
    1003 
    -		       (emit-label not-lab)))))))))
    1004 
    -  (frob < single comiss)
    1005 
    -  (frob < double comisd))
    1010 
    +		     ;; We want to jump when x < y.  This is the same
    1011 
    +		     ;; as jumping when y > x.  So if we reverse the
    1012 
    +		     ;; args, we can apply the same logic as we did
    1013 
    +		     ;; above for the > vop.
    1014 
    +
    1015 
    +		     (inst jmp :a target))))))))
    1016 
    +  (frob < single comiss movss)
    1017 
    +  (frob < double comisd movsd))
    1006 1018
    1007 1019
    1008 1020 
     ;;;; Conversion:

  • tests/nan.lisp
    1 
    +;;; Tests for NaN comparisons.
    2 
    +(defpackage :nan-tests
    3 
    +  (:use :cl :lisp-unit))
    4 
    +
    5 
    +(in-package :nan-tests)
    6 
    +
    7 
    +(defparameter *single-float-nan*
    8 
    +  (ext:with-float-traps-masked (:invalid :divide-by-zero)
    9 
    +    (/ 0d0 0d0)))
    10 
    +
    11 
    +(defparameter *double-float-nan*
    12 
    +  (ext:with-float-traps-masked (:invalid :divide-by-zero)
    13 
    +    (/ 0d0 0d0)))
    14 
    +
    15 
    +
    16 
    +(eval-when (:compile-toplevel :load-toplevel :execute)
    17 
    +  (macrolet
    18 
    +      ((frob (ntype op)
    19 
    +	 (let* ((name (ext:symbolicate (if (eq ntype 'single-float)
    20 
    +					   "S"
    21 
    +					   "D")
    22 
    +				       "TST-" op))
    23 
    +		(name3 (ext:symbolicate name "3")))
    24 
    +
    25 
    +	   `(progn
    26 
    +	      (defun ,name (x y)
    27 
    +		(declare (,ntype x y))
    28 
    +		(,op x y))
    29 
    +	      (defun ,name3 (x y z)
    30 
    +		(declare (,ntype x y z))
    31 
    +		(,op x y z))))))
    32 
    +    (frob single-float <)
    33 
    +    (frob single-float >)
    34 
    +    (frob double-float <)
    35 
    +    (frob double-float >)))
    36 
    +
    37 
    +(define-test nan-single.<
    38 
    +    (:tag :nan)
    39 
    +  ;; First just make sure it works with regular single-floats
    40 
    +  (assert-true (stst-< 1f0 2f0))
    41 
    +  (assert-false (stst-< 1f0 1f0))
    42 
    +  (assert-false (stst-< 1f0 0f0))
    43 
    +  ;; Now try NaN.  All comparisons should be false.
    44 
    +  (ext:with-float-traps-masked (:invalid)
    45 
    +    (assert-false (stst-< *single-float-nan* 1f0))
    46 
    +    (assert-false (stst-< 1f0 *single-float-nan*))
    47 
    +    (assert-false (stst-< *single-float-nan* *single-float-nan*))))
    48 
    +
    49 
    +(define-test nan-double.<
    50 
    +    (:tag :nan)
    51 
    +  ;; First just make sure it works with regular single-floats
    52 
    +  (assert-true (dtst-< 1d0 2d0))
    53 
    +  (assert-false (dtst-< 1d0 1d0))
    54 
    +  (assert-false (dtst-< 1d0 0d0))
    55 
    +  ;; Now try NaN.  All comparisons should be false.
    56 
    +  (ext:with-float-traps-masked (:invalid)
    57 
    +    (assert-false (dtst-< *double-float-nan* 1d0))
    58 
    +    (assert-false (dtst-< 1d0 *double-float-nan*))
    59 
    +    (assert-false (dtst-< *double-float-nan* *double-float-nan*))))
    60 
    +
    61 
    +(define-test nan-single.>
    62 
    +    (:tag :nan)
    63 
    +  ;; First just make sure it works with regular single-floats
    64 
    +  (assert-true (stst-> 2f0 1f0))
    65 
    +  (assert-false (stst-> 1f0 1f0))
    66 
    +  (assert-false (stst-> 0f0 1f0))
    67 
    +  ;; Now try NaN.  All comparisons should be false.
    68 
    +  (ext:with-float-traps-masked (:invalid)
    69 
    +    (assert-false (stst-> *single-float-nan* 1f0))
    70 
    +    (assert-false (stst-> 1f0 *single-float-nan*))
    71 
    +    (assert-false (stst-> *single-float-nan* *single-float-nan*))))
    72 
    +
    73 
    +(define-test nan-double.>
    74 
    +    (:tag :nan)
    75 
    +  ;; First just make sure it works with regular single-floats
    76 
    +  (assert-true (dtst-> 2d0 1d0))
    77 
    +  (assert-false (dtst-> 1d0 1d0))
    78 
    +  (assert-false (dtst-> 0d0 1d0))
    79 
    +  ;; Now try NaN.  All comparisons should be false.
    80 
    +  (ext:with-float-traps-masked (:invalid)
    81 
    +    (assert-false (dtst-> *double-float-nan* 1d0))
    82 
    +    (assert-false (dtst-> 1d0 *double-float-nan*))
    83 
    +    (assert-false (dtst-> *double-float-nan* *double-float-nan*))))
    84 
    +
    85 
    +(define-test nan-single.<3
    86 
    +    (:tag :nan)
    87 
    +  ;; First just make sure it works with regular single-floats
    88 
    +  (assert-true (stst-<3 1f0 2f0 3f0))
    89 
    +  (assert-false (stst-<3 1f0 2f0 2f0))
    90 
    +  (assert-false (stst-<3 1f0 1f0 2f0))
    91 
    +  (assert-false (stst-<3 1f0 0f0 2f0))
    92 
    +  ;; Now try NaN.  Currently we can only test if there's NaN in the
    93 
    +  ;; first two args.  When NaN is the last arg, we return the
    94 
    +  ;; incorrect value because of how multi-compare converts multiple
    95 
    +  ;; args into paris of comparisons.
    96 
    +  ;;
    97 
    +  ;; When that is fixed, we can add additional tests.  Nevertheless,
    98 
    +  ;; this is useful because it tests the not-p case of the vops.
    99 
    +  (ext:with-float-traps-masked (:invalid)
    100 
    +    (assert-false (stst-<3 *single-float-nan* 2f0 3f0))
    101 
    +    (assert-false (stst-<3 1f0 *single-float-nan* 3f0))
    102 
    +    (assert-false (stst-<3 *single-float-nan* *single-float-nan* 3f0))))
    103 
    +
    104 
    +(define-test nan-double.<3
    105 
    +    (:tag :nan)
    106 
    +  ;; First just make sure it works with regular double-floats
    107 
    +  (assert-true (dtst-<3 1d0 2d0 3d0))
    108 
    +  (assert-false (dtst-<3 1d0 2d0 2d0))
    109 
    +  (assert-false (dtst-<3 1d0 1d0 2d0))
    110 
    +  (assert-false (dtst-<3 1d0 0d0 2d0))
    111 
    +  ;; Now try NaN.  Currently we can only test if there's NaN in the
    112 
    +  ;; first two args.  When NaN is the last arg, we return the
    113 
    +  ;; incorrect value because of how multi-compare converts multiple
    114 
    +  ;; args into paris of comparisons.
    115 
    +  ;;
    116 
    +  ;; When that is fixed, we can add additional tests.  Nevertheless,
    117 
    +  ;; this is useful because it tests the not-p case of the vops.
    118 
    +  (ext:with-float-traps-masked (:invalid)
    119 
    +    (assert-false (dtst-<3 *double-float-nan* 2d0 3d0))
    120 
    +    (assert-false (dtst-<3 1d0 *double-float-nan* 3d0))
    121 
    +    (assert-false (dtst-<3 *double-float-nan* *double-float-nan* 3d0))))
    122 
    +
    123 
    +(define-test nan-single.>3
    124 
    +    (:tag :nan)
    125 
    +  ;; First just make sure it works with regular single-floats
    126 
    +  (assert-true (stst->3 3f0 2f0 1f0))
    127 
    +  (assert-false (stst->3 3f0 1f0 1f0))
    128 
    +  (assert-false (stst->3 2f0 2f0 1f0))
    129 
    +  (assert-false (stst->3 0f0 2f0 1f0))
    130 
    +  ;; Now try NaN.  Currently we can only test if there's NaN in the
    131 
    +  ;; first two args.  When NaN is the last arg, we return the
    132 
    +  ;; incorrect value because of how multi-compare converts multiple
    133 
    +  ;; args into paris of comparisons.
    134 
    +  ;;
    135 
    +  ;; When that is fixed, we can add additional tests.  Nevertheless,
    136 
    +  ;; this is useful because it tests the not-p case of the vops.
    137 
    +  (ext:with-float-traps-masked (:invalid)
    138 
    +    (assert-false (stst->3 *single-float-nan* 2f0 3f0))
    139 
    +    (assert-false (stst->3 1f0 *single-float-nan* 3f0))
    140 
    +    (assert-false (stst->3 *single-float-nan* *single-float-nan* 3f0))))
    141 
    +
    142 
    +(define-test nan-double.>3
    143 
    +    (:tag :nan)
    144 
    +  ;; First just make sure it works with regular double-floats
    145 
    +  (assert-true (dtst->3 3d0 2d0 1d0))
    146 
    +  (assert-false (dtst->3 3d0 1d0 1d0))
    147 
    +  (assert-false (dtst->3 2d0 2d0 1d0))
    148 
    +  (assert-false (dtst->3 0d0 2d0 1d0))
    149 
    +  ;; Now try NaN.  Currently we can only test if there's NaN in the
    150 
    +  ;; first two args.  When NaN is the last arg, we return the
    151 
    +  ;; incorrect value because of how multi-compare converts multiple
    152 
    +  ;; args into paris of comparisons.
    153 
    +  ;;
    154 
    +  ;; When that is fixed, we can add additional tests.  Nevertheless,
    155 
    +  ;; this is useful because it tests the not-p case of the vops.
    156 
    +  (ext:with-float-traps-masked (:invalid)
    157 
    +    (assert-false (dtst->3 *double-float-nan* 2d0 3d0))
    158 
    +    (assert-false (dtst->3 1d0 *double-float-nan* 3d0))
    159 
    +    (assert-false (dtst->3 *double-float-nan* *double-float-nan* 3d0))))
    160 
    +

    • —
    View it on GitLab.
    You're receiving this email because of your account on gitlab.common-lisp.net. Manage all notifications · Help