Teach LIAR/x86-64 about ordered vs unordered comparisons.

- Fix miscompilation of ordered comparisons: now the standard
  comparison operators raise exceptions, which trap if you ask.

- Open-code the unordered comparisons flo:safe< &c.

diff --git a/src/compiler/machines/x86-64/machin.scm b/src/compiler/machines/x86-64/machin.scm
index a6c44a36b78f551ef9de94b55e73a3c81731e4e5..6bfb5760f0940d715017d8edbcc2bad1c986812b 100644 (file)
--- a/src/compiler/machines/x86-64/machin.scm
+++ b/src/compiler/machines/x86-64/machin.scm
@@ -418,7 +418,4 @@ USA.
     FLONUM-ATAN2 FLONUM-CEILING FLONUM-COS FLONUM-EXP FLONUM-EXPM1
     FLONUM-FLOOR FLONUM-LOG FLONUM-LOG1P FLONUM-ROUND FLONUM-SIN
     FLONUM-TAN FLONUM-TRUNCATE GCD-FIXNUM STRING-ALLOCATE VECTOR-CONS
-    FLONUM-IS-LESS? FLONUM-IS-LESS-OR-EQUAL?
-    FLONUM-IS-GREATER? FLONUM-IS-GREATER-OR-EQUAL?
-    FLONUM-IS-LESS-OR-GREATER? FLONUM-IS-UNORDERED?
     FLONUM-IS-NEGATIVE?))
\ No newline at end of file

diff --git a/src/compiler/machines/x86-64/rulflo.scm b/src/compiler/machines/x86-64/rulflo.scm
index ffd78f1cc00cbf73f9ac502b004ab6c8f34ffab7..0735391ee7c47425dd782343331bcf5fea4503c4 100644 (file)
--- a/src/compiler/machines/x86-64/rulflo.scm
+++ b/src/compiler/machines/x86-64/rulflo.scm
@@ -336,9 +336,48 @@ USA.
     ((FLONUM-EQUAL?) 'FLONUM-EQUAL?)
     ((FLONUM-LESS?) 'FLONUM-GREATER?)
     ((FLONUM-GREATER?) 'FLONUM-LESS?)
+    ((FLONUM-IS-LESS?) 'FLONUM-IS-GREATER?)
+    ((FLONUM-IS-LESS-OR-EQUAL?) 'FLONUM-IS-GREATER-OR-EQUAL?)
+    ((FLONUM-IS-GREATER?) 'FLONUM-IS-LESS?)
+    ((FLONUM-IS-GREATER-OR-EQUAL?) 'FLONUM-IS-GREATER-OR-EQUAL?)
+    ((FLONUM-IS-UNORDERED?) 'FLONUM-IS-UNORDERED?)
+    ((FLONUM-IS-LESS-OR-GREATER?) 'FLONUM-IS-LESS-OR-GREATER?)
     (else (error "commute-flonum-predicate: Unknown predicate" predicate))))
-
+\f
 (define (flonum-branch! predicate source1 source2)
+  ;; (U)COMI sets
+  ;; - if unordered:    zf=1 pf=1 cf=1
+  ;; - if greater:      zf=0 pf=0 cf=0
+  ;; - if less:         zf=0 pf=0 cf=1
+  ;; - if equal:        zf=1 pf=0 cf=0
+  ;;
+  ;; (`Unordered' means NaN.)
+  ;;
+  ;; Thus:
+  ;; - JP (pf=1) is jump if NaN
+  ;; - JNP (pf=0) is jump if number
+  ;; - JE=JZ (zf=1) is jump if equal or NaN = not (less or greater)
+  ;; - JNE=JNZ (zf=0) is jump if not (equal or NaN) = less or greater
+  ;; - JA=JNBE (cf=0 & zf=0) is jump if greater = not (less or equal or NaN)
+  ;; - JAE=JNB (cf=0) is jump if greater or equal = not (less or NaN)
+  ;; - JB=JNAE (cf=1) is jump if less or NaN = not (greater or equal)
+  ;; - JBE=JNA (cf=1 | zf=1) is jump if not greater = less or equal or NaN
+  ;;
+  ;; None of the other (distinct) jump condition codes involve only zf,
+  ;; pf, and cf.  (JC=JB=JNAE and JNC=JAE=JNB too.)
+  ;;
+  ;; Apparently x86 doesn't like <, <=, or = -- they require two
+  ;; conditional jumps while all the rest take only one.  Go figure.
+  ;;
+  ;; XXX Needs more automatic tests.
+  ;;
+  ;; XXX Support signalling FLONUM-LESS-OR-EQUAL?,
+  ;; FLONUM-GREATER-OR-EQUAL?, and FLONUM-LESS-OR-GREATER?.
+  ;;
+  (define (signalling-comparison)
+    (LAP (COMIF S D ,source1 ,source2)))
+  (define (quiet-comparison)
+    (LAP (UCOMIF S D ,source1 ,source2)))
   (case predicate
     ((FLONUM-EQUAL?)
      (set-current-branches! (lambda (label)
@@ -348,8 +387,9 @@ USA.
                                      (LABEL ,unordered))))
                             (lambda (label)
                               (LAP (JNE (@PCR ,label))
-                                   (JP (@PCR ,label))))))
-    ((FLONUM-LESS?)
+                                   (JP (@PCR ,label)))))
+     (signalling-comparison))
+    ((FLONUM-LESS? FLONUM-IS-LESS?)
      (set-current-branches! (lambda (label)
                               (let ((unordered (generate-label 'UNORDERED)))
                                 (LAP (JP (@PCR ,unordered))
@@ -357,15 +397,50 @@ USA.
                                      (LABEL ,unordered))))
                             (lambda (label)
                               (LAP (JAE (@PCR ,label))
-                                   (JP (@PCR ,label))))))
-    ((FLONUM-GREATER?)
+                                   (JP (@PCR ,label)))))
+     (case predicate
+       ((FLONUM-LESS?) (signalling-comparison))
+       ((FLONUM-IS-LESS?) (quiet-comparison))
+       (else (assert #f))))
+    ((FLONUM-GREATER? FLONUM-IS-GREATER?)
      (set-current-branches! (lambda (label)
                               (LAP (JA (@PCR ,label))))
                             (lambda (label)
-                              (LAP (JBE (@PCR ,label))))))
+                              (LAP (JBE (@PCR ,label)))))
+     (case predicate
+       ((FLONUM-GREATER?) (signalling-comparison))
+       ((FLONUM-IS-GREATER?) (quiet-comparison))
+       (else (assert #f))))
+    ((FLONUM-IS-LESS-OR-EQUAL?)
+     (set-current-branches! (lambda (label)
+                              (let ((unordered (generate-label 'UNORDERED)))
+                                (LAP (JP (@PCR ,unordered))
+                                     (JBE (@PCR ,label))
+                                     (LABEL ,unordered))))
+                            (lambda (label)
+                              (LAP (JA (@PCR ,label))
+                                   (JP (@PCR ,label)))))
+     (quiet-comparison))
+    ((FLONUM-IS-GREATER-OR-EQUAL?)
+     (set-current-branches! (lambda (label)
+                              (LAP (JAE (@PCR ,label))))
+                            (lambda (label)
+                              (LAP (JB (@PCR ,label)))))
+     (quiet-comparison))
+    ((FLONUM-IS-LESS-OR-GREATER?)
+     (set-current-branches! (lambda (label)
+                              (LAP (JNE (@PCR ,label))))
+                            (lambda (label)
+                              (LAP (JE (@PCR ,label)))))
+     (quiet-comparison))
+    ((FLONUM-IS-UNORDERED?)
+     (set-current-branches! (lambda (label)
+                              (LAP (JP (@PCR ,label))))
+                            (lambda (label)
+                              (LAP (JNP (@PCR ,label)))))
+     (quiet-comparison))
     (else
-     (error "flonum-branch!: Unknown predicate" predicate)))
-  (LAP (UCOMIF S D ,source1 ,source2)))
+     (error "flonum-branch!: Unknown predicate" predicate))))
 \f
 (define-rule statement
   (ASSIGN (REGISTER (? target)) (OBJECT->FLOAT (CONSTANT (? fp-value))))

diff --git a/tests/microcode/test-flonum-except.scm b/tests/microcode/test-flonum-except.scm
index 80c2cf312dda22c000b2a63c013481a1d1f8a056..07c2d7f015e932b14718bd09e2f6278b6d883f5f 100644 (file)
--- a/tests/microcode/test-flonum-except.scm
+++ b/tests/microcode/test-flonum-except.scm
@@ -275,22 +275,26 @@ USA.
 
 ;; XXX sinh, cosh, tanh, asinh, acosh, atanh
 
-(define-invop-compare-test 'flo:= (applicator flo:= 0. +nan.0) expect-failure)
-(define-invop-compare-test 'flo:= (applicator flo:= +nan.0 0.) expect-failure)
-(define-invop-compare-test 'flo:= (applicator flo:= +nan.0 +nan.0) expect-failure)
-
-(define-invop-compare-test 'flo:< (applicator flo:< 0. +nan.0) expect-failure)
-(define-invop-compare-test 'flo:< (applicator flo:< +nan.0 0.) expect-failure)
-(define-invop-compare-test 'flo:< (applicator flo:< +nan.0 +nan.0) expect-failure)
-
-(define-invop-compare-test 'flo:> (applicator flo:> 0. +nan.0) expect-failure)
-(define-invop-compare-test 'flo:> (applicator flo:> +nan.0 0.) expect-failure)
-(define-invop-compare-test 'flo:> (applicator flo:> +nan.0 +nan.0) expect-failure)
-
-(define-invop-compare-test 'flo:<= (applicator flo:<= 0. +nan.0) expect-failure)
-(define-invop-compare-test 'flo:<= (applicator flo:<= +nan.0 0.) expect-failure)
-(define-invop-compare-test 'flo:<= (applicator flo:<= +nan.0 +nan.0) expect-failure)
-
-(define-invop-compare-test 'flo:>= (applicator flo:>= 0. +nan.0) expect-failure)
-(define-invop-compare-test 'flo:>= (applicator flo:>= +nan.0 0.) expect-failure)
-(define-invop-compare-test 'flo:>= (applicator flo:>= +nan.0 +nan.0) expect-failure)
+(let ((expect-failure
+       (if (eq? microcode-id/compiled-code-type 'x86-64)
+           #!default
+           expect-failure)))
+  (define-invop-compare-test 'flo:= (applicator flo:= 0. +nan.0) expect-failure)
+  (define-invop-compare-test 'flo:= (applicator flo:= +nan.0 0.) expect-failure)
+  (define-invop-compare-test 'flo:= (applicator flo:= +nan.0 +nan.0) expect-failure)
+
+  (define-invop-compare-test 'flo:< (applicator flo:< 0. +nan.0) expect-failure)
+  (define-invop-compare-test 'flo:< (applicator flo:< +nan.0 0.) expect-failure)
+  (define-invop-compare-test 'flo:< (applicator flo:< +nan.0 +nan.0) expect-failure)
+
+  (define-invop-compare-test 'flo:> (applicator flo:> 0. +nan.0) expect-failure)
+  (define-invop-compare-test 'flo:> (applicator flo:> +nan.0 0.) expect-failure)
+  (define-invop-compare-test 'flo:> (applicator flo:> +nan.0 +nan.0) expect-failure)
+
+  (define-invop-compare-test 'flo:<= (applicator flo:<= 0. +nan.0) expect-failure)
+  (define-invop-compare-test 'flo:<= (applicator flo:<= +nan.0 0.) expect-failure)
+  (define-invop-compare-test 'flo:<= (applicator flo:<= +nan.0 +nan.0) expect-failure)
+
+  (define-invop-compare-test 'flo:>= (applicator flo:>= 0. +nan.0) expect-failure)
+  (define-invop-compare-test 'flo:>= (applicator flo:>= +nan.0 0.) expect-failure)
+  (define-invop-compare-test 'flo:>= (applicator flo:>= +nan.0 +nan.0) expect-failure))