This repository has been archived on 2023-08-20. You can view files and clone it, but cannot push or open issues or pull requests.
yap-6.3/C/bignum.c

513 lines
13 KiB
C
Raw Normal View History

/*************************************************************************
2017-07-30 21:53:07 +01:00
* *
* YAP Prolog *
* *
* Yap Prolog was developed at NCCUP - Universidade do Porto *
* *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* *
**************************************************************************
* *
* File: arith1.c *
* Last rev: *
* mods: *
* comments: bignum support through gmp *
* *
*************************************************************************/
#ifdef SCCS
2017-07-30 21:53:07 +01:00
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
#include "Yatom.h"
2010-07-19 22:42:47 +01:00
#if HAVE_STRING_H
#include <string.h>
#endif
#include "YapHeap.h"
2015-09-21 23:05:36 +01:00
#include "YapText.h"
#ifdef USE_GMP
2017-02-20 14:21:46 +00:00
#include "YapEval.h"
#include "alloc.h"
2017-07-30 21:53:07 +01:00
Term Yap_MkBigIntTerm(MP_INT *big) {
CACHE_REGS
Int nlimbs;
2017-07-30 21:53:07 +01:00
MP_INT *dst = (MP_INT *)(HR + 2);
2014-01-19 21:15:05 +00:00
CELL *ret = HR;
Int bytes;
if (mpz_fits_slong_p(big)) {
long int out = mpz_get_si(big);
return MkIntegerTerm((Int)out);
}
// bytes = big->_mp_alloc * sizeof(mp_limb_t);
// nlimbs = ALIGN_YAPTYPE(bytes,CELL)/CellSize;
// this works, but it shouldn't need to do this...
nlimbs = big->_mp_alloc;
2017-07-30 21:53:07 +01:00
bytes = nlimbs * sizeof(CELL);
if (nlimbs > (ASP - ret) - 1024) {
return TermNil;
}
2014-01-19 21:15:05 +00:00
HR[0] = (CELL)FunctorBigInt;
HR[1] = BIG_INT;
dst->_mp_size = big->_mp_size;
2017-07-30 21:53:07 +01:00
dst->_mp_alloc = nlimbs * (CellSize / sizeof(mp_limb_t));
memmove((void *)(dst + 1), (const void *)(big->_mp_d), bytes);
HR = (CELL *)(dst + 1) + nlimbs;
2014-01-19 21:15:05 +00:00
HR[0] = EndSpecials;
HR++;
2011-07-21 10:24:21 +01:00
return AbsAppl(ret);
}
2017-07-30 21:53:07 +01:00
MP_INT *Yap_BigIntOfTerm(Term t) {
MP_INT *new = (MP_INT *)(RepAppl(t) + 2);
2017-07-30 21:53:07 +01:00
new->_mp_d = (mp_limb_t *)(new + 1);
return (new);
}
2017-07-30 21:53:07 +01:00
Term Yap_MkBigRatTerm(MP_RAT *big) {
CACHE_REGS
2010-05-27 12:24:15 +01:00
Int nlimbs;
2017-07-30 21:53:07 +01:00
MP_INT *dst = (MP_INT *)(HR + 2);
2010-05-27 12:24:15 +01:00
MP_INT *num = mpq_numref(big);
MP_INT *den = mpq_denref(big);
MP_RAT *rat;
2014-01-19 21:15:05 +00:00
CELL *ret = HR;
2010-05-27 12:24:15 +01:00
if (mpz_cmp_si(den, 1) == 0)
return Yap_MkBigIntTerm(num);
2017-07-30 21:53:07 +01:00
if ((num->_mp_alloc + den->_mp_alloc) * (sizeof(mp_limb_t) / CellSize) >
(ASP - ret) - 1024) {
2010-05-27 12:24:15 +01:00
return TermNil;
}
2014-01-19 21:15:05 +00:00
HR[0] = (CELL)FunctorBigInt;
HR[1] = BIG_RATIONAL;
dst->_mp_size = 0;
2017-07-30 21:53:07 +01:00
rat = (MP_RAT *)(dst + 1);
2010-05-27 12:24:15 +01:00
rat->_mp_num._mp_size = num->_mp_size;
rat->_mp_num._mp_alloc = num->_mp_alloc;
2017-07-30 21:53:07 +01:00
nlimbs = (num->_mp_alloc) * (sizeof(mp_limb_t) / CellSize);
memmove((void *)(rat + 1), (const void *)(num->_mp_d), nlimbs * CellSize);
2010-05-27 12:24:15 +01:00
rat->_mp_den._mp_size = den->_mp_size;
rat->_mp_den._mp_alloc = den->_mp_alloc;
2017-07-30 21:53:07 +01:00
HR = (CELL *)(rat + 1) + nlimbs;
nlimbs = (den->_mp_alloc) * (sizeof(mp_limb_t) / CellSize);
memmove((void *)(HR), (const void *)(den->_mp_d), nlimbs * CellSize);
2014-01-19 21:15:05 +00:00
HR += nlimbs;
2017-07-30 21:53:07 +01:00
dst->_mp_alloc = (HR - (CELL *)(dst + 1));
2014-01-19 21:15:05 +00:00
HR[0] = EndSpecials;
HR++;
2010-05-27 12:24:15 +01:00
return AbsAppl(ret);
}
2017-07-30 21:53:07 +01:00
MP_RAT *Yap_BigRatOfTerm(Term t) {
MP_RAT *new = (MP_RAT *)(RepAppl(t) + 2 + sizeof(MP_INT) / sizeof(CELL));
2010-05-27 12:24:15 +01:00
mp_limb_t *nt;
2017-07-30 21:53:07 +01:00
nt = new->_mp_num._mp_d = (mp_limb_t *)(new + 1);
2010-05-27 12:24:15 +01:00
nt += new->_mp_num._mp_alloc;
new->_mp_den._mp_d = nt;
return new;
}
2017-07-30 21:53:07 +01:00
Term Yap_RatTermToApplTerm(Term t) {
Term ts[2];
MP_RAT *rat = Yap_BigRatOfTerm(t);
2017-07-30 21:53:07 +01:00
ts[0] = Yap_MkBigIntTerm(mpq_numref(rat));
ts[1] = Yap_MkBigIntTerm(mpq_denref(rat));
return Yap_MkApplTerm(FunctorRDiv, 2, ts);
}
#endif
Term Yap_AllocExternalDataInStack(CELL tag, size_t bytes, void *pt) {
CACHE_REGS
Int nlimbs;
2017-07-30 21:53:07 +01:00
MP_INT *dst = (MP_INT *)(HR + 2);
2014-01-19 21:15:05 +00:00
CELL *ret = HR;
CELL **blobp;
2017-07-30 21:53:07 +01:00
nlimbs = ALIGN_BY_TYPE(bytes, CELL) / CellSize;
if (nlimbs > (ASP - ret) - 1024) {
return TermNil;
}
2014-01-19 21:15:05 +00:00
HR[0] = (CELL)FunctorBigInt;
HR[1] = tag;
dst->_mp_size = 0;
dst->_mp_alloc = nlimbs;
2017-07-30 21:53:07 +01:00
HR = (CELL *)(dst + 1) + nlimbs;
2014-01-19 21:15:05 +00:00
HR[0] = EndSpecials;
HR++;
blobp = (CELL **)pt;
*blobp = (CELL *)(dst + 1);
return AbsAppl(ret);
}
2010-05-27 12:24:15 +01:00
2017-07-30 21:53:07 +01:00
int Yap_CleanOpaqueVariable(CELL d) {
CELL blob_info, blob_tag;
2017-07-30 21:53:07 +01:00
CELL *pt = RepAppl(HeadOfTerm(d));
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
2015-09-25 10:57:26 +01:00
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
return FALSE;
}
#endif
blob_tag = pt[1];
2017-07-30 21:53:07 +01:00
if (blob_tag < USER_BLOB_START || blob_tag >= USER_BLOB_END) {
Yap_Error(SYSTEM_ERROR_INTERNAL, AbsAppl(pt),
"clean opaque: bad blob with tag " UInt_FORMAT, blob_tag);
return FALSE;
}
blob_info = blob_tag - USER_BLOB_START;
if (!GLOBAL_OpaqueHandlers)
return FALSE;
2011-07-22 12:21:21 +01:00
if (!GLOBAL_OpaqueHandlers[blob_info].fail_handler)
2017-07-30 21:53:07 +01:00
return true;
return (GLOBAL_OpaqueHandlers[blob_info].fail_handler)(d);
}
2017-07-30 21:53:07 +01:00
YAP_Opaque_CallOnWrite Yap_blob_write_handler(Term t) {
2011-07-27 16:50:14 +01:00
CELL blob_info, blob_tag;
CELL *pt = RepAppl(t);
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
2015-09-25 10:57:26 +01:00
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
2011-07-27 16:50:14 +01:00
return FALSE;
}
#endif
blob_tag = pt[1];
2017-07-30 21:53:07 +01:00
if (blob_tag < USER_BLOB_START || blob_tag >= USER_BLOB_END) {
Yap_Error(SYSTEM_ERROR_INTERNAL, AbsAppl(pt),
"clean opaque: bad blob with tag " UInt_FORMAT, blob_tag);
2011-07-27 16:50:14 +01:00
return FALSE;
}
blob_info = blob_tag - USER_BLOB_START;
if (!GLOBAL_OpaqueHandlers) {
2011-07-27 16:50:14 +01:00
return NULL;
}
2011-07-27 16:50:14 +01:00
return GLOBAL_OpaqueHandlers[blob_info].write_handler;
}
2017-07-30 21:53:07 +01:00
YAP_Opaque_CallOnGCMark Yap_blob_gc_mark_handler(Term t) {
CELL blob_info, blob_tag;
CELL *pt = RepAppl(t);
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
2015-09-25 10:57:26 +01:00
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
return FALSE;
}
#endif
blob_tag = pt[1];
2017-07-30 21:53:07 +01:00
if (blob_tag < USER_BLOB_START || blob_tag >= USER_BLOB_END) {
return NULL;
}
blob_info = blob_tag - USER_BLOB_START;
if (!GLOBAL_OpaqueHandlers)
return NULL;
2017-07-30 21:53:07 +01:00
return GLOBAL_OpaqueHandlers[blob_info].mark_handler;
}
2017-07-30 21:53:07 +01:00
YAP_Opaque_CallOnGCRelocate Yap_blob_gc_relocate_handler(Term t) {
CELL blob_info, blob_tag;
CELL *pt = RepAppl(t);
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
2015-09-25 10:57:26 +01:00
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
return FALSE;
}
#endif
blob_tag = pt[1];
2017-07-30 21:53:07 +01:00
if (blob_tag < USER_BLOB_START || blob_tag >= USER_BLOB_END) {
Yap_Error(SYSTEM_ERROR_INTERNAL, AbsAppl(pt),
"clean opaque: bad blob with tag " UInt_FORMAT, blob_tag);
return FALSE;
}
blob_info = blob_tag - USER_BLOB_START;
if (!GLOBAL_OpaqueHandlers)
return NULL;
2017-07-30 21:53:07 +01:00
return GLOBAL_OpaqueHandlers[blob_info].relocate_handler;
}
2017-07-30 21:53:07 +01:00
extern Int Yap_blob_tag(Term t) {
2011-07-27 16:50:14 +01:00
CELL *pt = RepAppl(t);
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
2015-09-25 10:57:26 +01:00
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
2011-07-27 16:50:14 +01:00
return FALSE;
}
#endif
return pt[1];
}
2017-07-30 21:53:07 +01:00
void *Yap_blob_info(Term t) {
2011-07-27 16:50:14 +01:00
MP_INT *blobp;
CELL *pt = RepAppl(t);
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
2015-09-25 10:57:26 +01:00
Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call");
2011-07-27 16:50:14 +01:00
return FALSE;
}
#endif
if (!GLOBAL_OpaqueHandlers)
return FALSE;
2017-07-30 21:53:07 +01:00
blobp = (MP_INT *)(pt + 2);
return (void *)(blobp + 1);
2011-07-27 16:50:14 +01:00
}
2017-07-30 21:53:07 +01:00
Term Yap_MkULLIntTerm(YAP_ULONG_LONG n) {
#if __GNUC__ && USE_GMP
2017-07-30 21:53:07 +01:00
mpz_t new;
char tmp[256];
Term t;
#ifdef _WIN32
2017-07-30 21:53:07 +01:00
snprintf(tmp, 256, "%I64u", n);
#elif HAVE_SNPRINTF
2017-07-30 21:53:07 +01:00
snprintf(tmp, 256, "%llu", n);
2015-04-13 13:15:30 +01:00
#else
2017-07-30 21:53:07 +01:00
sprintf(tmp, "%llu", n);
#endif
2017-07-30 21:53:07 +01:00
/* try to scan it as a bignum */
mpz_init_set_str(new, tmp, 10);
if (mpz_fits_slong_p(new)) {
2013-06-04 04:03:59 +01:00
CACHE_REGS
2017-07-30 21:53:07 +01:00
return MkIntegerTerm(mpz_get_si(new));
}
t = Yap_MkBigIntTerm(new);
mpz_clear(new);
return t;
#else
CACHE_REGS
return MkIntegerTerm(n);
#endif
}
2017-07-30 21:53:07 +01:00
CELL *Yap_HeapStoreOpaqueTerm(Term t) {
CELL *ptr = RepAppl(t);
size_t sz;
void *new;
if (ptr[0] == (CELL)FunctorBigInt) {
2017-07-30 21:53:07 +01:00
sz = sizeof(MP_INT) + 2 * CellSize +
((MP_INT *)(ptr + 2))->_mp_alloc * sizeof(mp_limb_t);
} else { /* string */
2017-07-30 21:53:07 +01:00
sz = sizeof(CELL) * (2 + ptr[1]);
}
new = Yap_AllocCodeSpace(sz);
if (!new) {
2017-07-30 21:53:07 +01:00
Yap_Error(RESOURCE_ERROR_HEAP, TermNil,
"subgoal_search_loop: no space for %s", StringOfTerm(t));
} else {
if (ptr[0] == (CELL)FunctorBigInt) {
2017-07-30 21:53:07 +01:00
MP_INT *new = (MP_INT *)(RepAppl(t) + 2);
2017-07-30 21:53:07 +01:00
new->_mp_d = (mp_limb_t *)(new + 1);
}
memmove(new, ptr, sz);
}
2015-04-13 13:15:30 +01:00
return new;
}
2017-07-30 21:53:07 +01:00
size_t Yap_OpaqueTermToString(Term t, char *str, size_t max) {
size_t str_index = 0;
2017-07-30 21:53:07 +01:00
CELL *li = RepAppl(t);
2015-11-05 15:09:54 +00:00
unsigned char *ptr = (unsigned char *)StringOfTerm(AbsAppl(li));
if (li[0] == (CELL)FunctorString) {
2017-07-30 21:53:07 +01:00
str_index += sprintf(&str[str_index], "\"");
do {
2015-09-21 23:05:36 +01:00
utf8proc_int32_t chr;
2017-07-30 21:53:07 +01:00
ptr += get_utf8(ptr, -1, &chr);
if (chr == '\0')
break;
str_index += sprintf(str + str_index, "%C", chr);
} while (TRUE);
2017-07-30 21:53:07 +01:00
str_index += sprintf(str + str_index, "\"");
} else {
CELL big_tag = li[1];
if (big_tag == ARRAY_INT || big_tag == ARRAY_FLOAT) {
2017-07-30 21:53:07 +01:00
str_index += sprintf(&str[str_index], "{...}");
#ifdef USE_GMP
} else if (big_tag == BIG_INT) {
MP_INT *big = Yap_BigIntOfTerm(AbsAppl(li));
char *s = mpz_get_str(&str[str_index], 10, big);
str_index += strlen(&s[str_index]);
} else if (big_tag == BIG_RATIONAL) {
MP_RAT *big = Yap_BigRatOfTerm(AbsAppl(li));
char *s = mpq_get_str(&str[str_index], 10, big);
str_index += strlen(&s[str_index]);
#endif
2015-04-13 13:15:30 +01:00
}
/*
else if (big_tag >= USER_BLOB_START && big_tag < USER_BLOB_END) {
Opaque_CallOnWrite f;
CELL blob_info;
2015-04-13 13:15:30 +01:00
blob_info = big_tag - USER_BLOB_START;
if (GLOBAL_OpaqueHandlers &&
(f= GLOBAL_OpaqueHandlers[blob_info].write_handler)) {
(f)(wglb->stream, big_tag, ExternalBlobFromTerm(t), 0);
return;
}
} */
2017-07-30 21:53:07 +01:00
str_index += sprintf(&str[str_index], "0");
}
return str_index;
}
2017-07-30 21:53:07 +01:00
static Int p_is_bignum(USES_REGS1) {
#ifdef USE_GMP
Term t = Deref(ARG1);
2017-07-30 21:53:07 +01:00
return (IsNonVarTerm(t) && IsApplTerm(t) &&
FunctorOfTerm(t) == FunctorBigInt && RepAppl(t)[1] == BIG_INT);
#else
return FALSE;
#endif
}
2017-07-30 21:53:07 +01:00
static Int p_is_string(USES_REGS1) {
2013-12-06 23:24:01 +00:00
Term t = Deref(ARG1);
2017-07-30 21:53:07 +01:00
return (IsNonVarTerm(t) && IsApplTerm(t) &&
FunctorOfTerm(t) == FunctorString);
2013-12-06 23:24:01 +00:00
}
2017-07-30 21:53:07 +01:00
static Int p_nb_set_bit(USES_REGS1) {
#ifdef USE_GMP
Term t = Deref(ARG1);
Term ti = Deref(ARG2);
Int i;
2017-07-30 21:53:07 +01:00
if (!(IsNonVarTerm(t) && IsApplTerm(t) && FunctorOfTerm(t) == FunctorBigInt &&
RepAppl(t)[1] == BIG_INT))
return FALSE;
if (!IsIntegerTerm(ti)) {
return FALSE;
}
if (!IsIntegerTerm(ti)) {
return FALSE;
}
i = IntegerOfTerm(ti);
if (i < 0) {
return FALSE;
}
Yap_gmp_set_bit(i, t);
return TRUE;
#else
return FALSE;
#endif
}
2017-07-30 21:53:07 +01:00
static Int p_has_bignums(USES_REGS1) {
#ifdef USE_GMP
return TRUE;
#else
return FALSE;
#endif
}
2017-07-30 21:53:07 +01:00
static Int p_is_opaque(USES_REGS1) {
2013-09-19 14:23:10 +01:00
Term t = Deref(ARG1);
if (IsVarTerm(t))
return FALSE;
if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
CELL *pt;
if (f != FunctorBigInt)
return FALSE;
pt = RepAppl(t);
2017-07-30 21:53:07 +01:00
return (pt[1] != BIG_RATIONAL || pt[1] != BIG_INT);
2013-09-19 14:23:10 +01:00
}
return FALSE;
}
2017-07-30 21:53:07 +01:00
static Int p_is_rational(USES_REGS1) {
Term t = Deref(ARG1);
if (IsVarTerm(t))
return FALSE;
if (IsIntTerm(t))
return TRUE;
if (IsApplTerm(t)) {
Functor f = FunctorOfTerm(t);
CELL *pt;
if (f == FunctorLongInt)
return TRUE;
if (f != FunctorBigInt)
return FALSE;
pt = RepAppl(t);
2017-07-30 21:53:07 +01:00
return (pt[1] == BIG_RATIONAL || pt[1] == BIG_INT);
}
return FALSE;
}
2017-07-30 21:53:07 +01:00
static Int p_rational(USES_REGS1) {
#ifdef USE_GMP
Term t = Deref(ARG1);
Functor f;
CELL *pt;
MP_RAT *rat;
Term t1, t2;
if (IsVarTerm(t))
return FALSE;
if (!IsApplTerm(t))
return FALSE;
f = FunctorOfTerm(t);
if (f != FunctorBigInt)
return FALSE;
pt = RepAppl(t);
if (pt[1] != BIG_RATIONAL)
return FALSE;
rat = Yap_BigRatOfTerm(t);
while ((t1 = Yap_MkBigIntTerm(mpq_numref(rat))) == TermNil ||
2017-07-30 21:53:07 +01:00
(t2 = Yap_MkBigIntTerm(mpq_denref(rat))) == TermNil) {
UInt size = (mpq_numref(rat)->_mp_alloc) * (sizeof(mp_limb_t) / CellSize) +
(mpq_denref(rat)->_mp_alloc) * (sizeof(mp_limb_t) / CellSize);
if (!Yap_gcl(size, 3, ENV, P)) {
2015-09-25 10:57:26 +01:00
Yap_Error(RESOURCE_ERROR_STACK, t, LOCAL_ErrorMessage);
return FALSE;
}
}
2017-07-30 21:53:07 +01:00
return Yap_unify(ARG2, t1) && Yap_unify(ARG3, t2);
#else
return FALSE;
#endif
}
2017-07-30 21:53:07 +01:00
void Yap_InitBigNums(void) {
2012-10-19 18:10:48 +01:00
Yap_InitCPred("$has_bignums", 0, p_has_bignums, SafePredFlag);
Yap_InitCPred("$bignum", 1, p_is_bignum, SafePredFlag);
Yap_InitCPred("rational", 3, p_rational, 0);
Yap_InitCPred("rational", 1, p_is_rational, SafePredFlag);
2017-07-30 21:53:07 +01:00
/** @pred rational( _T_)
2014-09-11 20:06:57 +01:00
2017-07-30 21:53:07 +01:00
Checks whether `T` is a rational number.
2014-09-11 20:06:57 +01:00
2015-04-13 13:15:30 +01:00
2017-07-30 21:53:07 +01:00
*/
2013-12-06 23:24:01 +00:00
Yap_InitCPred("string", 1, p_is_string, SafePredFlag);
2013-09-19 14:23:10 +01:00
Yap_InitCPred("opaque", 1, p_is_opaque, SafePredFlag);
Yap_InitCPred("nb_set_bit", 2, p_nb_set_bit, SafePredFlag);
}