334 lines
10 KiB
C
334 lines
10 KiB
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;
|
|
}
|
|
|