From 41bc98985f39ed512594402cf150cebaff498656 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Tue, 8 May 2018 11:49:46 +0200
Subject: [PATCH] VM calls out to heap-numbers-equal? through intrinsics

* libguile/numbers.h:
* libguile/eq.c (scm_i_heap_numbers_equal_p): Change to return boolean
  directly instead of tagged Scheme value.
  (scm_eqv_p): Adapt caller of scm_i_heap_numbers_equal_p.
* libguile/intrinsics.c (scm_bootstrap_intrinsics):
* libguile/intrinsics.h (SCM_FOR_ALL_VM_INTRINSICS): Declare
  heap-numbers-equal? intrinsic.
* libguile/vm-engine.c (heap-numbers-equal?): Call out through the
  intrinsics table.
---
 libguile/eq.c         | 14 +++++++-------
 libguile/intrinsics.c |  1 +
 libguile/intrinsics.h |  2 ++
 libguile/numbers.h    |  2 +-
 libguile/vm-engine.c  |  2 +-
 5 files changed, 12 insertions(+), 9 deletions(-)

diff --git a/libguile/eq.c b/libguile/eq.c
index daee4c02e..f1153f2cc 100644
--- a/libguile/eq.c
+++ b/libguile/eq.c
@@ -1,4 +1,4 @@
-/* Copyright (C) 1995-1998,2000-2001,2003-2004,2006,2009-2011,2017 Free Software Foundation, Inc.
+/* Copyright (C) 1995-1998,2000-2001,2003-2004,2006,2009-2011,2017,2018 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,20 +156,20 @@ scm_i_fraction_equalp (SCM x, SCM y)
 				  SCM_FRACTION_DENOMINATOR (y))));
 }
 
-SCM
+int
 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);
+      return scm_is_true (scm_bigequal (x, y));
     case scm_tc16_real:
-      return scm_real_equalp (x, y);
+      return scm_is_true (scm_real_equalp (x, y));
     case scm_tc16_complex:
-      return scm_complex_equalp (x, y);
+      return scm_is_true (scm_complex_equalp (x, y));
     case scm_tc16_fraction:
-      return scm_i_fraction_equalp (x, y);
+      return scm_is_true (scm_i_fraction_equalp (x, y));
     default:
       abort ();
     }
@@ -229,7 +229,7 @@ SCM scm_eqv_p (SCM x, SCM y)
     default:
       break;
     case scm_tc7_number:
-      return scm_i_heap_numbers_equal_p (x, y);
+      return scm_from_bool (scm_i_heap_numbers_equal_p (x, y));
     }
   return SCM_BOOL_F;
 }
diff --git a/libguile/intrinsics.c b/libguile/intrinsics.c
index 75a70fa3a..2a07905c0 100644
--- a/libguile/intrinsics.c
+++ b/libguile/intrinsics.c
@@ -242,6 +242,7 @@ scm_bootstrap_intrinsics (void)
   scm_vm_intrinsics.rsh = rsh;
   scm_vm_intrinsics.lsh_immediate = lsh_immediate;
   scm_vm_intrinsics.rsh_immediate = rsh_immediate;
+  scm_vm_intrinsics.heap_numbers_equal_p = scm_i_heap_numbers_equal_p;
 
   scm_c_register_extension ("libguile-" SCM_EFFECTIVE_VERSION,
                             "scm_init_intrinsics",
diff --git a/libguile/intrinsics.h b/libguile/intrinsics.h
index 419c0c048..e30ed10cd 100644
--- a/libguile/intrinsics.h
+++ b/libguile/intrinsics.h
@@ -37,6 +37,7 @@ typedef void (*scm_t_thread_scm_intrinsic) (scm_i_thread*, SCM);
 typedef void (*scm_t_thread_scm_scm_intrinsic) (scm_i_thread*, SCM, SCM);
 typedef SCM (*scm_t_scm_from_thread_scm_intrinsic) (scm_i_thread*, SCM);
 typedef SCM (*scm_t_scm_from_scm_u64_intrinsic) (SCM, scm_t_uint64);
+typedef int (*scm_t_bool_from_scm_scm_intrinsic) (SCM, SCM);
 
 #define SCM_FOR_ALL_VM_INTRINSICS(M) \
   M(scm_from_scm_scm, add, "add", ADD) \
@@ -75,6 +76,7 @@ typedef SCM (*scm_t_scm_from_scm_u64_intrinsic) (SCM, scm_t_uint64);
   M(scm_from_scm_u64, rsh, "rsh", RSH) \
   M(scm_from_scm_uimm, lsh_immediate, "lsh/immediate", LSH_IMMEDIATE) \
   M(scm_from_scm_uimm, rsh_immediate, "rsh/immediate", RSH_IMMEDIATE) \
+  M(bool_from_scm_scm, heap_numbers_equal_p, "heap-numbers-equal?", HEAP_NUMBERS_EQUAL_P) \
   /* Add new intrinsics here; also update scm_bootstrap_intrinsics.  */
 
 enum scm_vm_intrinsic
diff --git a/libguile/numbers.h b/libguile/numbers.h
index c07082eb1..744ef7fc5 100644
--- a/libguile/numbers.h
+++ b/libguile/numbers.h
@@ -264,7 +264,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_INTERNAL int 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);
diff --git a/libguile/vm-engine.c b/libguile/vm-engine.c
index 683b3acc2..184cd1ef7 100644
--- a/libguile/vm-engine.c
+++ b/libguile/vm-engine.c
@@ -3141,7 +3141,7 @@ VM_NAME (scm_i_thread *thread, struct scm_vm *vp,
       y = SP_REF (b);
 
       SYNC_IP ();
-      if (scm_is_true (scm_i_heap_numbers_equal_p (x, y)))
+      if (scm_vm_intrinsics.heap_numbers_equal_p (x, y))
         vp->compare_result = SCM_F_COMPARE_EQUAL;
       else
         vp->compare_result = SCM_F_COMPARE_NONE;