[Guile-commits] 04/04: Fix NaN handling in <= and >=

[Andy Wingo]

wingo pushed a commit to branch master
in repository guile.

commit 64acf24b4018627b2616567c74dae3f6800f3a9d
Author: Andy Wingo <address@hidden>
Date:   Sat Dec 2 21:07:48 2017 +0100

    Fix NaN handling in <= and >=
    
    * module/language/cps/compile-bytecode.scm (compile-function): Add
      support for emitting <= via < and jge / jnge.
    * module/language/cps/effects-analysis.scm: Declare effects for <= and
      f64-<=.
    * module/language/cps/primitives.scm (*comparisons*): Add <=, f64-<=.
    * module/language/cps/specialize-numbers.scm (specialize-operations):
      Specialize <= to < for integer comparisons.  Specialize to f64-<= for
      f64 ops.
    * module/language/cps/type-fold.scm (<=): Add folder.
    * module/language/cps/types.scm (infer-<=): Add inferrer.
    * module/language/tree-il/compile-cps.scm (canonicalize): Canonicalize
      <= and >= to <=, so that nans are handled correctly.
---
 module/language/cps/compile-bytecode.scm   |  4 ++++
 module/language/cps/effects-analysis.scm   |  2 ++
 module/language/cps/primitives.scm         |  2 ++
 module/language/cps/specialize-numbers.scm | 11 +++++++++++
 module/language/cps/type-fold.scm          |  8 ++++++++
 module/language/cps/types.scm              |  6 ++++++
 module/language/tree-il/compile-cps.scm    | 14 +++++++-------
 7 files changed, 40 insertions(+), 7 deletions(-)

diff --git a/module/language/cps/compile-bytecode.scm 
b/module/language/cps/compile-bytecode.scm
index f7c8fbb..0baa309 100644
--- a/module/language/cps/compile-bytecode.scm
+++ b/module/language/cps/compile-bytecode.scm
@@ -427,6 +427,8 @@
         (binary op emit-je emit-jne a b))
       (define (binary-< emit-<? a b)
         (binary emit-<? emit-jl emit-jnl a b))
+      (define (binary-<= emit-<? a b)
+        (binary emit-<? emit-jge emit-jnge b a))
       (define (binary-test/imm op a b)
         (op asm (from-sp (slot a)) b)
         (emit-branch emit-je emit-jne))
@@ -458,6 +460,7 @@
         (($ $primcall 'heap-numbers-equal? #f (a b))
          (binary-test emit-heap-numbers-equal? a b))
         (($ $primcall '< #f (a b)) (binary-< emit-<? a b))
+        (($ $primcall '<= #f (a b)) (binary-<= emit-<? a b))
         (($ $primcall '= #f (a b)) (binary-test emit-=? a b))
         (($ $primcall 'u64-< #f (a b)) (binary-< emit-u64<? a b))
         (($ $primcall 'u64-imm-< b (a)) (binary-</imm emit-u64-imm<? a b))
@@ -470,6 +473,7 @@
         (($ $primcall 's64-imm-< b (a)) (binary-</imm emit-s64-imm<? a b))
         (($ $primcall 'imm-s64-< b (a)) (binary-</imm emit-imm-s64<? a b))
         (($ $primcall 'f64-< #f (a b)) (binary-< emit-f64<? a b))
+        (($ $primcall 'f64-<= #f (a b)) (binary-<= emit-f64<? a b))
         (($ $primcall 'f64-= #f (a b)) (binary-test emit-f64=? a b))))
 
     (define (compile-trunc label k exp nreq rest-var)
diff --git a/module/language/cps/effects-analysis.scm 
b/module/language/cps/effects-analysis.scm
index 298a7be..9b86bec 100644
--- a/module/language/cps/effects-analysis.scm
+++ b/module/language/cps/effects-analysis.scm
@@ -449,6 +449,7 @@ the LABELS that are clobbered by the effects of LABEL."
 (define-primitive-effects
   ((heap-numbers-equal? . _))
   ((= . _)                         &type-check)
+  ((<= . _)                         &type-check)
   ((< . _)                         &type-check)
   ((u64-= . _))
   ((u64-imm-= . _))
@@ -462,6 +463,7 @@ the LABELS that are clobbered by the effects of LABEL."
   ((imm-s64-< . _))
   ((f64-= . _))
   ((f64-< . _))
+  ((f64-<= . _))
   ((zero? . _)                     &type-check)
   ((add . _)                       &type-check)
   ((add/immediate . _)             &type-check)
diff --git a/module/language/cps/primitives.scm 
b/module/language/cps/primitives.scm
index 7feead6..8d774cb 100644
--- a/module/language/cps/primitives.scm
+++ b/module/language/cps/primitives.scm
@@ -144,6 +144,7 @@ before it is lowered to CPS?"
     heap-numbers-equal?
 
     <
+    <=
     =
 
     u64-<
@@ -152,6 +153,7 @@ before it is lowered to CPS?"
     s64-<
 
     f64-<
+    f64-<=
     f64-=))
 
 (define *branching-primcall-arities* (make-hash-table))
diff --git a/module/language/cps/specialize-numbers.scm 
b/module/language/cps/specialize-numbers.scm
index 5b0103f..d8ec5e6 100644
--- a/module/language/cps/specialize-numbers.scm
+++ b/module/language/cps/specialize-numbers.scm
@@ -565,6 +565,17 @@ BITS indicating the significant bits needed for a 
variable.  BITS may be
 
     (define (specialize-branch cps kf kt src op param args)
       (match (cons op args)
+        (('<= a b)
+         (cond
+          ((f64-operands? a b)
+           (specialize-comparison cps kf kt src 'f64-<= a b
+                                  (unbox-f64 a) (unbox-f64 b)))
+          ((and (exact-integer-operand? a) (exact-integer-operand? b))
+           ;; If NaN is impossible, reduce (<= a b) to (not (< b a)) and
+           ;; try again.
+           (specialize-branch cps kt kf src '< param (list b a)))
+          (else
+           (with-cps cps #f))))
         (((or '< '=) a b)
          (cond
           ((f64-operands? a b)
diff --git a/module/language/cps/type-fold.scm 
b/module/language/cps/type-fold.scm
index f4e24f4..1fd933b 100644
--- a/module/language/cps/type-fold.scm
+++ b/module/language/cps/type-fold.scm
@@ -160,6 +160,14 @@
 ;;
 ;; (define-branch-folder-alias f64-< <)
 
+(define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
+  (if (type<=? (logior type0 type1) &exact-number)
+      (case (compare-exact-ranges min0 max0 min1 max1)
+        ((< <= =) (values #t #t))
+        ((>) (values #t #f))
+        (else (values #f #f)))
+      (values #f #f)))
+
 (define-unary-branch-folder* (u64-imm-= c type min max)
   (cond
    ((= c min max) (values #t #t))
diff --git a/module/language/cps/types.scm b/module/language/cps/types.scm
index dd2206b..5c213fc 100644
--- a/module/language/cps/types.scm
+++ b/module/language/cps/types.scm
@@ -1068,6 +1068,12 @@ minimum, and maximum."
           (restrict! a &exact-number (max min0 min1) max0)
           (restrict! b &exact-number min1 (min max0 max1)))))))))
 
+(define (infer-<= types succ param a b)
+  ;; Infer "(<= a b)" as "(not (< b a))", knowing that we only make
+  ;; inferences when NaN is impossible.
+  ((hashq-ref *type-inferrers* '<) types (match succ (0 1) (1 0)) param b a))
+(hashq-set! *type-inferrers* '<= infer-<=)
+
 (define-predicate-inferrer (u64-= a b true?)
   (infer-= a b true?))
 (define-predicate-inferrer (u64-< a b true?)
diff --git a/module/language/tree-il/compile-cps.scm 
b/module/language/tree-il/compile-cps.scm
index 49274c4..ed7ed47 100644
--- a/module/language/tree-il/compile-cps.scm
+++ b/module/language/tree-il/compile-cps.scm
@@ -1140,16 +1140,16 @@ integer."
                              (make-const src #f)))))
 
        (($ <primcall> src '<= (a b))
-        ;; No need to reduce as < is a branching primitive.
-        (make-conditional src (make-primcall src '< (list b a))
-                          (make-const src #f)
-                          (make-const src #t)))
+        ;; No need to reduce as <= is a branching primitive.
+        (make-conditional src (make-primcall src '<= (list a b))
+                          (make-const src #t)
+                          (make-const src #f)))
 
        (($ <primcall> src '>= (a b))
         ;; No need to reduce as < is a branching primitive.
-        (make-conditional src (make-primcall src '< (list a b))
-                          (make-const src #f)
-                          (make-const src #t)))
+        (make-conditional src (make-primcall src '<= (list b a))
+                          (make-const src #t)
+                          (make-const src #f)))
 
        (($ <primcall> src '> (a b))
         ;; No need to reduce as < is a branching primitive.