Add instructions to branch on u64 comparisons

* libguile/vm-engine.c (BR_U64_ARITHMETIC): New helper.
  (br-if-u64-=, br-if-u64-<, br-if-u64->=): New instructions.

* module/language/cps/compile-bytecode.scm (compile-function):
* module/language/cps/effects-analysis.scm:
* module/language/cps/primitives.scm (*branching-primcall-arities*):
* module/language/cps/type-fold.scm:
* module/language/cps/types.scm (u64-=, infer-u64-comparison-ranges):
  (define-u64-comparison-inferrer, u64-<, u64-<=, u64->=, u64->):
* module/system/vm/assembler.scm:
* module/system/vm/disassembler.scm (code-annotation):
  (compute-labels): Compiler and toolchain support for the new
  instructions.

libguile/vm-engine.c

@@ -376,6 +376,25 @@
       }                                                                 \
   }
 
+#define BR_U64_ARITHMETIC(crel,srel)                                    \
+  {                                                                     \
+    scm_t_uint32 a, b;                                                  \
+    scm_t_uint64 x, y;                                                  \
+    UNPACK_24 (op, a);                                                  \
+    UNPACK_24 (ip[1], b);                                               \
+    x = SP_REF_U64 (a);                                                 \
+    y = SP_REF_U64 (b);                                                 \
+    if ((ip[2] & 0x1) ? !(x crel y) : (x crel y))                       \
+      {                                                                 \
+        scm_t_int32 offset = ip[2];                                     \
+        offset >>= 8; /* Sign-extending shift. */                       \
+        if (offset <= 0)                                                \
+          VM_HANDLE_INTERRUPTS;                                         \
+        NEXT (offset);                                                  \
+      }                                                                 \
+    NEXT (3);                                                           \
+  }
+
 #define ARGS1(a1)                               \
   scm_t_uint16 dst, src;                        \
   SCM a1;                                       \
@@ -3358,9 +3377,31 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       NEXT (1);
     }
 
-  VM_DEFINE_OP (146, unused_146, NULL, NOP)
+  /* br-if-= a:12 b:12 invert:1 _:7 offset:24
-  VM_DEFINE_OP (147, unused_147, NULL, NOP)
+   *
-  VM_DEFINE_OP (148, unused_148, NULL, NOP)
+   * If the value in A is = to the value in B, add OFFSET, a signed
+   * 24-bit number, to the current instruction pointer.
+   */
+  VM_DEFINE_OP (146, br_if_u64_ee, "br-if-u64-=", OP3 (X8_S24, X8_S24, B1_X7_L24))
+    {
+      BR_U64_ARITHMETIC (==, scm_num_eq_p);
+    }
+
+  /* br-if-< a:12 b:12 invert:1 _:7 offset:24
+   *
+   * If the value in A is < to the value in B, add OFFSET, a signed
+   * 24-bit number, to the current instruction pointer.
+   */
+  VM_DEFINE_OP (147, br_if_u64_lt, "br-if-u64-<", OP3 (X8_S24, X8_S24, B1_X7_L24))
+    {
+      BR_U64_ARITHMETIC (<, scm_less_p);
+    }
+
+  VM_DEFINE_OP (148, br_if_u64_le, "br-if-u64-<=", OP3 (X8_S24, X8_S24, B1_X7_L24))
+    {
+      BR_U64_ARITHMETIC (<=, scm_leq_p);
+    }
+
   VM_DEFINE_OP (149, unused_149, NULL, NOP)
   VM_DEFINE_OP (150, unused_150, NULL, NOP)
   VM_DEFINE_OP (151, unused_151, NULL, NOP)

module/language/cps/compile-bytecode.scm

@@ -373,6 +373,11 @@
         (($ $primcall '= (a b)) (binary emit-br-if-= a b))
         (($ $primcall '>= (a b)) (binary emit-br-if-<= b a))
         (($ $primcall '> (a b)) (binary emit-br-if-< b a))
+        (($ $primcall 'u64-< (a b)) (binary emit-br-if-u64-< a b))
+        (($ $primcall 'u64-<= (a b)) (binary emit-br-if-u64-<= a b))
+        (($ $primcall 'u64-= (a b)) (binary emit-br-if-u64-= a b))
+        (($ $primcall 'u64->= (a b)) (binary emit-br-if-u64-<= b a))
+        (($ $primcall 'u64-> (a b)) (binary emit-br-if-u64-< b a))
         (($ $primcall 'logtest (a b)) (binary emit-br-if-logtest a b))))
 
     (define (compile-trunc label k exp nreq rest-var)

module/language/cps/effects-analysis.scm

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

module/language/cps/primitives.scm

@@ -88,6 +88,11 @@
     (> . (1 . 2))
     (<= . (1 . 2))
     (>= . (1 . 2))
+    (u64-= . (1 . 2))
+    (u64-< . (1 . 2))
+    (u64-> . (1 . 2))
+    (u64-<= . (1 . 2))
+    (u64->= . (1 . 2))
     (logtest . (1 . 2))))
 
 (define (compute-prim-instructions)

module/language/cps/type-fold.scm

@@ -93,7 +93,9 @@
 (define-branch-folder-alias eqv? eq?)
 
 (define (compare-ranges type0 min0 max0 type1 min1 max1)
-  (and (zero? (logand (logior type0 type1) (lognot &real)))
+  ;; Since &real, &u64, and &f64 are disjoint, we can compare once
+  ;; against their mask instead of doing three "or" comparisons.
+  (and (zero? (logand (logior type0 type1) (lognot (logior &real &f64 &u64))))
        (cond ((< max0 min1) '<)
              ((> min0 max1) '>)
              ((= min0 max0 min1 max1) '=)
@@ -106,30 +108,35 @@
     ((<) (values #t #t))
     ((= >= >) (values #t #f))
     (else (values #f #f))))
+(define-branch-folder-alias u64-< <)
 
 (define-binary-branch-folder (<= type0 min0 max0 type1 min1 max1)
   (case (compare-ranges type0 min0 max0 type1 min1 max1)
     ((< <= =) (values #t #t))
     ((>) (values #t #f))
     (else (values #f #f))))
+(define-branch-folder-alias u64-<= <=)
 
 (define-binary-branch-folder (= type0 min0 max0 type1 min1 max1)
   (case (compare-ranges type0 min0 max0 type1 min1 max1)
     ((=) (values #t #t))
     ((< >) (values #t #f))
     (else (values #f #f))))
+(define-branch-folder-alias u64-= =)
 
 (define-binary-branch-folder (>= type0 min0 max0 type1 min1 max1)
   (case (compare-ranges type0 min0 max0 type1 min1 max1)
     ((> >= =) (values #t #t))
     ((<) (values #t #f))
     (else (values #f #f))))
+(define-branch-folder-alias u64->= >=)
 
 (define-binary-branch-folder (> type0 min0 max0 type1 min1 max1)
   (case (compare-ranges type0 min0 max0 type1 min1 max1)
     ((>) (values #t #t))
     ((= <= <) (values #t #f))
     (else (values #f #f))))
+(define-branch-folder-alias u64-> >)
 
 (define-binary-branch-folder (logtest type0 min0 max0 type1 min1 max1)
   (define (logand-min a b)

module/language/cps/types.scm

@@ -835,6 +835,43 @@ minimum, and maximum."
 (define-simple-type-checker (> &real &real))
 (define-comparison-inferrer (> <=))
 
+(define-simple-type-checker (u64-= &u64 &u64))
+(define-predicate-inferrer (u64-= a b true?)
+  (when true?
+    (let ((min (max (&min a) (&min b)))
+          (max (min (&max a) (&max b))))
+      (restrict! a &u64 min max)
+      (restrict! b &u64 min max))))
+
+(define (infer-u64-comparison-ranges op min0 max0 min1 max1)
+  (match op
+    ('< (values min0 (min max0 (1- max1)) (max (1+ min0) min1) max1))
+    ('<= (values min0 (min max0 max1) (max min0 min1) max1))
+    ('>= (values (max min0 min1) max0 min1 (min max0 max1)))
+    ('> (values (max min0 (1+ min1)) max0 min1 (min (1- max0) max1)))))
+(define-syntax-rule (define-u64-comparison-inferrer (u64-op op inverse))
+  (define-predicate-inferrer (u64-op a b true?)
+    (call-with-values
+        (lambda ()
+          (infer-u64-comparison-ranges (if true? 'op 'inverse)
+                                       (&min a) (&max a)
+                                       (&min b) (&max b)))
+      (lambda (min0 max0 min1 max1)
+        (restrict! a &u64 min0 max0)
+        (restrict! b &u64 min1 max1)))))
+
+(define-simple-type-checker (u64-< &u64 &u64))
+(define-u64-comparison-inferrer (u64-< < >=))
+
+(define-simple-type-checker (u64-<= &u64 &u64))
+(define-u64-comparison-inferrer (u64-<= <= >))
+
+(define-simple-type-checker (u64->= &u64 &u64))
+(define-u64-comparison-inferrer (u64-<= >= <))
+
+(define-simple-type-checker (u64-> &u64 &u64))
+(define-u64-comparison-inferrer (u64-> > <=))
+
 ;; Arithmetic.
 (define-syntax-rule (define-unary-result! a result min max)
   (let ((min* min)

module/system/vm/assembler.scm

@@ -95,6 +95,9 @@
             emit-br-if-<
             emit-br-if-<=
             emit-br-if-logtest
+            emit-br-if-u64-=
+            emit-br-if-u64-<
+            emit-br-if-u64-<=
             (emit-mov* . emit-mov)
             (emit-fmov* . emit-fmov)
             (emit-box* . emit-box)

module/system/vm/disassembler.scm

@@ -195,6 +195,7 @@ address of that offset."
           'br-if-true 'br-if-null 'br-if-nil 'br-if-pair 'br-if-struct
           'br-if-char 'br-if-eq 'br-if-eqv
           'br-if-= 'br-if-< 'br-if-<= 'br-if-> 'br-if->=
+          'br-if-u64-= 'br-if-u64-< 'br-if-u64-<=
           'br-if-logtest) _ ... target)
      (list "-> ~A" (vector-ref labels (- (+ offset target) start))))
     (('br-if-tc7 slot invert? tc7 target)
@@ -296,7 +297,8 @@ address of that offset."
                    br-if-nargs-ne br-if-nargs-lt br-if-nargs-gt
                    br-if-true br-if-null br-if-nil br-if-pair br-if-struct
                    br-if-char br-if-tc7 br-if-eq br-if-eqv
-                   br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest)
+                   br-if-= br-if-< br-if-<= br-if-> br-if->= br-if-logtest
+                   br-if-u64-= br-if-u64-< br-if-u64-<=)
                   (match arg
                     ((_ ... target)
                      (add-label! (+ offset target) "L"))))