Add unboxed floating point comparison instructions.

* libguile/vm-engine.c (BR_F64_ARITHMETIC): New preprocessor macro.
(br_if_f64_ee, br_if_f64_lt, br_if_f64_le, br_if_f64_gt, br_if_f64_ge):
New VM instructions.
* doc/ref/vm.texi ("Unboxed Floating-Point Arithmetic"): Document them.
* module/language/cps/compile-bytecode.scm (compile-function): Emit f64
comparison instructions.
* module/language/cps/effects-analysis.scm: Define effects for f64
primcalls.
* module/language/cps/primitives.scm (*branching-primcall-arities*): Add
arities for f64 primcalls.
* module/language/cps/specialize-numbers.scm (specialize-f64-comparison):
New procedure.
(specialize-operations): Specialize f64 comparisons.
* module/system/vm/assembler.scm (emit-br-if-f64-=, emit-br-if-f64-<)
(emit-br-if-f64-<=, emit-br-if-f64->, emit-br-if-f64->=): Export.
* module/system/vm/disassembler.scm (code-annotation): Add annotations
for f64 comparison instructions.

module/language/cps/compile-bytecode.scm

@@ -446,7 +446,12 @@
         (($ $primcall 'u64-=-scm (a b)) (binary emit-br-if-u64-=-scm a b))
         (($ $primcall 'u64->=-scm (a b)) (binary emit-br-if-u64->=-scm a b))
         (($ $primcall 'u64->-scm (a b)) (binary emit-br-if-u64->-scm a b))
-        (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
+        (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))
+        (($ $primcall 'f64-< (a b)) (binary emit-br-if-f64-< a b))
+        (($ $primcall 'f64-<= (a b)) (binary emit-br-if-f64-<= a b))
+        (($ $primcall 'f64-= (a b)) (binary emit-br-if-f64-= a b))
+        (($ $primcall 'f64->= (a b)) (binary emit-br-if-f64->= a b))
+        (($ $primcall 'f64-> (a b)) (binary emit-br-if-f64-> a b))))
 
     (define (compile-trunc label k exp nreq rest-var)
       (define (do-call proc args emit-call)

module/language/cps/effects-analysis.scm

@@ -439,6 +439,11 @@ is or might be a read or a write to the same location as A."
   ((u64-=-scm . _)                 &type-check)
   ((u64->=-scm . _)                 &type-check)
   ((u64->-scm . _)                 &type-check)
+  ((f64-= . _))
+  ((f64-< . _))
+  ((f64-> . _))
+  ((f64-<= . _))
+  ((f64->= . _))
   ((zero? . _)                     &type-check)
   ((add . _)                       &type-check)
   ((add/immediate . _)             &type-check)

module/language/cps/primitives.scm

@@ -99,7 +99,12 @@
     (u64-=-scm . (1 . 2))
     (u64->=-scm . (1 . 2))
     (u64->-scm . (1 . 2))
-    (logtest . (1 . 2))))
+    (logtest . (1 . 2))
+    (f64-= . (1 . 2))
+    (f64-< . (1 . 2))
+    (f64-> . (1 . 2))
+    (f64-<= . (1 . 2))
+    (f64->= . (1 . 2))))
 
 (define (compute-prim-instructions)
   (let ((table (make-hash-table)))

module/language/cps/specialize-numbers.scm

@@ -144,6 +144,20 @@
         ($continue kop src
           ($primcall 'scm->u64 (a-u64)))))))
 
+(define (specialize-f64-comparison cps kf kt src op a b)
+  (let ((op (symbol-append 'f64- op)))
+    (with-cps cps
+      (letv f64-a f64-b)
+      (letk kop ($kargs ('f64-b) (f64-b)
+                  ($continue kf src
+                    ($branch kt ($primcall op (f64-a f64-b))))))
+      (letk kunbox-b ($kargs ('f64-a) (f64-a)
+                       ($continue kop src
+                         ($primcall 'scm->f64 (b)))))
+      (build-term
+        ($continue kunbox-b src
+          ($primcall 'scm->f64 (a)))))))
+
 (define (sigbits-union x y)
   (and x y (logior x y)))
 
@@ -287,6 +301,11 @@ BITS indicating the significant bits needed for a variable.  BITS may be
             (lambda (type min max)
               (and (eqv? type &exact-integer)
                    (<= 0 min max #xffffffffffffffff))))))
+    (define (f64-operand? var)
+      (call-with-values (lambda ()
+                          (lookup-pre-type types label var))
+        (lambda (type min max)
+          (and (eqv? type &flonum)))))
     (match cont
       (($ $kfun)
        (let ((types (infer-types cps label)))
@@ -391,20 +410,25 @@ BITS indicating the significant bits needed for a variable.  BITS may be
           ($ $continue k src
              ($ $branch kt ($ $primcall (and op (or '< '<= '= '>= '>)) (a b)))))
        (values
-        (if (u64-operand? a)
-            (let ((specialize (if (u64-operand? b)
-                                  specialize-u64-comparison
-                                  specialize-u64-scm-comparison)))
-              (with-cps cps
-                (let$ body (specialize k kt src op a b))
-                (setk label ($kargs names vars ,body))))
-            (if (u64-operand? b)
-                (let ((op (match op
-                            ('< '>) ('<= '>=) ('= '=) ('>= '<=) ('> '<))))
-                  (with-cps cps
-                    (let$ body (specialize-u64-scm-comparison k kt src op b a))
-                    (setk label ($kargs names vars ,body))))
-                cps))
+        (cond
+         ((or (f64-operand? a) (f64-operand? b))
+          (with-cps cps
+            (let$ body (specialize-f64-comparison k kt src op a b))
+            (setk label ($kargs names vars ,body))))
+         ((u64-operand? a)
+          (let ((specialize (if (u64-operand? b)
+                                specialize-u64-comparison
+                                specialize-u64-scm-comparison)))
+            (with-cps cps
+              (let$ body (specialize k kt src op a b))
+              (setk label ($kargs names vars ,body)))))
+         ((u64-operand? b)
+          (let ((op (match op
+                      ('< '>) ('<= '>=) ('= '=) ('>= '<=) ('> '<))))
+            (with-cps cps
+              (let$ body (specialize-u64-scm-comparison k kt src op b a))
+              (setk label ($kargs names vars ,body)))))
+         (else cps))
         types
         sigbits))
       (_ (values cps types sigbits))))

module/language/cps/type-fold.scm

@@ -110,6 +110,11 @@
     (else (values #f #f))))
 (define-branch-folder-alias u64-< <)
 (define-branch-folder-alias u64-<-scm <)
+;; We currently cannot define branch folders for floating point
+;; comparison ops like the commented one below because we can't prove
+;; there are no nans involved.
+;;
+;; (define-branch-folder-alias f64-< <)
 
 (define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
   (case (compare-ranges type0 min0 max0 type1 min1 max1)

module/system/vm/assembler.scm

@@ -106,6 +106,11 @@
             emit-br-if-u64-=-scm
             emit-br-if-u64->=-scm
             emit-br-if-u64->-scm
+            emit-br-if-f64-=
+            emit-br-if-f64-<
+            emit-br-if-f64-<=
+            emit-br-if-f64->
+            emit-br-if-f64->=
             emit-box
             emit-box-ref
             emit-box-set!

module/system/vm/disassembler.scm

@@ -198,6 +198,8 @@ address of that offset."
           'br-if-u64-= 'br-if-u64-< 'br-if-u64-<=
           'br-if-u64-<-scm 'br-if-u64-<=-scm 'br-if-u64-=-scm
           'br-if-u64->-scm 'br-if-u64->=-scm
+          'br-if-f64-= 'br-if-f64-< 'br-if-f64-<=
+          'br-if-f64-> 'br-if-f64->=
           'br-if-logtest) _ ... target)
      (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
     (('br-if-tc7 slot invert? tc7 target)