ocaml/otherlibs/num/nat_stubs.c

/***********************************************************************/
/*                                                                     */
/*                           Objective Caml                            */
/*                                                                     */
/*            Xavier Leroy, projet Cristal, INRIA Rocquencourt         */
/*                                                                     */
/*  Copyright 1996 Institut National de Recherche en Informatique et   */
/*  en Automatique.  All rights reserved.  This file is distributed    */
/*  under the terms of the GNU Library General Public License.         */
/*                                                                     */
/***********************************************************************/

/* $Id$ */

#define CAML_LIGHT
#include "alloc.h"
#include "custom.h"
#include "intext.h"
#include "fail.h"
#include "memory.h"
#include "mlvalues.h"
#include "nat.h"

#include "BigNum.h"
#include "BntoBnn.h"

/* Stub code for the BigNum package. */

static void serialize_nat(value, unsigned long *, unsigned long *);
static unsigned long deserialize_nat(void * dst);

static struct custom_operations nat_operations = {
  "_nat",
  custom_finalize_default,
  custom_compare_default,
  custom_hash_default,
  serialize_nat,
  deserialize_nat
};

value initialize_nat(value unit)
{
  register_custom_operations(&nat_operations);
  return Val_unit;
}

value create_nat(value size)
{
  mlsize_t sz = Long_val(size);

  return alloc_custom(&nat_operations, sz * sizeof(value), 0, 1);
}

value length_nat(value nat)
{
  return Val_long(Wosize_val(nat) - 1);
}

value set_to_zero_nat(value nat, value ofs, value len)
{
  BnSetToZero(Bignum_val(nat), Long_val(ofs), Long_val(len));
  return Val_unit;
}

value blit_nat(value nat1, value ofs1, value nat2, value ofs2, value len)
{
  BnAssign(Bignum_val(nat1), Long_val(ofs1),
           Bignum_val(nat2), Long_val(ofs2),
           Long_val(len));
  return Val_unit;
}

value set_digit_nat(value nat, value ofs, value digit)
{
  BnSetDigit(Bignum_val(nat), Long_val(ofs), Long_val(digit));
  return Val_unit;
}

value nth_digit_nat(value nat, value ofs)
{
  return Val_long(BnGetDigit(Bignum_val(nat), Long_val(ofs)));
}

value num_digits_nat(value nat, value ofs, value len)
{
  return Val_long(BnNumDigits(Bignum_val(nat), Long_val(ofs), Long_val(len)));
}

value num_leading_zero_bits_in_digit(value nat, value ofs)
{
  return
    Val_long(BnNumLeadingZeroBitsInDigit(Bignum_val(nat), Long_val(ofs)));
}

value is_digit_int(value nat, value ofs)
{
  return Val_bool(BnDoesDigitFitInWord(Bignum_val(nat), Long_val(ofs)));
}

value is_digit_zero(value nat, value ofs)
{
  return Val_bool(BnIsDigitZero(Bignum_val(nat), Long_val(ofs)));
}

value is_digit_normalized(value nat, value ofs)
{
  return Val_bool(BnIsDigitNormalized(Bignum_val(nat), Long_val(ofs)));
}

value is_digit_odd(value nat, value ofs)
{
  return Val_bool(BnIsDigitOdd(Bignum_val(nat), Long_val(ofs)));
}

value incr_nat(value nat, value ofs, value len, value carry_in)
{
  return Val_long(BnAddCarry(Bignum_val(nat), Long_val(ofs),
                             Long_val(len), Long_val(carry_in)));
}

value add_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2, value carry_in)
{
  return Val_long(BnAdd(Bignum_val(nat1), Long_val(ofs1), Long_val(len1),
                        Bignum_val(nat2), Long_val(ofs2), Long_val(len2),
                        Long_val(carry_in)));
}

value add_nat(value *argv, int argn)
{
  return add_nat_native(argv[0], argv[1], argv[2], argv[3],
                        argv[4], argv[5], argv[6]);
}

value complement_nat(value nat, value ofs, value len)
{
  BnComplement(Bignum_val(nat), Long_val(ofs), Long_val(len));
  return Val_unit;
}

value decr_nat(value nat, value ofs, value len, value carry_in)
{
  return Val_long(BnSubtractBorrow(Bignum_val(nat), Long_val(ofs),
                                   Long_val(len), Long_val(carry_in)));
}

value sub_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2, value carry_in)
{
  return Val_long(BnSubtract(Bignum_val(nat1), Long_val(ofs1), Long_val(len1),
                             Bignum_val(nat2), Long_val(ofs2), Long_val(len2),
                             Long_val(carry_in)));
}

value sub_nat(value *argv, int argn)
{
  return sub_nat_native(argv[0], argv[1], argv[2], argv[3],
                        argv[4], argv[5], argv[6]);
}

value mult_digit_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2, value nat3, value ofs3)
{
  return
    Val_long(BnMultiplyDigit(Bignum_val(nat1), Long_val(ofs1), Long_val(len1),
                             Bignum_val(nat2), Long_val(ofs2), Long_val(len2),
                             Bignum_val(nat3), Long_val(ofs3)));
}

value mult_digit_nat(value *argv, int argn)
{
  return mult_digit_nat_native(argv[0], argv[1], argv[2], argv[3],
                               argv[4], argv[5], argv[6], argv[7]);
}

value mult_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2, value nat3, value ofs3, value len3)
{
  return
    Val_long(BnMultiply(Bignum_val(nat1), Long_val(ofs1), Long_val(len1),
                        Bignum_val(nat2), Long_val(ofs2), Long_val(len2),
                        Bignum_val(nat3), Long_val(ofs3), Long_val(len3)));
}

value mult_nat(value *argv, int argn)
{
  return mult_nat_native(argv[0], argv[1], argv[2], argv[3],
                         argv[4], argv[5], argv[6], argv[7], argv[8]);
}

value shift_left_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value nbits)
{
  BnShiftLeft(Bignum_val(nat1), Long_val(ofs1), Long_val(len1),
              Bignum_val(nat2), Long_val(ofs2), Long_val(nbits));
  return Val_unit;
}

value shift_left_nat(value *argv, int argn)
{
  return shift_left_nat_native(argv[0], argv[1], argv[2],
                               argv[3], argv[4], argv[5]);
}

value div_digit_nat_native(value natq, value ofsq, value natr, value ofsr, value nat1, value ofs1, value len1, value nat2, value ofs2)
{
  BnDivideDigit(Bignum_val(natq), Long_val(ofsq),
                Bignum_val(natr), Long_val(ofsr),
                Bignum_val(nat1), Long_val(ofs1), Long_val(len1),
                Bignum_val(nat2), Long_val(ofs2));
  return Val_unit;
}

value div_digit_nat(value *argv, int argn)
{
  return div_digit_nat_native(argv[0], argv[1], argv[2], argv[3],
                              argv[4], argv[5], argv[6], argv[7], argv[8]);
}

value div_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2)
{
  BnDivide(Bignum_val(nat1), Long_val(ofs1), Long_val(len1),
           Bignum_val(nat2), Long_val(ofs2), Long_val(len2));
  return Val_unit;
}

value div_nat(value *argv, int argn)
{
  return div_nat_native(argv[0], argv[1], argv[2],
                        argv[3], argv[4], argv[5]);
}
 
value shift_right_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value nbits)
{
  BnShiftRight(Bignum_val(nat1), Long_val(ofs1), Long_val(len1),
              Bignum_val(nat2), Long_val(ofs2), Long_val(nbits));
  return Val_unit;
}

value shift_right_nat(value *argv, int argn)
{
  return shift_right_nat_native(argv[0], argv[1], argv[2],
                               argv[3], argv[4], argv[5]);
}

value compare_digits_nat(value nat1, value ofs1, value nat2, value ofs2)
{
  return Val_long(BnCompareDigits(Bignum_val(nat1), Long_val(ofs1),
                                  Bignum_val(nat2), Long_val(ofs2)));
}

value compare_nat_native(value nat1, value ofs1, value len1, value nat2, value ofs2, value len2)
{
  return Val_long(BnCompare(Bignum_val(nat1), Long_val(ofs1), Long_val(len1),
                            Bignum_val(nat2), Long_val(ofs2), Long_val(len2)));
}

value compare_nat(value *argv, int argn)
{
  return compare_nat_native(argv[0], argv[1], argv[2],
                            argv[3], argv[4], argv[5]);
}

value land_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
{
  BnAndDigits(Bignum_val(nat1), Long_val(ofs1),
              Bignum_val(nat2), Long_val(ofs2));
  return Val_unit;
}

value lor_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
{
  BnOrDigits(Bignum_val(nat1), Long_val(ofs1),
              Bignum_val(nat2), Long_val(ofs2));
  return Val_unit;
}

value lxor_digit_nat(value nat1, value ofs1, value nat2, value ofs2)
{
  BnXorDigits(Bignum_val(nat1), Long_val(ofs1),
              Bignum_val(nat2), Long_val(ofs2));
  return Val_unit;
}

/* The wire format for a nat is:
   - 32-bit word: number of 32-bit words in nat
   - N 32-bit words (big-endian format)
   For little-endian platforms, the memory layout between 32-bit and 64-bit
   machines is identical, so we can write the nat using serialize_block_4.
   For big-endian 64-bit platforms, we need to swap the two 32-bit halves
   of 64-bit words to obtain the correct behavior. */

static void serialize_nat(value nat, 
                          unsigned long * wsize_32,
                          unsigned long * wsize_64)
{
  mlsize_t len = Wosize_val(nat) - 1;

#ifdef ARCH_SIXTYFOUR
  len = len * 2; /* two 32-bit words per 64-bit digit  */
  if (len >= (1L << 32))
    failwith("output_value: nat too big");
#endif
  serialize_int_4((int32) len);
#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
  { int32 * p;
    mlsize_t i;
    for (i = len, p = Data_custom_val(nat); i > 0; i -= 2, p += 2) {
      serialize_int_4(p[1]);    /* low 32 bits of 64-bit digit */
      serialize_int_4(p[0]);    /* high 32 bits of 64-bit digit */
    }
  }
#else
  serialize_block_4(Data_custom_val(nat), len);
#endif
  *wsize_32 = len * 4;
  *wsize_64 = len * 4;
}

static unsigned long deserialize_nat(void * dst)
{
  mlsize_t len;

  len = deserialize_uint_4();
#if defined(ARCH_SIXTYFOUR) && defined(ARCH_BIG_ENDIAN)
  { uint32 * p;
    mlsize_t i;
    for (i = len, p = dst; i > 0; i -= 2, p += 2) {
      p[1] = deserialize_uint_4();   /* low 32 bits of 64-bit digit */
      p[0] = deserialize_uint_4();   /* high 32 bits of 64-bit digit */
    }
  }
#else
  deserialize_block_4(dst, len);
#endif
  return len * 4;
}