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?.

libguile/eq.c

@@ -1,4 +1,4 @@
-/* Copyright (C) 1995,1996,1997,1998,2000,2001,2003, 2004, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
+/* Copyright (C) 1995-1998,2000-2001,2003-2004,2006,2009-2011,2017 Free Software Foundation, Inc.
  * 
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -156,6 +156,25 @@ scm_i_fraction_equalp (SCM x, SCM y)
 				  SCM_FRACTION_DENOMINATOR (y))));
 }
 
+SCM
+scm_i_heap_numbers_equal_p (SCM x, SCM y)
+{
+  if (SCM_IMP (x)) abort();
+  switch (SCM_TYP16 (x))
+    {
+    case scm_tc16_big:
+      return scm_bigequal (x, y);
+    case scm_tc16_real:
+      return scm_real_equalp (x, y);
+    case scm_tc16_complex:
+      return scm_complex_equalp (x, y);
+    case scm_tc16_fraction:
+      return scm_i_fraction_equalp (x, y);
+    default:
+      abort ();
+    }
+}
+
 static SCM scm_i_eqv_p (SCM x, SCM y, SCM rest);
 #include <stdio.h>
 SCM_DEFINE (scm_i_eqv_p, "eqv?", 0, 2, 1,
@@ -210,17 +229,7 @@ SCM scm_eqv_p (SCM x, SCM y)
     default:
       break;
     case scm_tc7_number:
-      switch SCM_TYP16 (x)
+      return scm_i_heap_numbers_equal_p (x, y);
-        {
-        case scm_tc16_big:
-          return scm_bigequal (x, y);
-        case scm_tc16_real:
-          return scm_real_equalp (x, y);
-        case scm_tc16_complex:
-          return scm_complex_equalp (x, y);
-	case scm_tc16_fraction:
-          return scm_i_fraction_equalp (x, y);
-        }
     }
   return SCM_BOOL_F;
 }

libguile/numbers.h

@@ -4,7 +4,7 @@
 #define SCM_NUMBERS_H
 
 /* Copyright (C) 1995, 1996, 1998, 2000-2006, 2008-2011, 2013, 2014,
- *   2016 Free Software Foundation, Inc.
+ *   2016, 2017 Free Software Foundation, Inc.
  *
  * This library is free software; you can redistribute it and/or
  * modify it under the terms of the GNU Lesser General Public License
@@ -260,6 +260,7 @@ SCM_API SCM scm_string_to_number (SCM str, SCM radix);
 SCM_API SCM scm_bigequal (SCM x, SCM y);
 SCM_API SCM scm_real_equalp (SCM x, SCM y);
 SCM_API SCM scm_complex_equalp (SCM x, SCM y);
+SCM_INTERNAL SCM scm_i_heap_numbers_equal_p (SCM x, SCM y);
 SCM_API SCM scm_number_p (SCM x);
 SCM_API SCM scm_complex_p (SCM x);
 SCM_API SCM scm_real_p (SCM x);

libguile/vm-engine.c

@@ -4395,7 +4395,24 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
         NEXT (1);
     }
 
-  VM_DEFINE_OP (213, unused_213, NULL, NOP)
+  VM_DEFINE_OP (213, heap_numbers_equal, "heap-numbers-equal?", OP1 (X8_S12_S12))
+    {
+      scm_t_uint16 a, b;
+      SCM x, y;
+
+      UNPACK_12_12 (op, a, b);
+      x = SP_REF (a);
+      y = SP_REF (b);
+
+      SYNC_IP ();
+      if (scm_is_true (scm_i_heap_numbers_equal_p (x, y)))
+        vp->compare_result = SCM_F_COMPARE_EQUAL;
+      else
+        vp->compare_result = SCM_F_COMPARE_NONE;
+      CACHE_SP ();
+      NEXT (1);
+    }
+
   VM_DEFINE_OP (214, unused_214, NULL, NOP)
   VM_DEFINE_OP (215, unused_215, NULL, NOP)
   VM_DEFINE_OP (216, unused_216, NULL, NOP)

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:

module/system/vm/assembler.scm

@@ -77,6 +77,7 @@
             emit-immediate-tag=?
             emit-heap-tag=?
             emit-eq?
+            emit-heap-numbers-equal?
             emit-j
             emit-jl
             emit-je