/************************************************************************* * * * 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 static char SccsId[] = "%W% %G%"; #endif #include "Yap.h" #include "Yatom.h" #if HAVE_STRING_H #include #endif #include "YapHeap.h" #include "YapText.h" #ifdef USE_GMP #include "YapEval.h" #include "alloc.h" Term Yap_MkBigIntTerm(MP_INT *big) { CACHE_REGS Int nlimbs; MP_INT *dst = (MP_INT *)(HR + 2); 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; bytes = nlimbs * sizeof(CELL); if (nlimbs > (ASP - ret) - 1024) { return TermNil; } HR[0] = (CELL)FunctorBigInt; HR[1] = BIG_INT; dst->_mp_size = big->_mp_size; dst->_mp_alloc = nlimbs * (CellSize / sizeof(mp_limb_t)); memmove((void *)(dst + 1), (const void *)(big->_mp_d), bytes); HR = (CELL *)(dst + 1) + nlimbs; HR[0] = EndSpecials; HR++; return AbsAppl(ret); } MP_INT *Yap_BigIntOfTerm(Term t) { MP_INT *new = (MP_INT *)(RepAppl(t) + 2); new->_mp_d = (mp_limb_t *)(new + 1); return (new); } Term Yap_MkBigRatTerm(MP_RAT *big) { CACHE_REGS Int nlimbs; MP_INT *dst = (MP_INT *)(HR + 2); MP_INT *num = mpq_numref(big); MP_INT *den = mpq_denref(big); MP_RAT *rat; CELL *ret = HR; if (mpz_cmp_si(den, 1) == 0) return Yap_MkBigIntTerm(num); if ((num->_mp_alloc + den->_mp_alloc) * (sizeof(mp_limb_t) / CellSize) > (ASP - ret) - 1024) { return TermNil; } HR[0] = (CELL)FunctorBigInt; HR[1] = BIG_RATIONAL; dst->_mp_size = 0; rat = (MP_RAT *)(dst + 1); rat->_mp_num._mp_size = num->_mp_size; rat->_mp_num._mp_alloc = num->_mp_alloc; nlimbs = (num->_mp_alloc) * (sizeof(mp_limb_t) / CellSize); memmove((void *)(rat + 1), (const void *)(num->_mp_d), nlimbs * CellSize); rat->_mp_den._mp_size = den->_mp_size; rat->_mp_den._mp_alloc = den->_mp_alloc; HR = (CELL *)(rat + 1) + nlimbs; nlimbs = (den->_mp_alloc) * (sizeof(mp_limb_t) / CellSize); memmove((void *)(HR), (const void *)(den->_mp_d), nlimbs * CellSize); HR += nlimbs; dst->_mp_alloc = (HR - (CELL *)(dst + 1)); HR[0] = EndSpecials; HR++; return AbsAppl(ret); } MP_RAT *Yap_BigRatOfTerm(Term t) { MP_RAT *new = (MP_RAT *)(RepAppl(t) + 2 + sizeof(MP_INT) / sizeof(CELL)); mp_limb_t *nt; nt = new->_mp_num._mp_d = (mp_limb_t *)(new + 1); nt += new->_mp_num._mp_alloc; new->_mp_den._mp_d = nt; return new; } Term Yap_RatTermToApplTerm(Term t) { Term ts[2]; MP_RAT *rat = Yap_BigRatOfTerm(t); 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; MP_INT *dst = (MP_INT *)(HR + 2); CELL *ret = HR; CELL **blobp; nlimbs = ALIGN_BY_TYPE(bytes, CELL) / CellSize; if (nlimbs > (ASP - ret) - 1024) { return TermNil; } HR[0] = (CELL)FunctorBigInt; HR[1] = tag; dst->_mp_size = 0; dst->_mp_alloc = nlimbs; HR = (CELL *)(dst + 1) + nlimbs; HR[0] = EndSpecials; HR++; blobp = (CELL **)pt; *blobp = (CELL *)(dst + 1); return AbsAppl(ret); } int Yap_CleanOpaqueVariable(CELL d) { CELL blob_info, blob_tag; CELL *pt = RepAppl(HeadOfTerm(d)); #ifdef DEBUG /* sanity checking */ if (pt[0] != (CELL)FunctorBigInt) { Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call"); return FALSE; } #endif blob_tag = pt[1]; 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; if (!GLOBAL_OpaqueHandlers[blob_info].fail_handler) return true; return (GLOBAL_OpaqueHandlers[blob_info].fail_handler)(d); } YAP_Opaque_CallOnWrite Yap_blob_write_handler(Term t) { CELL blob_info, blob_tag; CELL *pt = RepAppl(t); #ifdef DEBUG /* sanity checking */ if (pt[0] != (CELL)FunctorBigInt) { Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call"); return FALSE; } #endif blob_tag = pt[1]; 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; } return GLOBAL_OpaqueHandlers[blob_info].write_handler; } 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) { Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call"); return FALSE; } #endif blob_tag = pt[1]; 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; return GLOBAL_OpaqueHandlers[blob_info].mark_handler; } 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) { Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call"); return FALSE; } #endif blob_tag = pt[1]; 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; return GLOBAL_OpaqueHandlers[blob_info].relocate_handler; } extern Int Yap_blob_tag(Term t) { CELL *pt = RepAppl(t); #ifdef DEBUG /* sanity checking */ if (pt[0] != (CELL)FunctorBigInt) { Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call"); return FALSE; } #endif return pt[1]; } void *Yap_blob_info(Term t) { MP_INT *blobp; CELL *pt = RepAppl(t); #ifdef DEBUG /* sanity checking */ if (pt[0] != (CELL)FunctorBigInt) { Yap_Error(SYSTEM_ERROR_INTERNAL, TermNil, "CleanOpaqueVariable bad call"); return FALSE; } #endif if (!GLOBAL_OpaqueHandlers) return FALSE; blobp = (MP_INT *)(pt + 2); return (void *)(blobp + 1); } Term Yap_MkULLIntTerm(YAP_ULONG_LONG n) { #if __GNUC__ && USE_GMP mpz_t new; char tmp[256]; Term t; #ifdef _WIN32 snprintf(tmp, 256, "%I64u", n); #elif HAVE_SNPRINTF snprintf(tmp, 256, "%llu", n); #else sprintf(tmp, "%llu", n); #endif /* try to scan it as a bignum */ mpz_init_set_str(new, tmp, 10); if (mpz_fits_slong_p(new)) { CACHE_REGS return MkIntegerTerm(mpz_get_si(new)); } t = Yap_MkBigIntTerm(new); mpz_clear(new); return t; #else CACHE_REGS return MkIntegerTerm(n); #endif } CELL *Yap_HeapStoreOpaqueTerm(Term t) { CELL *ptr = RepAppl(t); size_t sz; void *new; if (ptr[0] == (CELL)FunctorBigInt) { sz = sizeof(MP_INT) + 2 * CellSize + ((MP_INT *)(ptr + 2))->_mp_alloc * sizeof(mp_limb_t); } else { /* string */ sz = sizeof(CELL) * (2 + ptr[1]); } new = Yap_AllocCodeSpace(sz); if (!new) { Yap_Error(RESOURCE_ERROR_HEAP, TermNil, "subgoal_search_loop: no space for %s", StringOfTerm(t)); } else { if (ptr[0] == (CELL)FunctorBigInt) { MP_INT *new = (MP_INT *)(RepAppl(t) + 2); new->_mp_d = (mp_limb_t *)(new + 1); } memmove(new, ptr, sz); } return new; } size_t Yap_OpaqueTermToString(Term t, char *str, size_t max) { size_t str_index = 0; CELL *li = RepAppl(t); unsigned char *ptr = (unsigned char *)StringOfTerm(AbsAppl(li)); if (li[0] == (CELL)FunctorString) { str_index += sprintf(&str[str_index], "\""); do { utf8proc_int32_t chr; ptr += get_utf8(ptr, -1, &chr); if (chr == '\0') break; str_index += sprintf(str + str_index, "%C", chr); } while (TRUE); str_index += sprintf(str + str_index, "\""); } else { CELL big_tag = li[1]; if (big_tag == ARRAY_INT || big_tag == ARRAY_FLOAT) { 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 } /* else if (big_tag >= USER_BLOB_START && big_tag < USER_BLOB_END) { Opaque_CallOnWrite f; CELL blob_info; 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; } } */ str_index += sprintf(&str[str_index], "0"); } return str_index; } static Int p_is_bignum(USES_REGS1) { #ifdef USE_GMP Term t = Deref(ARG1); return (IsNonVarTerm(t) && IsApplTerm(t) && FunctorOfTerm(t) == FunctorBigInt && RepAppl(t)[1] == BIG_INT); #else return FALSE; #endif } static Int p_is_string(USES_REGS1) { Term t = Deref(ARG1); return (IsNonVarTerm(t) && IsApplTerm(t) && FunctorOfTerm(t) == FunctorString); } static Int p_nb_set_bit(USES_REGS1) { #ifdef USE_GMP Term t = Deref(ARG1); Term ti = Deref(ARG2); Int i; 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 } static Int p_has_bignums(USES_REGS1) { #ifdef USE_GMP return TRUE; #else return FALSE; #endif } static Int p_is_opaque(USES_REGS1) { 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); return (pt[1] != BIG_RATIONAL || pt[1] != BIG_INT); } return FALSE; } 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); return (pt[1] == BIG_RATIONAL || pt[1] == BIG_INT); } return FALSE; } 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 || (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)) { Yap_Error(RESOURCE_ERROR_STACK, t, LOCAL_ErrorMessage); return FALSE; } } return Yap_unify(ARG2, t1) && Yap_unify(ARG3, t2); #else return FALSE; #endif } void Yap_InitBigNums(void) { 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); /** @pred rational( _T_) Checks whether `T` is a rational number. */ Yap_InitCPred("string", 1, p_is_string, SafePredFlag); Yap_InitCPred("opaque", 1, p_is_opaque, SafePredFlag); Yap_InitCPred("nb_set_bit", 2, p_nb_set_bit, SafePredFlag); }