Lower eqv? and equal? to new instructions.

* libguile/numbers.h:
* libguile/eq.c (scm_i_heap_numbers_equal_p): New helper, factored out
  of scm_eqv_p.
  (scm_eqv_p): Use new helper.
* libguile/vm-engine.c (heap-numbers-equal?): New op.
* module/language/cps/compile-bytecode.scm (compile-function): Add
  support for heap-number? and heap-numbers-equal?.  Remove case for
  eqv?.
* module/language/cps/effects-analysis.scm: Add heap-numbers-equal?.
* module/language/cps/primitives.scm (*comparisons*): Add
  heap-numbers-equal?.
* module/language/cps/type-fold.scm (heap-numbers-equal?): Update.
* module/language/cps/types.scm (heap-numbers-equal?): Update.
* module/language/tree-il/compile-cps.scm (canonicalize): Completely
  inline eqv?, and partially inline equal?.
* module/system/vm/assembler.scm (system): Export emit-heap-numbers-equal?.

module/language/cps/compile-bytecode.scm

@@ -441,11 +441,13 @@
         (($ $primcall 'bytevector? (a)) (unary emit-bytevector? a))
         (($ $primcall 'bitvector? (a)) (unary emit-bitvector? a))
         (($ $primcall 'keyword? (a)) (unary emit-keyword? a))
+        (($ $primcall 'heap-number? (a)) (unary emit-heap-number? a))
         ;; Add more TC7 tests here.  Keep in sync with
         ;; *branching-primcall-arities* in (language cps primitives) and
         ;; the set of macro-instructions in assembly.scm.
         (($ $primcall 'eq? (a b)) (binary-test emit-eq? a b))
-        (($ $primcall 'eqv? (a b)) (binary emit-br-if-eqv a b))
+        (($ $primcall 'heap-numbers-equal? (a b))
+         (binary-test emit-heap-numbers-equal? a b))
         (($ $primcall '< (a b)) (binary* emit-<? emit-jl emit-jnl a b))
         (($ $primcall '<= (a b)) (binary* emit-<? emit-jge emit-jnge b a))
         (($ $primcall '= (a b)) (binary-test emit-=? a b))

module/language/cps/effects-analysis.scm

@@ -433,6 +433,7 @@ is or might be a read or a write to the same location as A."
 
 ;; Numbers.
 (define-primitive-effects
+  ((heap-numbers-equal? . _))
   ((= . _)                         &type-check)
   ((< . _)                         &type-check)
   ((> . _)                         &type-check)

module/language/cps/primitives.scm

@@ -127,7 +127,7 @@ before it is lowered to CPS?"
 
 (define *comparisons*
   '(eq?
-    eqv?
+    heap-numbers-equal?
     <
     <=
     =

module/language/cps/type-fold.scm

@@ -125,7 +125,7 @@
     (values #t #t))
    (else
     (values #f #f))))
-(define-branch-folder-alias eqv? eq?)
+(define-branch-folder-alias heap-numbers-equal? eq?)
 
 (define (compare-ranges type0 min0 max0 type1 min1 max1)
   ;; Since &real, &u64, and &f64 are disjoint, we can compare once

module/language/cps/types.scm

@@ -632,7 +632,7 @@ minimum, and maximum."
           (max (min (&max a) (&max b))))
       (restrict! a type min max)
       (restrict! b type min max))))
-(define-type-inferrer-aliases eq? eqv?)
+(define-type-inferrer-aliases eq? heap-numbers-equal?)
 
 
 

module/language/tree-il/compile-cps.scm

@@ -509,18 +509,6 @@
 
     (($ <primcall> src name args)
      (cond
-      ((eq? name 'equal?)
-       (convert-args cps args
-         (lambda (cps args)
-           (with-cps cps
-             (let$ k* (adapt-arity k src 1))
-             (letk kt ($kargs () () ($continue k* src ($const #t))))
-             (letk kf* ($kargs () ()
-                         ;; Here we continue to the original $kreceive
-                         ;; or $ktail, as equal? doesn't have a VM op.
-                         ($continue k src ($primcall 'equal? args))))
-             (build-term ($continue kf* src
-                           ($branch kt ($primcall 'eqv? args))))))))
       ((and (eq? name 'list)
             (and-map (match-lambda
                        ((or ($ <const>)
@@ -663,6 +651,8 @@
                      (lambda (cps integer)
                        (have-args cps (list integer)))))))
                 (else (have-args cps args))))
+            (when (branching-primitive? name)
+              (error "branching primcall in bad context" name))
             (convert-args cps args
               (lambda (cps args)
                 ;; Tree-IL primcalls are sloppy, in that it could be
@@ -1001,6 +991,48 @@ integer."
                            (make-const src #f)
                            (make-const src #t))))
 
+       (($ <primcall> src (or 'eqv? 'equal?) (a b))
+        (let ()
+          (define-syntax-rule (with-lexical id . body)
+            (let ((k (lambda (id) . body)))
+              (match id
+                (($ <lexical-ref>) (k id))
+                (_
+                 (let ((v (gensym "v ")))
+                   (make-let src (list 'v) (list v) (list id)
+                             (k (make-lexical-ref src 'v v))))))))
+          (define-syntax with-lexicals
+            (syntax-rules ()
+              ((with-lexicals () . body) (let () . body))
+              ((with-lexicals (id . ids) . body)
+               (with-lexical id (with-lexicals ids . body)))))
+          (define-syntax-rule (primcall name . args)
+            (make-primcall src 'name (list . args)))
+          (define-syntax primcall-chain
+            (syntax-rules ()
+              ((_ x) x)
+              ((_ x . y)
+               (make-conditional src (primcall . x) (primcall-chain . y)
+                                 (make-const src #f)))))
+          (define-syntax-rule (bool x)
+            (make-conditional src x (make-const src #t) (make-const src #f)))
+          (with-lexicals (a b)
+            (make-conditional
+             src
+             (primcall eq? a b)
+             (make-const src #t)
+             (match (primcall-name exp)
+               ('eqv?
+                ;; Completely inline.
+                (primcall-chain (heap-number? a)
+                                (heap-number? b)
+                                (bool (primcall heap-numbers-equal? a b))))
+               ('equal?
+                ;; Partially inline.
+                (primcall-chain (heap-object? a)
+                                (heap-object? b)
+                                (primcall equal? a b))))))))
+
        (($ <primcall> src 'vector
            (and args
                 ((or ($ <const>) ($ <void>) ($ <lambda>) ($ <lexical-ref>))
@@ -1110,4 +1142,5 @@ integer."
 ;;; Local Variables:
 ;;; eval: (put 'convert-arg 'scheme-indent-function 2)
 ;;; eval: (put 'convert-args 'scheme-indent-function 2)
+;;; eval: (put 'with-lexicals 'scheme-indent-function 1)
 ;;; End: