gmp.xs

来自「a very popular packet of cryptography to」· XS 代码 · 共 2,874 行 · 第 1/5 页

/* GMP module external subroutines.

Copyright 2001, 2002, 2003 Free Software Foundation, Inc.

This file is part of the GNU MP Library.

The GNU MP Library is free software; you can redistribute it and/or modify
it under the terms of the GNU Lesser General Public License as published by
the Free Software Foundation; either version 2.1 of the License, or (at your
option) any later version.

The GNU MP Library is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of MERCHANTABILITY
or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Lesser General Public
License for more details.

You should have received a copy of the GNU Lesser General Public License
along with the GNU MP Library; see the file COPYING.LIB.  If not, write to
the Free Software Foundation, Inc., 59 Temple Place - Suite 330, Boston,
MA 02111-1307, USA. */


/* Notes:

   Routines are grouped with the alias feature and a table of function
   pointers where possible, since each xsub routine ends up with quite a bit
   of code size.  Different combinations of arguments and return values have
   to be separate though.

   The "INTERFACE:" feature isn't available in perl 5.005 and so isn't used.
   "ALIAS:" requires a table lookup with CvXSUBANY(cv).any_i32 (which is
   "ix") whereas "INTERFACE:" would have CvXSUBANY(cv).any_dptr as the
   function pointer immediately.

   Mixed-type swapped-order assignments like "$a = 123; $a += mpz(456);"
   invoke the plain overloaded "+", not "+=", which makes life easier.

   mpz_assume etc types are used with the overloaded operators since such
   operators are always called with a class object as the first argument, we
   don't need an sv_derived_from() lookup to check.  There's assert()s in
   MPX_ASSUME() for this though.

   The overload_constant routines reached via overload::constant get 4
   arguments in perl 5.6, not the 3 as documented.  This is apparently a
   bug, using "..." lets us ignore the extra one.

   There's only a few "si" functions in gmp, so usually SvIV values get
   handled with an mpz_set_si into a temporary and then a full precision mpz
   routine.  This is reasonably efficient.

   Argument types are checked, with a view to preserving all bits in the
   operand.  Perl is a bit looser in its arithmetic, allowing rounding or
   truncation to an intended operand type (IV, UV or NV).

   Bugs:

   The memory leak detection attempted in GMP::END() doesn't work when mpz's
   are created as constants because END() is called before they're
   destroyed.  What's the right place to hook such a check?

   See the bugs section of GMP.pm too.  */


/* Comment this out to get assertion checking. */
#define NDEBUG

/* Change this to "#define TRACE(x) x" for some diagnostics. */
#define TRACE(x) 


#include <assert.h>
#include <float.h>

#include "EXTERN.h"
#include "perl.h"
#include "XSUB.h"
#include "patchlevel.h"

#include "gmp.h"


/* Perl 5.005 doesn't have SvIsUV, only 5.6 and up.
   Perl 5.8 has SvUOK, but not 5.6, so we don't use that.  */
#ifndef SvIsUV
#define SvIsUV(sv)  0
#endif
#ifndef SvUVX
#define SvUVX(sv)  (croak("GMP: oops, shouldn't be using SvUVX"), 0)
#endif


/* Code which doesn't check anything itself, but exists to support other
   assert()s.  */
#ifdef NDEBUG
#define assert_support(x)
#else
#define assert_support(x) x
#endif

/* LONG_MAX + 1 and ULONG_MAX + 1, as a doubles */
#define LONG_MAX_P1_AS_DOUBLE   ((double) ((unsigned long) LONG_MAX + 1))
#define ULONG_MAX_P1_AS_DOUBLE  (2.0 * (double) ((unsigned long) ULONG_MAX/2 + 1))

/* Check for perl version "major.minor".
   Perl 5.004 doesn't have PERL_REVISION and PERL_VERSION, but that's ok,
   we're only interested in tests above that.  */
#if defined (PERL_REVISION) && defined (PERL_VERSION)
#define PERL_GE(major,minor)                                    \
    (PERL_REVISION > (major)                                    \
     || ((major) == PERL_REVISION && PERL_VERSION >= (minor)))
#else
#define PERL_GE(major,minor)  (0)
#endif
#define PERL_LT(major,minor)  (! PERL_GE(major,minor))

/* sv_derived_from etc in 5.005 took "char *" rather than "const char *".
   Avoid some compiler warnings by using const only where it works.  */
#if PERL_LT (5,6)
#define classconst
#else
#define classconst const
#endif

/* In a MINGW or Cygwin DLL build of gmp, the various gmp functions are
   given with dllimport directives, which prevents them being used as
   initializers for constant data.  We give function tables as
   "static_functable const ...", which is normally "static const", but for
   mingw expands to just "const" making the table an automatic with a
   run-time initializer.

   In gcc 3.3.1, the function tables initialized like this end up getting
   all the __imp__foo values fetched, even though just one or two will be
   used.  This is wasteful, but probably not too bad.  */

#if defined (__MINGW32__) || defined (__CYGWIN__)
#define static_functable
#else
#define static_functable  static
#endif

#define GMP_MALLOC_ID  42

static classconst char mpz_class[]  = "GMP::Mpz";
static classconst char mpq_class[]  = "GMP::Mpq";
static classconst char mpf_class[]  = "GMP::Mpf";
static classconst char rand_class[] = "GMP::Rand";

static HV *mpz_class_hv;
static HV *mpq_class_hv;
static HV *mpf_class_hv;

assert_support (static long mpz_count = 0;)
assert_support (static long mpq_count = 0;)
assert_support (static long mpf_count = 0;)
assert_support (static long rand_count = 0;)

#define TRACE_ACTIVE()                                                   \
  assert_support                                                         \
  (TRACE (printf ("  active %ld mpz, %ld mpq, %ld mpf, %ld randstate\n", \
                  mpz_count, mpq_count, mpf_count, rand_count)))


/* Each "struct mpz_elem" etc is an mpz_t with a link field tacked on the
   end so they can be held on a linked list.  */

#define CREATE_MPX(type)                                \
                                                        \
  /* must have mpz_t etc first, for sprintf below */    \
  struct type##_elem {                                  \
    type##_t            m;                              \
    struct type##_elem  *next;                          \
  };                                                    \
  typedef struct type##_elem  *type;                    \
  typedef struct type##_elem  *type##_assume;           \
  typedef type##_ptr          type##_coerce;            \
                                                        \
  static type type##_freelist = NULL;                   \
                                                        \
  static type                                           \
  new_##type (void)                                     \
  {                                                     \
    type p;                                             \
    TRACE (printf ("new %s\n", type##_class));          \
    if (type##_freelist != NULL)                        \
      {                                                 \
        p = type##_freelist;                            \
        type##_freelist = type##_freelist->next;        \
      }                                                 \
    else                                                \
      {                                                 \
        New (GMP_MALLOC_ID, p, 1, struct type##_elem);  \
        type##_init (p->m);                             \
      }                                                 \
    TRACE (printf ("  p=%p\n", p));                     \
    assert_support (type##_count++);                    \
    TRACE_ACTIVE ();                                    \
    return p;                                           \
  }                                                     \

CREATE_MPX (mpz)
CREATE_MPX (mpq)

typedef mpf_ptr  mpf;
typedef mpf_ptr  mpf_assume;
typedef mpf_ptr  mpf_coerce_st0;
typedef mpf_ptr  mpf_coerce_def;


static mpf
new_mpf (unsigned long prec)
{
  mpf p;
  New (GMP_MALLOC_ID, p, 1, __mpf_struct);
  mpf_init2 (p, prec);
  TRACE (printf ("  mpf p=%p\n", p));
  assert_support (mpf_count++);
  TRACE_ACTIVE ();
  return p;
}


/* tmp_mpf_t records an allocated precision with an mpf_t so changes of
   precision can be done with just an mpf_set_prec_raw.  */

struct tmp_mpf_struct {
  mpf_t          m;
  unsigned long  allocated_prec;
};
typedef const struct tmp_mpf_struct  *tmp_mpf_srcptr;
typedef struct tmp_mpf_struct        *tmp_mpf_ptr;
typedef struct tmp_mpf_struct        tmp_mpf_t[1];

#define tmp_mpf_init(f)                         \
  do {                                          \
    mpf_init (f->m);                            \
    f->allocated_prec = mpf_get_prec (f->m);    \
  } while (0)

static void
tmp_mpf_grow (tmp_mpf_ptr f, unsigned long prec)
{
  mpf_set_prec_raw (f->m, f->allocated_prec);
  mpf_set_prec (f->m, prec);
  f->allocated_prec = mpf_get_prec (f->m);
}

#define tmp_mpf_shrink(f)  tmp_mpf_grow (f, 1L)

#define tmp_mpf_set_prec(f,prec)        \
  do {                                  \
    if (prec > f->allocated_prec)       \
      tmp_mpf_grow (f, prec);           \
    else                                \
      mpf_set_prec_raw (f->m, prec);    \
  } while (0)


static mpz_t  tmp_mpz_0, tmp_mpz_1, tmp_mpz_2;
static mpq_t  tmp_mpq_0, tmp_mpq_1;
static tmp_mpf_t tmp_mpf_0, tmp_mpf_1;

/* for GMP::Mpz::export */
#define tmp_mpz_4  tmp_mpz_2


#define FREE_MPX_FREELIST(p,type)               \
  do {                                          \
    TRACE (printf ("free %s\n", type##_class)); \
    p->next = type##_freelist;                  \
    type##_freelist = p;                        \
    assert_support (type##_count--);            \
    TRACE_ACTIVE ();                            \
    assert (type##_count >= 0);                 \
  } while (0)

/* this version for comparison, if desired */
#define FREE_MPX_NOFREELIST(p,type)             \
  do {                                          \
    TRACE (printf ("free %s\n", type##_class)); \
    type##_clear (p->m);                        \
    Safefree (p);                               \
    assert_support (type##_count--);            \
    TRACE_ACTIVE ();                            \
    assert (type##_count >= 0);                 \
  } while (0)

#define free_mpz(z)    FREE_MPX_FREELIST (z, mpz)
#define free_mpq(q)    FREE_MPX_FREELIST (q, mpq)


/* Return a new mortal SV holding the given mpx_ptr pointer.
   class_hv should be one of mpz_class_hv etc.  */
#define MPX_NEWMORTAL(mpx_ptr, class_hv)                                \
    sv_bless (sv_setref_pv (sv_newmortal(), NULL, mpx_ptr), class_hv)

/* Aliases for use in typemaps */
typedef char           *malloced_string;
typedef const char     *const_string;
typedef const char     *const_string_assume;
typedef char           *string;
typedef SV             *order_noswap;
typedef SV             *dummy;
typedef SV             *SV_copy_0;
typedef unsigned long  ulong_coerce;
typedef __gmp_randstate_struct *randstate;
typedef UV             gmp_UV;

#define SvMPX(s,type)  ((type) SvIV((SV*) SvRV(s)))
#define SvMPZ(s)       SvMPX(s,mpz)
#define SvMPQ(s)       SvMPX(s,mpq)
#define SvMPF(s)       SvMPX(s,mpf)
#define SvRANDSTATE(s) SvMPX(s,randstate)

#define MPX_ASSUME(x,sv,type)                           \
  do {                                                  \
    assert (sv_derived_from (sv, type##_class));        \
    x = SvMPX(sv,type);                                 \
  } while (0)

#define MPZ_ASSUME(z,sv)    MPX_ASSUME(z,sv,mpz)
#define MPQ_ASSUME(q,sv)    MPX_ASSUME(q,sv,mpq)
#define MPF_ASSUME(f,sv)    MPX_ASSUME(f,sv,mpf)

#define numberof(x)  (sizeof (x) / sizeof ((x)[0]))
#define SGN(x)       ((x)<0 ? -1 : (x) != 0)
#define ABS(x)       ((x)>=0 ? (x) : -(x))
#define double_integer_p(d)  (floor (d) == (d))

#define x_mpq_integer_p(q) \
  (mpz_cmp_ui (mpq_denref(q), 1L) == 0)

#define assert_table(ix)  assert (ix >= 0 && ix < numberof (table))

#define SV_PTR_SWAP(x,y) \
  do { SV *__tmp = (x); (x) = (y); (y) = __tmp; } while (0)
#define MPF_PTR_SWAP(x,y) \
  do { mpf_ptr __tmp = (x); (x) = (y); (y) = __tmp; } while (0)


static void
class_or_croak (SV *sv, classconst char *cl)
{
  if (! sv_derived_from (sv, cl))
    croak("not type %s", cl);
}


/* These are macros, wrap them in functions. */
static int
x_mpz_odd_p (mpz_srcptr z)
{
  return mpz_odd_p (z);
}
static int
x_mpz_even_p (mpz_srcptr z)
{
  return mpz_even_p (z);
}

static void
x_mpq_pow_ui (mpq_ptr r, mpq_srcptr b, unsigned long e)
{
  mpz_pow_ui (mpq_numref(r), mpq_numref(b), e);
  mpz_pow_ui (mpq_denref(r), mpq_denref(b), e);
}


static void *
my_gmp_alloc (size_t n)
{
  void *p;
  TRACE (printf ("my_gmp_alloc %u\n", n));
  New (GMP_MALLOC_ID, p, n, char);
  TRACE (printf ("  p=%p\n", p));
  return p;
}

static void *
my_gmp_realloc (void *p, size_t oldsize, size_t newsize)
{
  TRACE (printf ("my_gmp_realloc %p, %u to %u\n", p, oldsize, newsize));
  Renew (p, newsize, char);
  TRACE (printf ("  p=%p\n", p));
  return p;
}

static void
my_gmp_free (void *p, size_t n)
{
  TRACE (printf ("my_gmp_free %p %u\n", p, n));
  Safefree (p);
}


#define my_mpx_set_svstr(type)                                  \
  static void                                                   \
  my_##type##_set_svstr (type##_ptr x, SV *sv)                  \
  {                                                             \
    const char  *str;                                           \
    STRLEN      len;                                            \
    TRACE (printf ("  my_" #type "_set_svstr\n"));              \
    assert (SvPOK(sv) || SvPOKp(sv));                           \
    str = SvPV (sv, len);                                       \
    TRACE (printf ("  str \"%s\"\n", str));                     \
    if (type##_set_str (x, str, 0) != 0)                        \
      croak ("%s: invalid string: %s", type##_class, str);      \
  }

my_mpx_set_svstr(mpz)
my_mpx_set_svstr(mpq)
my_mpx_set_svstr(mpf)


/* very slack */
static int
x_mpq_cmp_si (mpq_srcptr x, long yn, unsigned long yd)
{
  mpq  y;
  int  ret;
  y = new_mpq ();
  mpq_set_si (y->m, yn, yd);
  ret = mpq_cmp (x, y->m);
  free_mpq (y);
  return ret;
}

static int
x_mpq_fits_slong_p (mpq_srcptr q)
{
  return x_mpq_cmp_si (q, LONG_MIN, 1L) >= 0
    && mpq_cmp_ui (q, LONG_MAX, 1L) <= 0;
}

static int
x_mpz_cmp_q (mpz_ptr x, mpq_srcptr y)
{
  int  ret;
  mpz_set_ui (mpq_denref(tmp_mpq_0), 1L);
  mpz_swap (mpq_numref(tmp_mpq_0), x);
  ret = mpq_cmp (tmp_mpq_0, y);
  mpz_swap (mpq_numref(tmp_mpq_0), x);
  return ret;
}

static int
x_mpz_cmp_f (mpz_srcptr x, mpf_srcptr y)
{
  tmp_mpf_set_prec (tmp_mpf_0, mpz_sizeinbase (x, 2));
  mpf_set_z (tmp_mpf_0->m, x);
  return mpf_cmp (tmp_mpf_0->m, y);
}


#define USE_UNKNOWN  0
#define USE_IVX      1
#define USE_UVX      2
#define USE_NVX      3
#define USE_PVX      4
#define USE_MPZ      5
#define USE_MPQ      6
#define USE_MPF      7

/* mg_get is called every time we get a value, even if the private flags are
   still set from a previous such call.  This is the same as as SvIV and
   friends do.

   When POK, we use the PV, even if there's an IV or NV available.  This is
   because it's hard to be sure there wasn't any rounding in establishing
   the IV and/or NV.  Cases of overflow, where the PV should definitely be
   used, are easy enough to spot, but rounding is hard.  So although IV or
   NV would be more efficient, we must use the PV to be sure of getting all
   the data.  Applications should convert once to mpz, mpq or mpf when using
   a value repeatedly.

   Zany dual-type scalars like $! where the IV is an error code and the PV
   is an error description string won't work with this preference for PV,
   but that's too bad.  Such scalars should be rare, and unlikely to be used
   in bignum calculations.

   When IOK and NOK are both set, we would prefer to use the IV since it can
   be converted more efficiently, and because on a 64-bit system the NV may
   have less bits than the IV.  The following rules are applied,

   - If the NV is not an integer, then we must use that NV, since clearly
     the IV was merely established by rounding and is not the full value.

   - In perl prior to 5.8, an NV too big for an IV leaves an overflow value
     0xFFFFFFFF.  If the NV is too big to fit an IV then clearly it's the NV
     which is the true value and must be used.

   - In perl 5.8 and up, such an overflow doesn't set IOK, so that test is
     unnecessary.  However when coming from get-magic, IOKp _is_ set, and we
     must check for overflow the same as in older perl.

   FIXME:

   We'd like to call mg_get just once, but unfortunately sv_derived_from()
   will call it for each of our checks.  We could do a string compare like
   sv_isa ourselves, but that only tests the exact class, it doesn't
   recognise subclassing.  There doesn't seem to be a public interface to
   the subclassing tests (in the internal isa_lookup() function).  */

int
use_sv (SV *sv)
{
  double  d;

  if (SvGMAGICAL(sv))
    {
      mg_get(sv);

      if (SvPOKp(sv))
        return USE_PVX;

      if (SvIOKp(sv))
        {
          if (SvIsUV(sv))
            {
              if (SvNOKp(sv))
                goto u_or_n;
              return USE_UVX;
            }
          else
            {
              if (SvNOKp(sv))
                goto i_or_n;
              return USE_IVX;
            }
        }

      if (SvNOKp(sv))
        return USE_NVX;

      goto rok_or_unknown;
    }

  if (SvPOK(sv))
    return USE_PVX;

  if (SvIOK(sv))
    {
      if (SvIsUV(sv))
        {
          if (SvNOK(sv))
            {
              if (PERL_LT (5, 8))
                {
                u_or_n:
                  d = SvNVX(sv);
                  if (d >= ULONG_MAX_P1_AS_DOUBLE || d < 0.0)
                    return USE_NVX;
                }
              d = SvNVX(sv);
              if (d != floor (d))
                return USE_NVX;
            }
          return USE_UVX;
        }
      else
        {
          if (SvNOK(sv))
            {
              if (PERL_LT (5, 8))
                {
                i_or_n:
                  d = SvNVX(sv);
                  if (d >= LONG_MAX_P1_AS_DOUBLE || d < (double) LONG_MIN)
                    return USE_NVX;
                }
              d = SvNVX(sv);
              if (d != floor (d))
                return USE_NVX;
            }
          return USE_IVX;
        }