[Guile-commits] 03/69: Implement odd? and even? with new integer lib

[Andy Wingo]

wingo pushed a commit to branch wip-inline-digits
in repository guile.

commit dd5f4e44d6e606803b91e8a7a60fcefe6ce3edca
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Fri Dec 3 14:07:32 2021 +0100

    Implement odd? and even? with new integer lib
    
    * libguile/integers.c (scm_is_integer_odd_i):
    (scm_is_integer_odd_z): New internal functions.  Add a number of
    internal support routines.
    * libguile/integers.h: Declare internal functions.
    * libguile/numbers.c (scm_odd_p, scm_even_p): Use the new functions.
---
 libguile/integers.c | 211 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 libguile/integers.h |   5 +-
 libguile/numbers.c  |  23 ++----
 3 files changed, 220 insertions(+), 19 deletions(-)

diff --git a/libguile/integers.c b/libguile/integers.c
index d19c4450e..e449ff635 100644
--- a/libguile/integers.c
+++ b/libguile/integers.c
@@ -23,6 +23,8 @@
 # include <config.h>
 #endif
 
+#include <stdlib.h>
+#include <stdio.h>
 #include <verify.h>
 
 #include "numbers.h"
@@ -33,3 +35,212 @@
    non-negative fixnum will always fit in a 'mp_limb_t'.  */
 verify (SCM_MOST_POSITIVE_FIXNUM <= (mp_limb_t) -1);
 
+#define NLIMBS_MAX (SSIZE_MAX / sizeof(mp_limb_t))
+
+#ifndef NDEBUG
+#define ASSERT(x)                                                       \
+  do {                                                                  \
+    if (!(x))                                                           \
+      {                                                                 \
+        fprintf (stderr, "%s:%d: assertion failed\n", __FILE__, __LINE__); \
+        abort();                                                        \
+      }                                                                 \
+  } while (0)
+#else
+#define ASSERT(x) do { } while (0)
+#endif
+
+struct scm_bignum
+{
+  scm_t_bits tag;
+  /* FIXME: In Guile 3.2, replace this union with just a "size" member.
+     Digits are always allocated inline.  */
+  union {
+    mpz_t mpz;
+    struct {
+      int zero;
+      int size;
+      mp_limb_t *limbs;
+    } z;
+  } u;
+  mp_limb_t limbs[];
+};
+
+static inline struct scm_bignum *
+scm_bignum (SCM x)
+{
+  ASSERT (SCM_BIGP (x));
+  return (struct scm_bignum *) SCM_UNPACK (x);
+}
+
+static int
+bignum_size (struct scm_bignum *z)
+{
+  return z->u.z.size;
+}
+
+static int
+bignum_is_negative (struct scm_bignum *z)
+{
+  return bignum_size (z) < 0;
+}
+
+static size_t
+bignum_limb_count (struct scm_bignum *z)
+{
+  return bignum_is_negative (z) ? -bignum_size (z) : bignum_size (z);
+}
+
+static mp_limb_t*
+bignum_limbs (struct scm_bignum *z)
+{
+  // FIXME: In the future we can just return z->limbs.
+  return z->u.z.limbs;
+}
+
+static inline unsigned long
+long_magnitude (long l)
+{
+  unsigned long mag = l;
+  return l < 0 ? ~mag + 1 : mag;
+}
+
+static inline long
+negative_long (unsigned long mag)
+{
+  ASSERT (mag <= (unsigned long) LONG_MIN);
+  return ~mag + 1;
+}
+
+static inline scm_t_bits
+inum_magnitude (scm_t_inum i)
+{
+  scm_t_bits mag = i;
+  if (i < 0)
+    mag = ~mag + 1;
+  return mag;
+}
+
+static struct scm_bignum *
+allocate_bignum (size_t nlimbs)
+{
+  ASSERT (nlimbs <= (size_t)INT_MAX);
+  ASSERT (nlimbs <= NLIMBS_MAX);
+
+  size_t size = sizeof (struct scm_bignum) + nlimbs * sizeof(mp_limb_t);
+  struct scm_bignum *z = scm_gc_malloc_pointerless (size, "bignum");
+
+  z->tag = scm_tc16_big;
+
+  z->u.z.zero = 0;
+  z->u.z.size = nlimbs;
+  z->u.z.limbs = z->limbs;
+
+  // _mp_alloc == 0 means GMP will never try to free this memory.
+  ASSERT (z->u.mpz[0]._mp_alloc == 0);
+  // Our "size" field should alias the mpz's _mp_size field.
+  ASSERT (z->u.mpz[0]._mp_size == nlimbs);
+  // Limbs are always allocated inline.
+  ASSERT (z->u.mpz[0]._mp_d == z->limbs);
+
+  // z->limbs left uninitialized.
+  return z;
+}
+
+static struct scm_bignum *
+negate_bignum (struct scm_bignum *z)
+{
+  z->u.z.size = -z->u.z.size;
+  return z;
+}
+
+static SCM
+make_bignum_1 (int is_negative, mp_limb_t limb)
+{
+  struct scm_bignum *z = allocate_bignum (1);
+  z->limbs[0] = limb;
+  return SCM_PACK (is_negative ? negate_bignum(z) : z);
+}
+
+static SCM
+ulong_to_bignum (unsigned long u)
+{
+  ASSERT (!SCM_POSFIXABLE (u));
+  return make_bignum_1 (0, u);
+};
+
+static SCM
+long_to_bignum (long i)
+{
+  if (i > 0)
+    return ulong_to_bignum (i);
+
+  ASSERT (!SCM_NEGFIXABLE (i));
+  return make_bignum_1 (1, long_magnitude (i));
+};
+
+static SCM
+inum_to_bignum (scm_t_inum i)
+{
+  return long_to_bignum (i);
+};
+
+static struct scm_bignum *
+clone_bignum (struct scm_bignum *z)
+{
+  struct scm_bignum *ret = allocate_bignum (bignum_limb_count (z));
+  mpn_copyi (bignum_limbs (ret), bignum_limbs (z), bignum_limb_count (z));
+  return bignum_is_negative (z) ? negate_bignum (ret) : ret;
+}
+
+static void
+alias_bignum_to_mpz (struct scm_bignum *z, mpz_ptr mpz)
+{
+  // No need to clear this mpz.
+  mpz->_mp_alloc = 0;
+  mpz->_mp_size = bignum_size (z);
+  // Gotta be careful to keep z alive.
+  mpz->_mp_d = bignum_limbs (z);
+}
+
+static struct scm_bignum *
+make_bignum_from_mpz (mpz_srcptr mpz)
+{
+  size_t nlimbs = mpz_size (mpz);
+  struct scm_bignum *ret = allocate_bignum (nlimbs);
+  mpn_copyi (bignum_limbs (ret), mpz_limbs_read (mpz), nlimbs);
+  return mpz_sgn (mpz) < 0 ? negate_bignum (ret) : ret;
+}
+
+static SCM
+normalize_bignum (struct scm_bignum *z)
+{
+  switch (bignum_size (z))
+    {
+    case -1:
+      if (bignum_limbs (z)[0] <= inum_magnitude (SCM_MOST_NEGATIVE_FIXNUM))
+        return SCM_I_MAKINUM (negative_long (bignum_limbs (z)[0]));
+      break;
+    case 0:
+      return SCM_INUM0;
+    case 1:
+      if (bignum_limbs (z)[0] <= SCM_MOST_POSITIVE_FIXNUM)
+        return SCM_I_MAKINUM (bignum_limbs (z)[0]);
+      break;
+    default:
+      break;
+    }
+  return SCM_PACK (z);
+}
+
+int
+scm_is_integer_odd_i (scm_t_inum i)
+{
+  return i & 1;
+}
+
+int
+scm_is_integer_odd_z (SCM z)
+{
+  return bignum_limbs (scm_bignum (z))[0] & 1;
+}
diff --git a/libguile/integers.h b/libguile/integers.h
index ac0a0f325..2bd937669 100644
--- a/libguile/integers.h
+++ b/libguile/integers.h
@@ -21,7 +21,10 @@
 
 
 
-/* Contents go here.  */
+#include "libguile/numbers.h"
+
+SCM_INTERNAL int scm_is_integer_odd_i (scm_t_inum i);
+SCM_INTERNAL int scm_is_integer_odd_z (SCM z);
 
 
 
diff --git a/libguile/numbers.c b/libguile/numbers.c
index bc0fe282d..a91d5963d 100644
--- a/libguile/numbers.c
+++ b/libguile/numbers.c
@@ -65,6 +65,7 @@
 #include "finalizers.h"
 #include "goops.h"
 #include "gsubr.h"
+#include "integers.h"
 #include "modules.h"
 #include "pairs.h"
 #include "ports.h"
@@ -741,16 +742,9 @@ SCM_PRIMITIVE_GENERIC (scm_odd_p, "odd?", 1, 0, 0,
 #define FUNC_NAME s_scm_odd_p
 {
   if (SCM_I_INUMP (n))
-    {
-      scm_t_inum val = SCM_I_INUM (n);
-      return scm_from_bool ((val & 1L) != 0);
-    }
+    return scm_from_bool (scm_is_integer_odd_i (SCM_I_INUM (n)));
   else if (SCM_BIGP (n))
-    {
-      int odd_p = mpz_odd_p (SCM_I_BIG_MPZ (n));
-      scm_remember_upto_here_1 (n);
-      return scm_from_bool (odd_p);
-    }
+    return scm_from_bool (scm_is_integer_odd_z (n));
   else if (SCM_REALP (n))
     {
       double val = SCM_REAL_VALUE (n);
@@ -775,16 +769,9 @@ SCM_PRIMITIVE_GENERIC (scm_even_p, "even?", 1, 0, 0,
 #define FUNC_NAME s_scm_even_p
 {
   if (SCM_I_INUMP (n))
-    {
-      scm_t_inum val = SCM_I_INUM (n);
-      return scm_from_bool ((val & 1L) == 0);
-    }
+    return scm_from_bool (!scm_is_integer_odd_i (SCM_I_INUM (n)));
   else if (SCM_BIGP (n))
-    {
-      int even_p = mpz_even_p (SCM_I_BIG_MPZ (n));
-      scm_remember_upto_here_1 (n);
-      return scm_from_bool (even_p);
-    }
+    return scm_from_bool (!scm_is_integer_odd_z (n));
   else if (SCM_REALP (n))
     {
       double val = SCM_REAL_VALUE (n);