diogo/yap-6.3
Archived
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

replace cut_c by trail entries

Browse Source
This commit is contained in:
Vitor Santos Costa 2017-07-30 21:53:07 +01:00
parent 3d191957db
commit dac6dc7c22
35 changed files with 4509 additions and 4587 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
C/agc.c
View File

@ -340,8 +340,8 @@ mark_global_cell(CELL *pt)
Int sz = 3 +
(sizeof(MP_INT)+
(((MP_INT *)(pt+2))->_mp_alloc*sizeof(mp_limb_t)))/sizeof(CELL);
Opaque_CallOnGCMark f;
Opaque_CallOnGCRelocate f2;
YAP_Opaque_CallOnGCMark f;
YAP_Opaque_CallOnGCRelocate f2;
Term t = AbsAppl(pt);
if ( (f = Yap_blob_gc_mark_handler(t)) ) {

327
C/bignum.c
View File

@ -1,21 +1,21 @@
/*************************************************************************
* *
* 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 *
* *
*************************************************************************/
* *
* 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%";
static char SccsId[] = "%W% %G%";
#endif
#include "Yap.h"
@ -33,12 +33,10 @@ static char SccsId[] = "%W% %G%";
#include "YapEval.h"
#include "alloc.h"
Term
Yap_MkBigIntTerm(MP_INT *big)
{
Term Yap_MkBigIntTerm(MP_INT *big) {
CACHE_REGS
Int nlimbs;
MP_INT *dst = (MP_INT *)(HR+2);
MP_INT *dst = (MP_INT *)(HR + 2);
CELL *ret = HR;
Int bytes;
@ -50,38 +48,33 @@ Yap_MkBigIntTerm(MP_INT *big)
// 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) {
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;
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);
MP_INT *
Yap_BigIntOfTerm(Term t)
{
MP_INT *new = (MP_INT *)(RepAppl(t)+2);
new->_mp_d = (mp_limb_t *)(new+1);
return(new);
new->_mp_d = (mp_limb_t *)(new + 1);
return (new);
}
Term
Yap_MkBigRatTerm(MP_RAT *big)
{
Term Yap_MkBigRatTerm(MP_RAT *big) {
CACHE_REGS
Int nlimbs;
MP_INT *dst = (MP_INT *)(HR+2);
MP_INT *dst = (MP_INT *)(HR + 2);
MP_INT *num = mpq_numref(big);
MP_INT *den = mpq_denref(big);
MP_RAT *rat;
@ -89,84 +82,76 @@ Yap_MkBigRatTerm(MP_RAT *big)
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) {
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_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);
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 = (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));
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_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_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 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);
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)
{
Term Yap_AllocExternalDataInStack(CELL tag, size_t bytes, CELL **pt) {
CACHE_REGS
Int nlimbs;
MP_INT *dst = (MP_INT *)(HR+2);
MP_INT *dst = (MP_INT *)(HR + 2);
CELL *ret = HR;
nlimbs = ALIGN_BY_TYPE(bytes,CELL)/CellSize;
if (nlimbs > (ASP-ret)-1024) {
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 = (CELL *)(dst + 1) + nlimbs;
HR[0] = EndSpecials;
HR++;
if (tag != EXTERNAL_BLOB) {
TrailTerm(TR) = AbsPair(ret);
TR++;
}
*pt = (CELL *)(dst + 1);
return AbsAppl(ret);
}
int Yap_CleanOpaqueVariable(CELL *pt)
{
int Yap_CleanOpaqueVariable(CELL d) {
CELL blob_info, blob_tag;
MP_INT *blobp;
CELL *pt = RepAppl(HeadOfTerm(d));
#ifdef DEBUG
/* sanity checking */
if (pt[0] != (CELL)FunctorBigInt) {
@ -175,23 +160,20 @@ int Yap_CleanOpaqueVariable(CELL *pt)
}
#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);
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;
blobp = (MP_INT *)(pt+2);
if (!GLOBAL_OpaqueHandlers[blob_info].fail_handler)
return TRUE;
return (GLOBAL_OpaqueHandlers[blob_info].fail_handler)((void *)(blobp+1));
return true;
return (GLOBAL_OpaqueHandlers[blob_info].fail_handler)(d);
}
Opaque_CallOnWrite
Yap_blob_write_handler(Term t)
{
YAP_Opaque_CallOnWrite Yap_blob_write_handler(Term t) {
CELL blob_info, blob_tag;
CELL *pt = RepAppl(t);
@ -203,9 +185,9 @@ Yap_blob_write_handler(Term t)
}
#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);
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;
@ -215,9 +197,7 @@ Yap_blob_write_handler(Term t)
return GLOBAL_OpaqueHandlers[blob_info].write_handler;
}
Opaque_CallOnGCMark
Yap_blob_gc_mark_handler(Term t)
{
YAP_Opaque_CallOnGCMark Yap_blob_gc_mark_handler(Term t) {
CELL blob_info, blob_tag;
CELL *pt = RepAppl(t);
@ -229,19 +209,16 @@ Yap_blob_gc_mark_handler(Term t)
}
#endif
blob_tag = pt[1];
if (blob_tag < USER_BLOB_START ||
blob_tag >= USER_BLOB_END) {
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].gc_mark_handler;
return GLOBAL_OpaqueHandlers[blob_info].mark_handler;
}
Opaque_CallOnGCRelocate
Yap_blob_gc_relocate_handler(Term t)
{
YAP_Opaque_CallOnGCRelocate Yap_blob_gc_relocate_handler(Term t) {
CELL blob_info, blob_tag;
CELL *pt = RepAppl(t);
@ -253,19 +230,18 @@ Yap_blob_gc_relocate_handler(Term t)
}
#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);
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].gc_relocate_handler;
return GLOBAL_OpaqueHandlers[blob_info].relocate_handler;
}
extern Int Yap_blob_tag(Term t)
{
extern Int Yap_blob_tag(Term t) {
CELL *pt = RepAppl(t);
#ifdef DEBUG
@ -278,9 +254,7 @@ extern Int Yap_blob_tag(Term t)
return pt[1];
}
void *
Yap_blob_info(Term t)
{
void *Yap_blob_info(Term t) {
MP_INT *blobp;
CELL *pt = RepAppl(t);
@ -293,88 +267,83 @@ Yap_blob_info(Term t)
#endif
if (!GLOBAL_OpaqueHandlers)
return FALSE;
blobp = (MP_INT *)(pt+2);
return (void *)(blobp+1);
blobp = (MP_INT *)(pt + 2);
return (void *)(blobp + 1);
}
Term
Yap_MkULLIntTerm(YAP_ULONG_LONG n)
{
Term Yap_MkULLIntTerm(YAP_ULONG_LONG n) {
#if __GNUC__ && USE_GMP
mpz_t new;
char tmp[256];
Term t;
mpz_t new;
char tmp[256];
Term t;
#ifdef _WIN32
snprintf(tmp,256,"%I64u",n);
snprintf(tmp, 256, "%I64u", n);
#elif HAVE_SNPRINTF
snprintf(tmp,256,"%llu",n);
snprintf(tmp, 256, "%llu", n);
#else
sprintf(tmp,"%llu",n);
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
/* try to scan it as a bignum */
mpz_init_set_str(new, tmp, 10);
if (mpz_fits_slong_p(new)) {
CACHE_REGS
return MkIntegerTerm(n);
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 *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);
sz = sizeof(MP_INT) + 2 * CellSize +
((MP_INT *)(ptr + 2))->_mp_alloc * sizeof(mp_limb_t);
} else { /* string */
sz = sizeof(CELL)*(2+ptr[1]);
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) );
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);
MP_INT *new = (MP_INT *)(RepAppl(t) + 2);
new->_mp_d = (mp_limb_t *)(new+1);
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 Yap_OpaqueTermToString(Term t, char *str, size_t max) {
size_t str_index = 0;
CELL * li = RepAppl(t);
CELL *li = RepAppl(t);
unsigned char *ptr = (unsigned char *)StringOfTerm(AbsAppl(li));
if (li[0] == (CELL)FunctorString) {
str_index += sprintf(& str[str_index], "\"");
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);
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, "\"");
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], "{...}");
str_index += sprintf(&str[str_index], "{...}");
#ifdef USE_GMP
} else if (big_tag == BIG_INT) {
MP_INT *big = Yap_BigIntOfTerm(AbsAppl(li));
@ -398,52 +367,35 @@ Yap_OpaqueTermToString(Term t, char *str, size_t max)
return;
}
} */
str_index += sprintf(& str[str_index], "0");
str_index += sprintf(&str[str_index], "0");
}
return str_index;
}
static Int
p_is_bignum( USES_REGS1 )
{
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
);
return (IsNonVarTerm(t) && IsApplTerm(t) &&
FunctorOfTerm(t) == FunctorBigInt && RepAppl(t)[1] == BIG_INT);
#else
return FALSE;
#endif
}
static Int
p_is_string( USES_REGS1 )
{
static Int p_is_string(USES_REGS1) {
Term t = Deref(ARG1);
return(
IsNonVarTerm(t) &&
IsApplTerm(t) &&
FunctorOfTerm(t) == FunctorString
);
return (IsNonVarTerm(t) && IsApplTerm(t) &&
FunctorOfTerm(t) == FunctorString);
}
static Int
p_nb_set_bit( USES_REGS1 )
{
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
))
if (!(IsNonVarTerm(t) && IsApplTerm(t) && FunctorOfTerm(t) == FunctorBigInt &&
RepAppl(t)[1] == BIG_INT))
return FALSE;
if (!IsIntegerTerm(ti)) {
return FALSE;
@ -462,9 +414,7 @@ p_nb_set_bit( USES_REGS1 )
#endif
}
static Int
p_has_bignums( USES_REGS1 )
{
static Int p_has_bignums(USES_REGS1) {
#ifdef USE_GMP
return TRUE;
#else
@ -472,9 +422,7 @@ p_has_bignums( USES_REGS1 )
#endif
}
static Int
p_is_opaque( USES_REGS1 )
{
static Int p_is_opaque(USES_REGS1) {
Term t = Deref(ARG1);
if (IsVarTerm(t))
return FALSE;
@ -485,14 +433,12 @@ p_is_opaque( USES_REGS1 )
if (f != FunctorBigInt)
return FALSE;
pt = RepAppl(t);
return ( pt[1] != BIG_RATIONAL || pt[1] != BIG_INT );
return (pt[1] != BIG_RATIONAL || pt[1] != BIG_INT);
}
return FALSE;
}
static Int
p_is_rational( USES_REGS1 )
{
static Int p_is_rational(USES_REGS1) {
Term t = Deref(ARG1);
if (IsVarTerm(t))
return FALSE;
@ -507,14 +453,12 @@ p_is_rational( USES_REGS1 )
if (f != FunctorBigInt)
return FALSE;
pt = RepAppl(t);
return ( pt[1] == BIG_RATIONAL || pt[1] == BIG_INT );
return (pt[1] == BIG_RATIONAL || pt[1] == BIG_INT);
}
return FALSE;
}
static Int
p_rational( USES_REGS1 )
{
static Int p_rational(USES_REGS1) {
#ifdef USE_GMP
Term t = Deref(ARG1);
Functor f;
@ -534,37 +478,32 @@ p_rational( USES_REGS1 )
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);
(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);
return Yap_unify(ARG2, t1) && Yap_unify(ARG3, t2);
#else
return FALSE;
#endif
}
void
Yap_InitBigNums(void)
{
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_)
/** @pred rational( _T_)
Checks whether `T` is a rational number.
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);

25
C/c_interface.c
View File

@ -1865,7 +1865,8 @@ X_API Int YAP_RunGoal(Term t) {
}
X_API Term YAP_AllocExternalDataInStack(size_t bytes) {
Term t = Yap_AllocExternalDataInStack(EXTERNAL_BLOB, bytes);
CELL *pt;
Term t = Yap_AllocExternalDataInStack(EXTERNAL_BLOB, bytes, &pt);
if (t == TermNil)
return 0L;
return t;
@ -1883,7 +1884,7 @@ X_API YAP_opaque_tag_t YAP_NewOpaqueType(struct YAP_opaque_handler_struct *f) {
int i;
if (!GLOBAL_OpaqueHandlers) {
GLOBAL_OpaqueHandlers =
malloc(sizeof(opaque_handler_t) * (USER_BLOB_END - USER_BLOB_START));
malloc(sizeof(YAP_opaque_handler_t) * (USER_BLOB_END - USER_BLOB_START));
if (!GLOBAL_OpaqueHandlers) {
/* no room */
return -1;
@ -1893,14 +1894,28 @@ X_API YAP_opaque_tag_t YAP_NewOpaqueType(struct YAP_opaque_handler_struct *f) {
return -1;
}
i = GLOBAL_OpaqueHandlersCount++;
memcpy(GLOBAL_OpaqueHandlers + i, f, sizeof(opaque_handler_t));
memcpy(GLOBAL_OpaqueHandlers + i, f, sizeof(YAP_opaque_handler_t));
return i + USER_BLOB_START;
}
X_API Term YAP_NewOpaqueObject(YAP_opaque_tag_t tag, size_t bytes) {
Term t = Yap_AllocExternalDataInStack((CELL) tag, bytes);
X_API Term YAP_NewOpaqueObject(YAP_opaque_tag_t blob_tag, size_t bytes) {
CELL *pt;
Term t = Yap_AllocExternalDataInStack((CELL) blob_tag, bytes, &pt);
if (t == TermNil)
return 0L;
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;
}
YAP_opaque_tag_t blob_info = blob_tag - USER_BLOB_START;
if (GLOBAL_OpaqueHandlers[blob_info].cut_handler ||
GLOBAL_OpaqueHandlers[blob_info].fail_handler ) {
*HR++ = t;
*HR++ = TermNil;
TrailTerm(TR) = AbsPair(HR-2);
}
return t;
}

574
C/exec.c
View File

@ -22,7 +22,6 @@ static char SccsId[] = "@(#)cdmgr.c 1.1 05/02/98";
#include "attvar.h"
#include "cut_c.h"
#include "yapio.h"
#include "yapio.h"
static bool CallPredicate(PredEntry *, choiceptr, yamop *CACHE_TYPE);
// must hold thread worker comm lock at call.
@ -48,7 +47,7 @@ static choiceptr cp_from_integer(Term cpt USES_REGS) {
*/
Term Yap_cp_as_integer(choiceptr cp) {
CACHE_REGS
return cp_as_integer(cp PASS_REGS);
return cp_as_integer(cp PASS_REGS);
}
/**
@ -128,7 +127,7 @@ inline static bool CallMetaCall(Term t, Term mod USES_REGS) {
*/
Term Yap_ExecuteCallMetaCall(Term g, Term mod) {
CACHE_REGS
Term ts[4];
Term ts[4];
ts[0] = g;
ts[1] = cp_as_integer(B PASS_REGS); /* p_current_choice_point */
ts[2] = g;
@ -141,8 +140,8 @@ Term Yap_ExecuteCallMetaCall(Term g, Term mod) {
Term Yap_PredicateIndicator(Term t, Term mod) {
CACHE_REGS
// generate predicate indicator in this case
Term ti[2];
// generate predicate indicator in this case
Term ti[2];
t = Yap_YapStripModule(t, &mod);
if (IsApplTerm(t) && !IsExtensionFunctor(FunctorOfTerm(t))) {
ti[0] = MkAtomTerm(NameOfFunctor(FunctorOfTerm(t)));
@ -215,7 +214,7 @@ static Int save_env_b(USES_REGS1) {
static PredEntry *new_pred(Term t, Term tmod, char *pname) {
Term t0 = t;
restart:
restart:
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, t0, pname);
return NULL;
@ -315,7 +314,7 @@ inline static bool do_execute(Term t, Term mod USES_REGS) {
/* I cannot use the standard macro here because
otherwise I would dereference the argument and
might skip a svar */
if (pen->PredFlags & (MetaPredFlag|UndefPredFlag)) {
if (pen->PredFlags & (MetaPredFlag | UndefPredFlag)) {
return CallMetaCall(t, mod PASS_REGS);
}
pt = RepAppl(t) + 1;
@ -393,7 +392,7 @@ inline static bool do_execute_n(Term t, Term mod, unsigned int n USES_REGS) {
int j = -n;
Term t0 = t;
restart_exec:
restart_exec:
if (IsVarTerm(t)) {
return CallError(INSTANTIATION_ERROR, t0, mod PASS_REGS);
} else if (IsAtomTerm(t)) {
@ -432,8 +431,8 @@ inline static bool do_execute_n(Term t, Term mod, unsigned int n USES_REGS) {
}
if (Yap_has_a_signal() && !LOCAL_InterruptsDisabled) {
return EnterCreepMode(
copy_execn_to_heap(f, pt, n, arity, CurrentModule PASS_REGS),
mod PASS_REGS);
copy_execn_to_heap(f, pt, n, arity, CurrentModule PASS_REGS),
mod PASS_REGS);
}
if (arity > MaxTemps) {
return CallError(TYPE_ERROR_CALLABLE, t, mod PASS_REGS);
@ -441,7 +440,7 @@ inline static bool do_execute_n(Term t, Term mod, unsigned int n USES_REGS) {
pen = RepPredProp(PredPropByFunc(f, mod));
/* You thought we would be over by now */
/* but no meta calls require special preprocessing */
if (pen->PredFlags & (MetaPredFlag|UndefPredFlag)) {
if (pen->PredFlags & (MetaPredFlag | UndefPredFlag)) {
Term t = copy_execn_to_heap(f, pt, n, arity, mod PASS_REGS);
return (CallMetaCall(t, mod PASS_REGS));
}
@ -650,7 +649,7 @@ static Int execute_clause(USES_REGS1) { /* '$execute_clause'(Goal) */
yamop *code;
Term clt = Deref(ARG3);
restart_exec:
restart_exec:
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, ARG3, "call/1");
return FALSE;
@ -712,26 +711,6 @@ static Int execute_in_mod(USES_REGS1) { /* '$execute'(Goal) */
return do_execute(Deref(ARG1), Deref(ARG2) PASS_REGS);
}
typedef enum {
CALLED_FROM_CALL = 0x1,
CALLED_FROM_ANSWER = 0x2,
CALLED_FROM_EXIT = 0x4,
CALLED_FROM_RETRY = 0x8,
CALLED_FROM_FAIL = 0x18,
CALLED_FROM_CUT = 0x20,
CALLED_FROM_EXCEPTION = 0x40,
CALLED_FROM_THROW = 0x80
} execution_port;
INLINE_ONLY inline bool called_from_forward(execution_port port) {
return port & (CALLED_FROM_EXIT | CALLED_FROM_CALL | CALLED_FROM_ANSWER |
CALLED_FROM_CUT | CALLED_FROM_THROW);
}
INLINE_ONLY inline bool called_from_backward(execution_port port) {
return port & (CALLED_FROM_RETRY | CALLED_FROM_FAIL | CALLED_FROM_EXCEPTION);
}
/**
* remove choice points created since a call to top-goal.
*
@ -762,6 +741,7 @@ static void prune_inner_computation(choiceptr parent) {
CP = oCP;
ENV = LCL0 - oENV;
}
/**
* restore abstract machine state
* after completing a computation.
@ -789,160 +769,95 @@ static void complete_inner_computation(choiceptr old_B) {
ENV = myB->cp_env;
}
static inline Term *GetTermAddress(CELL a) {
Term *b = NULL;
restart:
if (!IsVarTerm(a)) {
return (b);
} else if (a == (CELL)b) {
return (b);
} else {
b = (CELL *)a;
a = *b;
goto restart;
}
}
static Int Yap_ignore(Term t USES_REGS) {
yamop *oP = P, *oCP = CP;
Int oENV = LCL0 - ENV;
Int oYENV = LCL0 - YENV;
Int oB = LCL0 - (CELL *)B;
bool rc = Yap_RunTopGoal(t, false);
/**
* call a cleanup routine taking care with the status variable.
*/
static bool call_cleanup(Term t3, Term t4, Term cleanup,
choiceptr B0 USES_REGS) {
CELL *pt = GetTermAddress(t3);
DBTerm *ball = Yap_RefToException();
if (pt == NULL)
if (Yap_RaiseException()) {
P = oP;
CP = oCP;
ENV = LCL0 - oENV;
YENV = LCL0 - oYENV;
B = (choiceptr)(LCL0-oB);
return false;
*pt = cleanup;
bool out = Yap_RunTopGoal(t4, true);
if (out) {
prune_inner_computation(B0);
}
if (!rc) {
complete_inner_computation((choiceptr)(LCL0 - oB));
// We'll pass it through
} else {
complete_inner_computation(B0);
prune_inner_computation((choiceptr)(LCL0 - oB));
}
pt = GetTermAddress(t3);
if (ball)
Yap_CopyException(ball);
if (pt == NULL) {
return false;
}
RESET_VARIABLE(pt);
P = oP;
CP = oCP;
ENV = LCL0 - oENV;
YENV = LCL0 - oYENV;
B = (choiceptr)(LCL0 - oB);
return true;
}
/**
* What to do when we exit a protected call
* @method exit_set_call
* @param exec_result result of call (0 or 1)
* @param b0 original choicepointer (pointed to by root)
* @param t3 state
* @param b0 user goal to call on port.
*
* @param USES_REGS [description]
* @return [description]
*/
static bool exit_set_call(execution_port exec_result, choiceptr B0, yamop *oCP,
Term t3, Term t4 USES_REGS) {
Term rc;
switch (exec_result) {
// we failed
// Exception: we'll pass it through
case CALLED_FROM_EXCEPTION:
// internal exception
{
Term ball = Yap_PeekException();
Term signal = Yap_MkApplTerm(FunctorException, 1, &ball);
rc = signal;
B = B0;
}
break;
case CALLED_FROM_THROW:
// internal exception
{
Term ball = Yap_PeekException();
Term signal = Yap_MkApplTerm(FunctorException, 1, &ball);
rc = signal;
B = B0;
}
break;
case CALLED_FROM_RETRY:
// external exception
rc = TermRetry;
// internal failure
return true;
break;
case CALLED_FROM_FAIL:
B = B0;
rc = TermFail;
break;
case CALLED_FROM_EXIT:
// deterministic exit
rc = TermExit;
if (B->cp_b == B0) {
CP = B->cp_cp;
ENV = B->cp_env;
ASP = (CELL *)B;
B = B0;
}
break;
case CALLED_FROM_CUT:
if (B->cp_b == B0) {
CP = B->cp_cp;
ENV = B->cp_env;
ASP = (CELL *)B;
B = B0;
}
rc = TermCut;
break;
case CALLED_FROM_CALL:
// cut exit
rc = TermCall;
break;
case CALLED_FROM_ANSWER:
// cut exit
rc = TermAnswer;
// non deterministic
choiceptr saved_b = B;
CELL *pt = ASP;
CUT_C_PUSH(
NEXTOP(NEXTOP(PredProtectStack->cs.p_code.FirstClause, OtapFs), OtapFs),
pt); // this is where things get complicated, we need to
// protect the stack and be able to backtrack
pt -= 4;
pt[3] = t4;
pt[2] = t3;
pt[1] = MkAddressTerm(oCP);
pt[0] = MkIntegerTerm(LCL0 - (CELL *)B0);
B = (choiceptr)pt;
B--;
B->cp_h = HR;
B->cp_tr = TR;
B->cp_cp = oCP;
B->cp_ap = NEXTOP(PredProtectStack->cs.p_code.FirstClause, OtapFs);
B->cp_env = ENV;
B->cp_b = saved_b;
#ifdef DEPTH_LIMIT
B->cp_depth = saved_b->cp_depth;
#endif /* DEPTH_LIMIT */
YENV = ASP = (CELL *)B;
YENV[E_CB] = (CELL)B;
HB = HR;
return true;
}
call_cleanup(t3, t4, rc, B PASS_REGS);
extern void *Yap_blob_info(Term t);
static bool set_watch(Int Bv, Term task) {
CELL *pt;
Term t = Yap_AllocExternalDataInStack((CELL)setup_call_catcher_cleanup_tag,
sizeof(Int), &pt);
if (t == TermNil)
return false;
*pt = Bv;
*HR++ = t;
*HR++ = task;
TrailTerm(TR) = AbsPair(HR - 2);
TR++;
return true;
}
static Int protect_stack_from_cut(USES_REGS1) {
static bool watch_cut(Term ext USES_REGS) {
// called after backtracking..
/* reinitialize the engine */
/* the first real choice-point will also have AP=FAIL */
/* always have an empty slots for people to use */
YENV = ASP = (CELL *)B;
call_cleanup(B->cp_a3, B->cp_a4, (P == FAILCODE ? TermException : TermCut),
B PASS_REGS);
//
Term task = TailOfTerm(ext);
Term box = ArgOfTerm(1, task);
Term port = ArgOfTerm(2, task);
Term cleanup = ArgOfTerm(3, task);
Term cleaned = ArgOfTerm(6, task);
bool first = Deref(ArgOfTerm(5, task)) == MkIntTerm(0);
bool done = first && !IsVarTerm(Deref(ArgOfTerm(4, task)));
bool previous = !IsVarTerm(Deref(ArgOfTerm(6, task)));
if (done || previous)
return true;
while (B->cp_ap->opc == FAIL_OPCODE)
B = B->cp_b;
if (Yap_HasException()) {
Term e = Yap_GetException();
Term t;
if (first) {
t = Yap_MkApplTerm(FunctorException, 1, &e);
} else {
t = Yap_MkApplTerm(FunctorExternalException, 1, &e);
}
if (!Yap_unify(port, t))
return false;
} else {
if (!Yap_unify(port, TermCut))
return false;
}
if (IsVarTerm(cleaned) && box != TermTrue)
{
*VarOfTerm(cleaned) = Deref(port);
}
else
{
return true;
}
Yap_ignore(cleanup);
if (Yap_RaiseException())
return false;
return true;
}
@ -953,57 +868,68 @@ static Int protect_stack_from_cut(USES_REGS1) {
* @method protect_stack_from_restore
* @param USES_REGS1 [env for threaded execution]
* @return c
[next answer]
*/
static Int protect_stack_from_retry(USES_REGS1) {
*/
static bool watch_retry(Term d0 USES_REGS) {
// called after backtracking..
//
yamop *oP = P;
Int oENV = LCL0 - ENV;
yamop *oCP = (yamop *)AddressOfTerm(B->cp_a2);
Term t3 = B->cp_a3;
Term t4 = B->cp_a4;
Int b0 = IntegerOfTerm(ARG1);
choiceptr B0 = (choiceptr)(LCL0 - b0);
CELL d = ((CELL *)Yap_blob_info(HeadOfTerm(d0)))[0];
cut_c_pop();
choiceptr B0 = (choiceptr)(LCL0 - d);
Term task = TailOfTerm(d0);
Term box = ArgOfTerm(1, task);
Term cleanup = ArgOfTerm(3, task);
Term port = ArgOfTerm(2, task);
Term cleaned = ArgOfTerm(6, task);
bool first = Deref(ArgOfTerm(5, task)) == MkIntTerm(0);
bool done = first && !IsVarTerm(Deref(ArgOfTerm(4, task)));
bool previous = !IsVarTerm(Deref(ArgOfTerm(6, task)));
bool ex = false;
// call_cleanup(t3, t4, TermRetry, B0 USES_REGS);
// binding to t3 should be undone
// by next backtrack.
/* first, destroy the current choice-point,
*/
B = B->cp_b;
// B should lead to CP with _ystop,,
P = FAILCODE;
bool res = Yap_exec_absmi(false, CurrentModule);
/* reinitialize the engine */
/* the first real choice-point will also have AP=FAIL */
/* always have an empty slots for people to use */
// ensure that we have slots where we need the
execution_port p;
if (res) {
if (Yap_HasException()) {
p = CALLED_FROM_THROW;
} else if (B->cp_b >= B0) {
p = CALLED_FROM_EXIT;
} else
p = CALLED_FROM_ANSWER;
} else {
if (Yap_HasException())
p = CALLED_FROM_EXCEPTION;
if (done || previous)
return true;
while (B->cp_ap->opc == FAIL_OPCODE)
B = B->cp_b;
if (Yap_HasException())
{
Term e = Yap_GetException();
Term t;
ex = true;
if (first)
{
t = Yap_MkApplTerm(FunctorException, 1, &e);
}
else
p = CALLED_FROM_FAIL;
{
t = Yap_MkApplTerm(FunctorExternalException, 1, &e);
}
if (!Yap_unify(port, t))
return false;
}
Int rc = exit_set_call(p, B0, oCP, t3, t4 PASS_REGS);
if (rc) {
CP = oCP;
P = oP;
ENV = LCL0 - oENV;
}
if (Yap_RaiseException())
else if(B < B0)
{
if (box != TermTrue) {
return true;
}
if (!Yap_unify(port, TermRetry)) {
return false;
return res;
}
} else if (first) {
if (!Yap_unify(port, TermFail))
return false;
} else {
return true;
}
if (IsVarTerm(cleaned) && box != TermTrue) {
*VarOfTerm(cleaned) = Deref(port);
} else {
return true;
}
Yap_ignore(cleanup);
if (!ex && Yap_RaiseException())
return false;
return true;
}
/**
@ -1014,24 +940,14 @@ static Int protect_stack_from_retry(USES_REGS1) {
* @param USES_REGS1 [env for threaded execution]
* @return [always succeed]
*/
static Int protect_stack(USES_REGS1) {
// just create the choice-point;
return true;
}
static Int setup_call_catcher_cleanup(USES_REGS1) {
Term Setup = Deref(ARG1);
Int oENV = LCL0 - ENV;
choiceptr B0 = B;
Term t3, t4;
yhandle_t hl = Yap_StartSlots();
yhandle_t h2 = Yap_InitHandle(ARG2);
yhandle_t h3 = Yap_InitHandle(t3 = Deref(ARG3));
yhandle_t h4 = Yap_InitHandle(ARG4);
yamop *oCP = CP, *oP = P;
yamop *oP = P, *oCP = CP;
Int oENV = LCL0 - ENV;
Int oYENV = LCL0 - YENV;
bool rc;
execution_port port;
Yap_DisableInterrupts(worker_id);
rc = Yap_RunTopGoal(Setup, false);
@ -1048,51 +964,67 @@ static Int setup_call_catcher_cleanup(USES_REGS1) {
} else {
prune_inner_computation(B0);
}
// at this point starts actual goal execution....
rc = Yap_RunTopGoal(Yap_GetFromSlot(h2), false);
complete_inner_computation(B);
t4 = Yap_GetFromSlot(h4);
t3 = Yap_GetFromSlot(h3);
// make sure that t3 point to our nice cell.
Yap_CloseSlots(hl);
P = oP;
CP = oCP;
ENV = LCL0 - oENV;
YENV = LCL0 - oYENV;
return rc;
}
if (rc) {
// ignore empty choice
static Int tag_cleanup(USES_REGS1)
{
Int iB = LCL0 - (CELL *)B;
set_watch(iB, Deref(ARG2));
return Yap_unify(ARG1, MkIntegerTerm(iB));
}
static Int cleanup_on_exit(USES_REGS1)
{
choiceptr B0 = (choiceptr)(LCL0 - IntegerOfTerm(Deref(ARG1)));
Term task = Deref(ARG2);
Term box = ArgOfTerm(1, task);
Term cleanup = ArgOfTerm(3, task);
Term catcher = ArgOfTerm(2, task);
Term tag = ArgOfTerm(4, task);
Term cleaned = ArgOfTerm(6, task);
while (B->cp_ap->opc == FAIL_OPCODE)
B = B->cp_b;
if (Yap_HasException()) {
port = CALLED_FROM_THROW;
} else if (B->cp_b < B0) {
port = CALLED_FROM_ANSWER;
} else {
port = CALLED_FROM_EXIT;
if (B < B0)
{
// non-deterministic
set_watch(LCL0 - (CELL *)B, task);
if (box == TermTrue)
{
if (!Yap_unify(catcher, TermAnswer))
return false;
B->cp_tr++;
Yap_ignore(cleanup);
B->cp_tr--;
}
return true;
}
if (!Yap_unify(catcher, TermExit))
return false;
if (IsVarTerm(tag))
*VarOfTerm(tag) = TermTrue;
if (IsVarTerm(cleaned) && box != TermTrue)
{
*VarOfTerm(cleaned) = TermExit;
}
} else {
if (Yap_HasException())
port = CALLED_FROM_EXCEPTION;
else
port = CALLED_FROM_FAIL;
}
// store the correct CP, ENV can be recovered from last env.
bool e = exit_set_call(port, B0, oCP, t3, t4 PASS_REGS);
// ensure we have same P
// also, we cannot trust recovered ENV and CP
if (e) {
P = oP;
CP = oCP;
ENV = LCL0 - oENV;
}
if (Yap_RaiseException()) {
return false;
}
return rc;
{
return true;
}
Yap_ignore(cleanup);
return true;
}
static bool complete_ge(bool out, Term omod, yhandle_t sl, bool creeping) {
CACHE_REGS
if (creeping) {
Yap_signal(YAP_CREEP_SIGNAL);
}
if (creeping) {
Yap_signal(YAP_CREEP_SIGNAL);
}
CurrentModule = omod;
Yap_CloseSlots(sl);
if (out) {
@ -1122,7 +1054,7 @@ static Int _user_expand_goal(USES_REGS1) {
ARG1 = Yap_MkApplTerm(FunctorModule, 2, mg_args);
ARG2 = Yap_GetFromSlot(h2);
if ((pe = RepPredProp(
Yap_GetPredPropByFunc(FunctorGoalExpansion2, SYSTEM_MODULE))) &&
Yap_GetPredPropByFunc(FunctorGoalExpansion2, SYSTEM_MODULE))) &&
pe->OpcodeOfPred != FAIL_OPCODE && pe->OpcodeOfPred != UNDEF_OPCODE &&
Yap_execute_pred(pe, NULL, false PASS_REGS)) {
return complete_ge(true, omod, sl, creeping);
@ -1132,7 +1064,7 @@ static Int _user_expand_goal(USES_REGS1) {
ARG3 = Yap_GetFromSlot(h2);
/* user:goal_expansion(A,CurMod,B) */
if ((pe = RepPredProp(
Yap_GetPredPropByFunc(FunctorGoalExpansion, USER_MODULE))) &&
Yap_GetPredPropByFunc(FunctorGoalExpansion, USER_MODULE))) &&
pe->OpcodeOfPred != FAIL_OPCODE && pe->OpcodeOfPred != UNDEF_OPCODE &&
Yap_execute_pred(pe, NULL PASS_REGS, false)) {
return complete_ge(true, omod, sl, creeping);
@ -1144,7 +1076,7 @@ static Int _user_expand_goal(USES_REGS1) {
/* user:goal_expansion(A,B) */
if (cmod != USER_MODULE && /* we have tried this before */
(pe = RepPredProp(
Yap_GetPredPropByFunc(FunctorGoalExpansion2, USER_MODULE))) &&
Yap_GetPredPropByFunc(FunctorGoalExpansion2, USER_MODULE))) &&
pe->OpcodeOfPred != FAIL_OPCODE && pe->OpcodeOfPred != UNDEF_OPCODE &&
Yap_execute_pred(pe, NULL PASS_REGS, false)) {
return complete_ge(true, omod, sl, creeping);
@ -1164,7 +1096,7 @@ static Int do_term_expansion(USES_REGS1) {
ARG1 = g;
if ((pe = RepPredProp(
Yap_GetPredPropByFunc(FunctorTermExpansion, USER_MODULE))) &&
Yap_GetPredPropByFunc(FunctorTermExpansion, USER_MODULE))) &&
pe->OpcodeOfPred != FAIL_OPCODE && pe->OpcodeOfPred != UNDEF_OPCODE &&
Yap_execute_pred(pe, NULL, false PASS_REGS)) {
return complete_ge(true, omod, sl, creeping);
@ -1183,7 +1115,7 @@ static Int do_term_expansion(USES_REGS1) {
ARG1 = Yap_MkApplTerm(FunctorModule, 2, mg_args);
ARG2 = Yap_GetFromSlot(h2);
if ((pe = RepPredProp(
Yap_GetPredPropByFunc(FunctorTermExpansion, SYSTEM_MODULE))) &&
Yap_GetPredPropByFunc(FunctorTermExpansion, SYSTEM_MODULE))) &&
pe->OpcodeOfPred != FAIL_OPCODE && pe->OpcodeOfPred != UNDEF_OPCODE &&
Yap_execute_pred(pe, NULL, false PASS_REGS)) {
return complete_ge(true, omod, sl, creeping);
@ -1201,7 +1133,7 @@ static Int execute0(USES_REGS1) { /* '$execute0'(Goal,Mod) */
return EnterCreepMode(t, mod PASS_REGS);
}
t = Yap_YapStripModule(t, &mod);
restart_exec:
restart_exec:
if (IsVarTerm(t)) {
Yap_Error(INSTANTIATION_ERROR, ARG3, "call/1");
return false;
@ -1451,7 +1383,7 @@ static bool exec_absmi(bool top, yap_reset_t reset_mode USES_REGS) {
/* reset the registers so that we don't have trash in abstract
* machine */
Yap_set_fpu_exceptions(
getAtomicGlobalPrologFlag(ARITHMETIC_EXCEPTIONS_FLAG));
getAtomicGlobalPrologFlag(ARITHMETIC_EXCEPTIONS_FLAG));
P = (yamop *)FAILCODE;
LOCAL_PrologMode = UserMode;
} break;
@ -1465,28 +1397,28 @@ static bool exec_absmi(bool top, yap_reset_t reset_mode USES_REGS) {
/* can be called from anywhere, must reset registers,
*/
while (B) {
Yap_JumpToEnv(TermDAbort);
}
LOCAL_PrologMode &= ~AbortMode;
Yap_JumpToEnv(TermDAbort);
}
LOCAL_PrologMode &= ~AbortMode;
P = (yamop *)FAILCODE;
if (LOCAL_CBorder)
LOCAL_CBorder = OldBorder;
LOCAL_CBorder = OldBorder;
LOCAL_RestartEnv = sighold;
return false;
return false;
break;
case 5:
// going up, unless there is no up to go to. or someone
// but we should inform the caller on what happened.
if (B && B->cp_b && B->cp_b <= (choiceptr)(LCL0-LOCAL_CBorder)) {
break;
if (B && B->cp_b && B->cp_b <= (choiceptr)(LCL0 - LOCAL_CBorder)) {
break;
}
LOCAL_RestartEnv = sighold;
LOCAL_PrologMode = UserMode;
LOCAL_CBorder = OldBorder;
LOCAL_PrologMode = UserMode;
LOCAL_CBorder = OldBorder;
return false;
default:
/* do nothing */
LOCAL_PrologMode = UserMode;
/* do nothing */
LOCAL_PrologMode = UserMode;
}
} else {
LOCAL_PrologMode = UserMode;
@ -1570,7 +1502,7 @@ static bool do_goal(yamop *CodeAdr, int arity, CELL *pt, bool top USES_REGS) {
bool Yap_exec_absmi(bool top, yap_reset_t has_reset) {
CACHE_REGS
return exec_absmi(top, has_reset PASS_REGS);
return exec_absmi(top, has_reset PASS_REGS);
}
/**
@ -1599,7 +1531,7 @@ void Yap_fail_all(choiceptr bb USES_REGS) {
DEPTH = B->cp_depth;
#endif /* DEPTH_LIMIT */
YENV = ENV = B->cp_env;
/* recover local stack */
/* recover local stack */
#ifdef DEPTH_LIMIT
DEPTH = ENV[E_DEPTH];
#endif
@ -1711,7 +1643,7 @@ bool Yap_execute_pred(PredEntry *ppe, CELL *pt, bool pass_ex USES_REGS) {
bool Yap_execute_goal(Term t, int nargs, Term mod, bool pass_ex) {
CACHE_REGS
Prop pe;
Prop pe;
PredEntry *ppe;
CELL *pt;
/* preserve the current restart environment */
@ -1748,7 +1680,7 @@ bool Yap_execute_goal(Term t, int nargs, Term mod, bool pass_ex) {
void Yap_trust_last(void) {
CACHE_REGS
ASP = B->cp_env;
ASP = B->cp_env;
CP = B->cp_cp;
HR = B->cp_h;
#ifdef DEPTH_LIMIT
@ -1766,7 +1698,7 @@ void Yap_trust_last(void) {
Term Yap_RunTopGoal(Term t, bool handle_errors) {
CACHE_REGS
yamop *CodeAdr;
yamop *CodeAdr;
Prop pe;
PredEntry *ppe;
CELL *pt;
@ -1812,7 +1744,7 @@ Term Yap_RunTopGoal(Term t, bool handle_errors) {
HR[1] = MkAtomTerm(Yap_LookupAtom("top"));
arity = 2;
HR += 2;
} else if (ppe->PredFlags & (MetaPredFlag|UndefPredFlag)) {
} else if (ppe->PredFlags & (MetaPredFlag | UndefPredFlag)) {
// we're in a meta-call, rake care about modules
//
Term ts[2];
@ -1989,7 +1921,7 @@ static Int cut_up_to_next_disjunction(USES_REGS1) {
bool Yap_Reset(yap_reset_t mode) {
CACHE_REGS
int res = TRUE;
int res = TRUE;
Yap_ResetException(worker_id);
/* first, backtrack to the root */
@ -2038,11 +1970,8 @@ static Int JumpToEnv() {
/* find the first choicepoint that may be a catch */
// DBTerm *dbt = Yap_RefToException();
while (handler && Yap_PredForChoicePt(handler, NULL) != PredDollarCatch) {
//printf("--handler=%p, max=%p\n", handler, LCL0-LOCAL_CBorder);
while (POP_CHOICE_POINT(handler)) {
POP_FAIL_EXECUTE(handler);
}
if (handler == (choiceptr)(LCL0-LOCAL_CBorder)) {
// printf("--handler=%p, max=%p\n", handler, LCL0-LOCAL_CBorder);
if (handler == (choiceptr)(LCL0 - LOCAL_CBorder)) {
break;
}
/* we are already doing a catch */
@ -2058,6 +1987,7 @@ static Int JumpToEnv() {
}
POP_FAIL(handler);
B = handler;
// Yap_CopyException(ref);
if (Yap_PredForChoicePt(B, NULL) == PredDollarCatch) {
/* can recover Heap thanks to copy term :-( */
@ -2077,10 +2007,9 @@ static Int JumpToEnv() {
} else if (IsVarTerm(t)) {
t = Yap_MkApplTerm(FunctorGVar, 1, &t);
}
B->cp_h = HR;
HB = HR;
Yap_unify(t, B->cp_a2);
B->cp_tr = TR;
B->cp_h = HR;
TR--;
}
P = FAILCODE;
return true;
@ -2088,7 +2017,7 @@ static Int JumpToEnv() {
bool Yap_JumpToEnv(Term t) {
CACHE_REGS
LOCAL_BallTerm = Yap_StoreTermInDB(t, 0);
LOCAL_BallTerm = Yap_StoreTermInDB(t, 0);
if (!LOCAL_BallTerm)
return false;
if (LOCAL_PrologMode & TopGoalMode)
@ -2138,27 +2067,27 @@ static Int generate_pred_info(USES_REGS1) {
void Yap_InitYaamRegs(int myworker_id) {
Term h0var;
// getchar();
// getchar();
#if PUSH_REGS
/* Guarantee that after a longjmp we go back to the original abstract
machine registers */
/* Guarantee that after a longjmp we go back to the original abstract
machine registers */
#ifdef THREADS
if (myworker_id) {
REGSTORE *rs = REMOTE_ThreadHandle(myworker_id).default_yaam_regs;
pthread_setspecific(Yap_yaamregs_key, (const void *)rs);
REMOTE_ThreadHandle(myworker_id).current_yaam_regs = rs;
}
/* may be run by worker_id on behalf on myworker_id */
/* may be run by worker_id on behalf on myworker_id */
#else
Yap_regp = &Yap_standard_regs;
#endif
#endif /* PUSH_REGS */
CACHE_REGS
Yap_ResetException(worker_id);
Yap_ResetException(worker_id);
Yap_PutValue(AtomBreak, MkIntTerm(0));
TR = (tr_fr_ptr)REMOTE_TrailBase(myworker_id);
HR = H0 = ((CELL *)REMOTE_GlobalBase(myworker_id)) +
1; // +1: hack to ensure the gc does not try to mark mistakenly
1; // +1: hack to ensure the gc does not try to mark mistakenly
LCL0 = ASP = (CELL *)REMOTE_LocalBase(myworker_id);
CurrentTrailTop = (tr_fr_ptr)(REMOTE_TrailTop(myworker_id) - MinTrailGap);
/* notice that an initial choice-point and environment
@ -2182,12 +2111,12 @@ void Yap_InitYaamRegs(int myworker_id) {
#ifdef YAPOR_SBA
BSEG =
#endif /* YAPOR_SBA */
BBREG = B_FZ = (choiceptr)REMOTE_LocalBase(myworker_id);
BBREG = B_FZ = (choiceptr)REMOTE_LocalBase(myworker_id);
TR = TR_FZ = (tr_fr_ptr)REMOTE_TrailBase(myworker_id);
#endif /* FROZEN_STACKS */
CalculateStackGap(PASS_REGS1);
/* the first real choice-point will also have AP=FAIL */
/* always have an empty slots for people to use */
/* the first real choice-point will also have AP=FAIL */
/* always have an empty slots for people to use */
#if defined(YAPOR) || defined(THREADS)
LOCAL = REMOTE(myworker_id);
worker_id = myworker_id;
@ -2202,7 +2131,7 @@ void Yap_InitYaamRegs(int myworker_id) {
REMOTE_GcGeneration(myworker_id) = Yap_NewTimedVar(h0var);
REMOTE_GcCurrentPhase(myworker_id) = 0L;
REMOTE_GcPhase(myworker_id) =
Yap_NewTimedVar(MkIntTerm(REMOTE_GcCurrentPhase(myworker_id)));
Yap_NewTimedVar(MkIntTerm(REMOTE_GcCurrentPhase(myworker_id)));
#if defined(YAPOR) || defined(THREADS)
PP = NULL;
PREG_ADDR = NULL;
@ -2215,7 +2144,7 @@ void Yap_InitYaamRegs(int myworker_id) {
#ifdef YAPOR_SBA
BSEG =
#endif /* YAPOR_SBA */
BBREG = B_FZ = (choiceptr)REMOTE_LocalBase(myworker_id);
BBREG = B_FZ = (choiceptr)REMOTE_LocalBase(myworker_id);
TR = TR_FZ = (tr_fr_ptr)REMOTE_TrailBase(myworker_id);
#endif /* FROZEN_STACKS */
CalculateStackGap(PASS_REGS1);
@ -2228,7 +2157,7 @@ void Yap_InitYaamRegs(int myworker_id) {
Term Yap_GetException(void) {
CACHE_REGS
Term t = 0;
Term t = 0;
if (LOCAL_BallTerm) {
t = Yap_PopTermFromDB(LOCAL_BallTerm);
@ -2247,8 +2176,8 @@ bool Yap_RaiseException(void) {
bool Yap_PutException(Term t) {
CACHE_REGS
if ((LOCAL_BallTerm = Yap_StoreTermInDB(t, 0)) != NULL)
return true;
if ((LOCAL_BallTerm = Yap_StoreTermInDB(t, 0)) != NULL)
return true;
return false;
}
@ -2296,7 +2225,13 @@ int Yap_dogc(int extra_args, Term *tp USES_REGS) {
void Yap_InitExecFs(void) {
CACHE_REGS
Term cm = CurrentModule;
YAP_opaque_handler_t catcher_ops;
memset(&catcher_ops, 0, sizeof(catcher_ops));
catcher_ops.cut_handler = watch_cut;
catcher_ops.fail_handler = watch_retry;
setup_call_catcher_cleanup_tag = YAP_NewOpaqueType(&catcher_ops);
Term cm = CurrentModule;
Yap_InitComma();
Yap_InitCPred("$execute", 1, execute, 0);
Yap_InitCPred("$execute", 2, execute2, 0);
@ -2350,7 +2285,8 @@ void Yap_InitExecFs(void) {
Yap_InitCPred("_user_expand_goal", 2, _user_expand_goal, 0);
Yap_InitCPred("$do_term_expansion", 2, do_term_expansion, 0);
Yap_InitCPred("$get_exception", 1, get_exception, 0);
Yap_InitCPred("setup_call_catcher_cleanup", 4, setup_call_catcher_cleanup, 0);
Yap_InitCPredBackCut("$protect_stack", 4, 0, protect_stack,
protect_stack_from_retry, protect_stack_from_cut, 0);
Yap_InitCPred("$setup_call_catcher_cleanup", 1, setup_call_catcher_cleanup,
0);
Yap_InitCPred("$cleanup_on_exit", 2, cleanup_on_exit, 0);
Yap_InitCPred("$tag_cleanup", 2, tag_cleanup, 0);
}

698
C/fail_absmi_insts.h
View File

@ -4,411 +4,457 @@
#ifdef INDENT_CODE
{
{
{
#endif /* INDENT_CODE */
/* trust_fail */
BOp(trust_fail, e);
{
while (POP_CHOICE_POINT(B->cp_b))
{
POP_EXECUTE();
}
}
/* trust_fail */
BOp(trust_fail, e);
{
while (POP_CHOICE_POINT(B->cp_b))
{
POP_EXECUTE();
}
}
#ifdef YAPOR
{
choiceptr cut_pt;
cut_pt = B->cp_b;
CUT_prune_to(cut_pt);
B = cut_pt;
}
{
choiceptr cut_pt;
cut_pt = B->cp_b;
CUT_prune_to(cut_pt);
B = cut_pt;
}
#else
B = B->cp_b;
#endif /* YAPOR */
goto fail;
ENDBOp();
B = B->cp_b;
#endif /* YAPOR */
goto fail;
ENDBOp();
#ifdef YAPOR
shared_fail:
B = Get_LOCAL_top_cp();
SET_BB(PROTECT_FROZEN_B(B));
goto fail;
#endif /* YAPOR */
shared_fail:
B = Get_LOCAL_top_cp();
SET_BB(PROTECT_FROZEN_B(B));
goto fail;
#endif /* YAPOR */
/* fail */
PBOp(op_fail, e);
/* fail */
PBOp(op_fail, e);
if (PP) {
UNLOCK(PP->PELock);
PP = NULL;
}
if (PP)
{
UNLOCK(PP->PELock);
PP = NULL;
}
#ifdef COROUTINING
CACHE_Y_AS_ENV(YREG);
check_stack(NoStackFail, HR);
ENDCACHE_Y_AS_ENV();
CACHE_Y_AS_ENV(YREG);
check_stack(NoStackFail, HR);
ENDCACHE_Y_AS_ENV();
#endif
fail:
{
fail:
{
register tr_fr_ptr pt0 = TR;
#if defined(YAPOR) || defined(THREADS)
if (PP) {
UNLOCK(PP->PELock);
PP = NULL;
if (PP)
{
UNLOCK(PP->PELock);
PP = NULL;
}
#endif
PREG = B->cp_ap;
save_pc();
CACHE_TR(B->cp_tr);
PREFETCH_OP(PREG);
failloop:
if (pt0 == S_TR) {
SP = SP0;
failloop:
if (pt0 == S_TR)
{
SP = SP0;
#ifdef LOW_LEVEL_TRACER
if (Yap_do_low_level_trace) {
int go_on = true;
yamop *ipc = PREG;
if (Yap_do_low_level_trace)
{
int go_on = true;
yamop *ipc = PREG;
while (go_on) {
op_numbers opnum = Yap_op_from_opcode(ipc->opc);
while (go_on)
{
op_numbers opnum = Yap_op_from_opcode(ipc->opc);
go_on = false;
switch (opnum) {
go_on = false;
switch (opnum)
{
#ifdef TABLING
case _table_load_answer:
low_level_trace(retry_table_loader, LOAD_CP(B)->cp_pred_entry, NULL);
break;
case _table_try_answer:
case _table_retry_me:
case _table_trust_me:
case _table_retry:
case _table_trust:
case _table_completion:
case _table_load_answer:
low_level_trace(retry_table_loader, LOAD_CP(B)->cp_pred_entry, NULL);
break;
case _table_try_answer:
case _table_retry_me:
case _table_trust_me:
case _table_retry:
case _table_trust:
case _table_completion:
#ifdef THREADS_CONSUMER_SHARING
case _table_answer_resolution_completion:
case _table_answer_resolution_completion:
#endif /* THREADS_CONSUMER_SHARING */
#ifdef DETERMINISTIC_TABLING
if (IS_DET_GEN_CP(B))
low_level_trace(retry_table_generator, DET_GEN_CP(B)->cp_pred_entry, NULL);
else
if (IS_DET_GEN_CP(B))
low_level_trace(retry_table_generator, DET_GEN_CP(B)->cp_pred_entry, NULL);
else
#endif /* DETERMINISTIC_TABLING */
low_level_trace(retry_table_generator, GEN_CP(B)->cp_pred_entry, (CELL *)(GEN_CP(B) + 1));
break;
case _table_answer_resolution:
low_level_trace(retry_table_consumer, CONS_CP(B)->cp_pred_entry, NULL);
break;
case _trie_trust_var:
case _trie_retry_var:
case _trie_trust_var_in_pair:
case _trie_retry_var_in_pair:
case _trie_trust_val:
case _trie_retry_val:
case _trie_trust_val_in_pair:
case _trie_retry_val_in_pair:
case _trie_trust_atom:
case _trie_retry_atom:
case _trie_trust_atom_in_pair:
case _trie_retry_atom_in_pair:
case _trie_trust_null:
case _trie_retry_null:
case _trie_trust_null_in_pair:
case _trie_retry_null_in_pair:
case _trie_trust_pair:
case _trie_retry_pair:
case _trie_trust_appl:
case _trie_retry_appl:
case _trie_trust_appl_in_pair:
case _trie_retry_appl_in_pair:
case _trie_trust_extension:
case _trie_retry_extension:
case _trie_trust_double:
case _trie_retry_double:
case _trie_trust_longint:
case _trie_retry_longint:
case _trie_trust_gterm:
case _trie_retry_gterm:
low_level_trace(retry_table_loader, UndefCode, NULL);
break;
low_level_trace(retry_table_generator, GEN_CP(B)->cp_pred_entry, (CELL *)(GEN_CP(B) + 1));
break;
case _table_answer_resolution:
low_level_trace(retry_table_consumer, CONS_CP(B)->cp_pred_entry, NULL);
break;
case _trie_trust_var:
case _trie_retry_var:
case _trie_trust_var_in_pair:
case _trie_retry_var_in_pair:
case _trie_trust_val:
case _trie_retry_val:
case _trie_trust_val_in_pair:
case _trie_retry_val_in_pair:
case _trie_trust_atom:
case _trie_retry_atom:
case _trie_trust_atom_in_pair:
case _trie_retry_atom_in_pair:
case _trie_trust_null:
case _trie_retry_null:
case _trie_trust_null_in_pair:
case _trie_retry_null_in_pair:
case _trie_trust_pair:
case _trie_retry_pair:
case _trie_trust_appl:
case _trie_retry_appl:
case _trie_trust_appl_in_pair:
case _trie_retry_appl_in_pair:
case _trie_trust_extension:
case _trie_retry_extension:
case _trie_trust_double:
case _trie_retry_double:
case _trie_trust_longint:
case _trie_retry_longint:
case _trie_trust_gterm:
case _trie_retry_gterm:
low_level_trace(retry_table_loader, UndefCode, NULL);
break;
#endif /* TABLING */
case _or_else:
case _or_last:
low_level_trace(retry_or, NULL, NULL);
break;
case _retry2:
case _retry3:
case _retry4:
ipc = NEXTOP(ipc,l);
go_on = true;
break;
case _jump:
ipc = ipc->y_u.l.l;
go_on = true;
break;
case _retry_c:
case _retry_userc:
low_level_trace(retry_pred, ipc->y_u.OtapFs.p, B->cp_args);
break;
case _retry_profiled:
case _count_retry:
ipc = NEXTOP(ipc,p);
go_on = true;
break;
case _retry_me:
case _trust_me:
case _count_retry_me:
case _count_trust_me:
case _profiled_retry_me:
case _profiled_trust_me:
case _retry_and_mark:
case _profiled_retry_and_mark:
case _retry:
case _trust:
low_level_trace(retry_pred, ipc->y_u.Otapl.p, B->cp_args);
break;
case _try_logical:
case _retry_logical:
case _profiled_retry_logical:
case _count_retry_logical:
case _trust_logical:
case _profiled_trust_logical:
case _count_trust_logical:
low_level_trace(retry_pred, ipc->y_u.OtILl.d->ClPred, B->cp_args);
break;
case _Nstop:
case _Ystop:
low_level_trace(retry_pred, NULL, B->cp_args);
break;
default:
break;
}
}
}
#endif /* LOW_LEVEL_TRACER */
case _or_else:
case _or_last:
low_level_trace(retry_or, NULL, NULL);
break;
case _retry2:
case _retry3:
case _retry4:
ipc = NEXTOP(ipc, l);
go_on = true;
break;
case _jump:
ipc = ipc->y_u.l.l;
go_on = true;
break;
case _retry_c:
case _retry_userc:
low_level_trace(retry_pred, ipc->y_u.OtapFs.p, B->cp_args);
break;
case _retry_profiled:
case _count_retry:
ipc = NEXTOP(ipc, p);
go_on = true;
break;
case _retry_me:
case _trust_me:
case _count_retry_me:
case _count_trust_me:
case _profiled_retry_me:
case _profiled_trust_me:
case _retry_and_mark:
case _profiled_retry_and_mark:
case _retry:
case _trust:
low_level_trace(retry_pred, ipc->y_u.Otapl.p, B->cp_args);
break;
case _try_logical:
case _retry_logical:
case _profiled_retry_logical:
case _count_retry_logical:
case _trust_logical:
case _profiled_trust_logical:
case _count_trust_logical:
low_level_trace(retry_pred, ipc->y_u.OtILl.d->ClPred, B->cp_args);
break;
case _Nstop:
case _Ystop:
low_level_trace(retry_pred, NULL, B->cp_args);
break;
default:
break;
}
}
}
#endif /* LOW_LEVEL_TRACER */
#ifdef FROZEN_STACKS
#ifdef YAPOR_SBA
if (pt0 < TR_FZ || pt0 > (ADDR)CurrentTrailTop+MinTrailGap)
if (pt0 < TR_FZ || pt0 > (ADDR)CurrentTrailTop + MinTrailGap)
#else
if (pt0 < TR_FZ)
if (pt0 < TR_FZ)
#endif /* YAPOR_SBA */
{
TR = TR_FZ;
TRAIL_LINK(pt0);
} else
{
TR = TR_FZ;
TRAIL_LINK(pt0);
}
else
#endif /* FROZEN_STACKS */
RESTORE_TR();
GONext();
RESTORE_TR();
GONext();
}
BEGD(d1);
d1 = TrailTerm(pt0-1);
d1 = TrailTerm(pt0 - 1);
pt0--;
if (IsVarTerm(d1)) {
if (IsVarTerm(d1))
{
#if defined(YAPOR_SBA) && defined(YAPOR)
/* clean up the trail when we backtrack */
if (Unsigned((Int)(d1)-(Int)(H_FZ)) >
Unsigned((Int)(B_FZ)-(Int)(H_FZ))) {
RESET_VARIABLE(STACK_TO_SBA(d1));
} else
/* clean up the trail when we backtrack */
if (Unsigned((Int)(d1) - (Int)(H_FZ)) >
Unsigned((Int)(B_FZ) - (Int)(H_FZ)))
{
RESET_VARIABLE(STACK_TO_SBA(d1));
}
else
#endif
/* normal variable */
RESET_VARIABLE(d1);
goto failloop;
/* normal variable */
RESET_VARIABLE(d1);
goto failloop;
}
/* pointer to code space */
/* or updatable variable */
/* pointer to code space */
/* or updatable variable */
#if defined(TERM_EXTENSIONS) || defined(FROZEN_STACKS) || defined(MULTI_ASSIGNMENT_VARIABLES)
if (IsPairTerm(d1))
#endif /* TERM_EXTENSIONS || FROZEN_STACKS || MULTI_ASSIGNMENT_VARIABLES */
{
register CELL flags;
CELL *pt1 = RepPair(d1);
{
register CELL flags;
CELL *pt1 = RepPair(d1);
#ifdef LIMIT_TABLING
if ((ADDR) pt1 == LOCAL_TrailBase) {
sg_fr_ptr sg_fr = (sg_fr_ptr) TrailVal(pt0);
TrailTerm(pt0) = AbsPair((CELL *)(pt0 - 1));
SgFr_state(sg_fr)--; /* complete_in_use --> complete : compiled_in_use --> compiled */
insert_into_global_sg_fr_list(sg_fr);
goto failloop;
}
#endif /* LIMIT_TABLING */
#ifdef FROZEN_STACKS /* TRAIL */
/* avoid frozen segments */
if (
#ifdef YAPOR_SBA
(ADDR) pt1 >= HeapTop
#else
IN_BETWEEN(LOCAL_TrailBase, pt1, (ADDR)CurrentTrailTop+MinTrailGap)
#endif /* YAPOR_SBA */
)
{
pt0 = (tr_fr_ptr) pt1;
goto failloop;
} else
#endif /* FROZEN_STACKS */
if (IN_BETWEEN(H0,pt1,HR)) {
if (IsAttVar(pt1)) {
goto failloop;
} else if (*pt1 == (CELL)FunctorBigInt) {
Yap_CleanOpaqueVariable(pt1);
goto failloop;
if ((ADDR)pt1 == LOCAL_TrailBase)
{
sg_fr_ptr sg_fr = (sg_fr_ptr)TrailVal(pt0);
TrailTerm(pt0) = AbsPair((CELL *)(pt0 - 1));
SgFr_state(sg_fr)--; /* complete_in_use --> complete : compiled_in_use --> compiled */
insert_into_global_sg_fr_list(sg_fr);
goto failloop;
}
}
#ifdef FROZEN_STACKS /* TRAIL */
/* don't reset frozen variables */
if (pt0 < TR_FZ)
goto failloop;
#endif /* LIMIT_TABLING */
#ifdef FROZEN_STACKS /* TRAIL */
/* avoid frozen segments */
if (
#ifdef YAPOR_SBA
(ADDR)pt1 >= HeapTop
#else
IN_BETWEEN(LOCAL_TrailBase, pt1, (ADDR)CurrentTrailTop + MinTrailGap)
#endif /* YAPOR_SBA */
)
{
pt0 = (tr_fr_ptr)pt1;
goto failloop;
}
else
#endif /* FROZEN_STACKS */
if (IN_BETWEEN(H0, pt1, HR))
{
if (IsAttVar(pt1))
{
goto failloop;
}
else
{
TR = pt0;
Yap_CleanOpaqueVariable(d1);
goto fail;
}
}
#ifdef FROZEN_STACKS /* TRAIL */
/* don't reset frozen variables */
if (pt0 < TR_FZ)
goto failloop;
#endif
flags = *pt1;
flags = *pt1;
#if MULTIPLE_STACKS
if (FlagOn(DBClMask, flags)) {
DBRef dbr = DBStructFlagsToDBStruct(pt1);
int erase;
if (FlagOn(DBClMask, flags))
{
DBRef dbr = DBStructFlagsToDBStruct(pt1);
int erase;
LOCK(dbr->lock);
DEC_DBREF_COUNT(dbr);
erase = (dbr->Flags & ErasedMask) && (dbr->ref_count == 0);
UNLOCK(dbr->lock);
if (erase) {
saveregs();
Yap_ErDBE(dbr);
setregs();
}
} else {
if (flags & LogUpdMask) {
if (flags & IndexMask) {
LogUpdIndex *cl = ClauseFlagsToLogUpdIndex(pt1);
int erase;
LOCK(dbr->lock);
DEC_DBREF_COUNT(dbr);
erase = (dbr->Flags & ErasedMask) && (dbr->ref_count == 0);
UNLOCK(dbr->lock);
if (erase)
{
saveregs();
Yap_ErDBE(dbr);
setregs();
}
}
else
{
if (flags & LogUpdMask)
{
if (flags & IndexMask)
{
LogUpdIndex *cl = ClauseFlagsToLogUpdIndex(pt1);
int erase;
#if PARALLEL_YAP
PredEntry *ap = cl->ClPred;
PredEntry *ap = cl->ClPred;
#endif
PELOCK(8,ap);
DEC_CLREF_COUNT(cl);
erase = (cl->ClFlags & ErasedMask) && !(cl->ClRefCount);
if (erase) {
saveregs();
/* at this point,
PELOCK(8, ap);
DEC_CLREF_COUNT(cl);
erase = (cl->ClFlags & ErasedMask) && !(cl->ClRefCount);
if (erase)
{
saveregs();
/* at this point,
we are the only ones accessing the clause,
hence we don't need to have a lock it */
Yap_ErLogUpdIndex(cl);
setregs();
} else if (cl->ClFlags & DirtyMask) {
saveregs();
/* at this point,
Yap_ErLogUpdIndex(cl);
setregs();
}
else if (cl->ClFlags & DirtyMask)
{
saveregs();
/* at this point,
we are the only ones accessing the clause,
hence we don't need to have a lock it */
Yap_CleanUpIndex(cl);
setregs();
}
UNLOCK(ap->PELock);
} else {
LogUpdClause *cl = ClauseFlagsToLogUpdClause(pt1);
int erase;
Yap_CleanUpIndex(cl);
setregs();
}
UNLOCK(ap->PELock);
}
else
{
LogUpdClause *cl = ClauseFlagsToLogUpdClause(pt1);
int erase;
#if PARALLEL_YAP
PredEntry *ap = cl->ClPred;
PredEntry *ap = cl->ClPred;
#endif
/* BB support */
if (ap) {
/* BB support */
if (ap)
{
PELOCK(9,ap);
DEC_CLREF_COUNT(cl);
erase = (cl->ClFlags & ErasedMask) && !(cl->ClRefCount);
if (erase) {
saveregs();
/* at this point,
PELOCK(9, ap);
DEC_CLREF_COUNT(cl);
erase = (cl->ClFlags & ErasedMask) && !(cl->ClRefCount);
if (erase)
{
saveregs();
/* at this point,
we are the only ones accessing the clause,
hence we don't need to have a lock it */
Yap_ErLogUpdCl(cl);
setregs();
}
UNLOCK(ap->PELock);
}
}
} else {
DynamicClause *cl = ClauseFlagsToDynamicClause(pt1);
int erase;
Yap_ErLogUpdCl(cl);
setregs();
}
UNLOCK(ap->PELock);
}
}
}
else
{
DynamicClause *cl = ClauseFlagsToDynamicClause(pt1);
int erase;
LOCK(cl->ClLock);
DEC_CLREF_COUNT(cl);
erase = (cl->ClFlags & ErasedMask) && !(cl->ClRefCount);
UNLOCK(cl->ClLock);
if (erase) {
saveregs();
/* at this point,
LOCK(cl->ClLock);
DEC_CLREF_COUNT(cl);
erase = (cl->ClFlags & ErasedMask) && !(cl->ClRefCount);
UNLOCK(cl->ClLock);
if (erase)
{
saveregs();
/* at this point,
we are the only ones accessing the clause,
hence we don't need to have a lock it */
Yap_ErCl(cl);
setregs();
Yap_ErCl(cl);
setregs();
}
}
}
}
}
#else
ResetFlag(InUseMask, flags);
*pt1 = flags;
if (FlagOn((ErasedMask|DirtyMask), flags)) {
if (FlagOn(DBClMask, flags)) {
saveregs();
Yap_ErDBE(DBStructFlagsToDBStruct(pt1));
setregs();
} else {
saveregs();
if (flags & LogUpdMask) {
if (flags & IndexMask) {
if (FlagOn(ErasedMask, flags)) {
Yap_ErLogUpdIndex(ClauseFlagsToLogUpdIndex(pt1));
} else {
Yap_CleanUpIndex(ClauseFlagsToLogUpdIndex(pt1));
}
} else {
Yap_ErLogUpdCl(ClauseFlagsToLogUpdClause(pt1));
}
} else {
Yap_ErCl(ClauseFlagsToDynamicClause(pt1));
ResetFlag(InUseMask, flags);
*pt1 = flags;
if (FlagOn((ErasedMask | DirtyMask), flags))
{
if (FlagOn(DBClMask, flags))
{
saveregs();
Yap_ErDBE(DBStructFlagsToDBStruct(pt1));
setregs();
}
else
{
saveregs();
if (flags & LogUpdMask)
{
if (flags & IndexMask)
{
if (FlagOn(ErasedMask, flags))
{
Yap_ErLogUpdIndex(ClauseFlagsToLogUpdIndex(pt1));
}
else
{
Yap_CleanUpIndex(ClauseFlagsToLogUpdIndex(pt1));
}
}
else
{
Yap_ErLogUpdCl(ClauseFlagsToLogUpdClause(pt1));
}
}
else
{
Yap_ErCl(ClauseFlagsToDynamicClause(pt1));
}
setregs();
}
}
setregs();
}
}
#endif
goto failloop;
}
goto failloop;
}
#ifdef MULTI_ASSIGNMENT_VARIABLES
else /* if (IsApplTerm(d1)) */ {
CELL *pt = RepAppl(d1);
/* AbsAppl means */
/* multi-assignment variable */
/* so the next cell is the old value */
else /* if (IsApplTerm(d1)) */
{
CELL *pt = RepAppl(d1);
/* AbsAppl means */
/* multi-assignment variable */
/* so the next cell is the old value */
#ifdef FROZEN_STACKS
--pt0;
pt[0] = TrailVal(pt0);
--pt0;
pt[0] = TrailVal(pt0);
#else
pt[0] = TrailTerm(pt0-1);
pt0 -= 2;
pt[0] = TrailTerm(pt0 - 1);
pt0 -= 2;
#endif /* FROZEN_STACKS */
goto failloop;
goto failloop;
}
#endif
ENDD(d1);
ENDCACHE_TR();
}
}
#ifdef COROUTINING
NoStackFail:
BEGD(d0);
NoStackFail:
BEGD(d0);
#ifdef SHADOW_S
Yap_REGS.S_ = SREG;
Yap_REGS.S_ = SREG;
#endif
saveregs();
d0 = interrupt_fail( PASS_REGS1 );
setregs();
saveregs();
d0 = interrupt_fail(PASS_REGS1);
setregs();
#ifdef SHADOW_S
SREG = Yap_REGS.S_;
SREG = Yap_REGS.S_;
#endif
if (!d0) FAIL();
JMPNext();
ENDD(d0);
if (!d0)
FAIL();
JMPNext();
ENDD(d0);
#endif /* COROUTINING */
ENDPBOp();
ENDPBOp();
#ifdef INDENT_CODE
}
#endif /* INDENT_CODE */

4
C/grow.c
View File

@ -586,8 +586,8 @@ AdjustGlobal(Int sz, bool thread_copying USES_REGS)
(sizeof(MP_INT)+
(((MP_INT *)(pt+2))->_mp_alloc*sizeof(mp_limb_t)))/CellSize;
//printf("sz *%ld* at @%ld@\n", sz, pt-H0);
Opaque_CallOnGCMark f;
Opaque_CallOnGCRelocate f2;
YAP_Opaque_CallOnGCMark f;
YAP_Opaque_CallOnGCRelocate f2;
Term t = AbsAppl(pt);
if ( (f = Yap_blob_gc_mark_handler(t)) ) {

81
C/heapgc.c
View File

@ -514,7 +514,7 @@ pop_registers(Int num_regs, yamop *nextop USES_REGS)
/* pop info on opaque variables */
while (LOCAL_extra_gc_cells > LOCAL_extra_gc_cells_base) {
Opaque_CallOnGCRelocate f;
YAP_Opaque_CallOnGCRelocate f;
CELL *ptr = LOCAL_extra_gc_cells-1;
size_t n = ptr[0], t = ptr[-1];
@ -1436,43 +1436,44 @@ mark_variable(CELL_PTR current USES_REGS)
MARK(next+sz);
}
POP_CONTINUATION();
case (CELL)FunctorBigInt:
{
Opaque_CallOnGCMark f;
Term t = AbsAppl(next);
UInt sz = (sizeof(MP_INT)+CellSize+
((MP_INT *)(next+2))->_mp_alloc*sizeof(mp_limb_t))/CellSize;
case (CELL)FunctorBigInt: {
YAP_Opaque_CallOnGCMark f;
Term t = AbsAppl(next);
UInt sz = (sizeof(MP_INT) + CellSize +
((MP_INT *)(next + 2))->_mp_alloc * sizeof(mp_limb_t)) /
CellSize;
MARK(next);
if ( (f = Yap_blob_gc_mark_handler(t)) ) {
Int n = (f)(Yap_BlobTag(t), Yap_BlobInfo(t), LOCAL_extra_gc_cells, LOCAL_extra_gc_cells_top - (LOCAL_extra_gc_cells+2));
if (n < 0) {
/* error: we don't have enough room */
/* could not find more trail */
save_machine_regs();
siglongjmp(*LOCAL_gc_restore, 3);
} else if (n > 0) {
CELL *ptr = LOCAL_extra_gc_cells;
MARK(next);
if ((f = Yap_blob_gc_mark_handler(t))) {
Int n = (f)(Yap_BlobTag(t), Yap_BlobInfo(t), LOCAL_extra_gc_cells,
LOCAL_extra_gc_cells_top - (LOCAL_extra_gc_cells + 2));
if (n < 0) {
/* error: we don't have enough room */
/* could not find more trail */
save_machine_regs();
siglongjmp(*LOCAL_gc_restore, 3);
} else if (n > 0) {
CELL *ptr = LOCAL_extra_gc_cells;
LOCAL_extra_gc_cells += n+2;
PUSH_CONTINUATION(ptr, n+1 PASS_REGS);
ptr += n;
ptr[0] = t;
ptr[1] = n+1;
}
}
LOCAL_extra_gc_cells += n + 2;
PUSH_CONTINUATION(ptr, n + 1 PASS_REGS);
ptr += n;
ptr[0] = t;
ptr[1] = n + 1;
}
}
/* size is given by functor + friends */
if (next < LOCAL_HGEN) {
LOCAL_total_oldies += 2+sz;
} else {
DEBUG_printf0("%p 1\n", next);
DEBUG_printf1("%p %ld\n", next, (long int)(sz+2));
}
//fprintf(stderr,"%p M %d\n", next,2+sz);
LOCAL_total_marked += 2+sz;
PUSH_POINTER(next PASS_REGS);
sz++;
/* size is given by functor + friends */
if (next < LOCAL_HGEN) {
LOCAL_total_oldies += 2 + sz;
} else {
DEBUG_printf0("%p 1\n", next);
DEBUG_printf1("%p %ld\n", next, (long int)(sz + 2));
}
// fprintf(stderr,"%p M %d\n", next,2+sz);
LOCAL_total_marked += 2 + sz;
PUSH_POINTER(next PASS_REGS);
sz++;
#if DEBUG
if (next[sz] != EndSpecials) {
fprintf(stderr,"[ Error: could not find EndSpecials at blob %p type " UInt_FORMAT " ]\n", next, next[1]);
@ -1811,15 +1812,9 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
TrailTerm(trail_base) = (CELL)cptr;
mark_external_reference(&TrailTerm(trail_base) PASS_REGS);
TrailTerm(trail_base) = trail_cell;
} else if (*cptr == (CELL)FunctorBigInt) {
TrailTerm(trail_base) = AbsAppl(cptr);
} else {
mark_external_reference(&TrailTerm(trail_base) PASS_REGS);
TrailTerm(trail_base) = trail_cell;
}
#ifdef DEBUG
else
fprintf(stderr,"OOPS in GC: weird trail entry at %p:" UInt_FORMAT "\n", &TrailTerm(trail_base), (CELL)cptr);
#endif
}
}
#if MULTI_ASSIGNMENT_VARIABLES
@ -2655,7 +2650,7 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR USES_REGS)
if (HEAP_PTR(TrailTerm(dest))) {
into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell) PASS_REGS);
}
} else if (*pt0 == (CELL)FunctorBigInt) {
} else {
TrailTerm(dest) = trail_cell;
/* be careful with partial gc */
if (HEAP_PTR(TrailTerm(dest))) {

3
C/stack.c
View File

@ -1155,8 +1155,9 @@ bool Yap_find_prolog_culprit(USES_REGS1) {
while (curCP != YESCODE) {
curENV = (CELL *)(curENV[E_E]);
if (curENV < ASP || curENV >= LCL0)
if (curENV < ASP || curENV >= LCL0) {
break;
}
pe = EnvPreg(curCP);
if (pe==NULL) {
pe = PredMetaCall;

2
C/write.c
View File

@ -271,7 +271,7 @@ static void writebig(Term t, int p, int depth, int rinfixarg,
return;
#endif
} else if (big_tag >= USER_BLOB_START && big_tag < USER_BLOB_END) {
Opaque_CallOnWrite f;
YAP_Opaque_CallOnWrite f;
CELL blob_info;
blob_info = big_tag - USER_BLOB_START;

4
H/ATOMS
View File

@ -20,7 +20,7 @@ A AltNot N "not"
A Answer N "answer"
A Any N "any"
A Append N "append"
A Arg N "arg"
A Arg N "arg"
A Array F "$array"
A ArrayAccess F "$array_arg"
A ArrayOverflow N "array_overflow"
@ -134,6 +134,7 @@ A Eq N "="
A Error N "error"
A Exception N "exception"
A Extensions N "extensions"
A ExternalException N "external_exception"
A Evaluable N "evaluable"
A EvaluationError N "evaluation_error"
A Executable N "executable"
@ -510,6 +511,7 @@ F ExecuteInMod ExecuteInMod 2
F ExecuteWithin ExecuteWithin 1
F ExistenceError ExistenceError 2
F ExoClause ExoClause 2
F ExternalException ExternalException 1
F Functor Functor 3
F GAtom Atom 1
F GAtomic Atomic 1

2
H/GLOBALS
View File

@ -116,7 +116,7 @@ char Executable[YAP_FILENAME_MAX] void
#endif
int OpaqueHandlersCount =0
struct opaque_handler_struct* OpaqueHandlers =NULL
struct YAP_opaque_handler_struct* OpaqueHandlers =NULL
#if __simplescalar__
char pwd[YAP_FILENAME_MAX] void

3
H/HEAPFIELDS
View File

@ -307,6 +307,9 @@ int NUM_OF_ATTS =1 void
UInt Yap_AttsSize void void
#endif
/** opaque terms used to wake up on cut of call catcher meta-goal */
UInt setup_call_catcher_cleanup_tag void void
/* Operators */
struct operator_entry *OpList =NULL OpListAdjust

1
H/TermExt.h
View File

@ -96,6 +96,7 @@ typedef enum {
ARRAY_FLOAT = 0x22,
CLAUSE_LIST = 0x40,
EXTERNAL_BLOB = 0x100, /* generic data */
GOAL_CUT_POINT = 0x200,
USER_BLOB_START = 0x1000, /* user defined blob */
USER_BLOB_END = 0x1100 /* end of user defined blob */
} big_blob_type;

18
H/YapHeap.h
View File

@ -31,24 +31,6 @@ typedef int (*SWI_FlushFunction)(void *);
typedef int (*SWI_PLGetStreamFunction)(void *);
typedef int (*SWI_PLGetStreamPositionFunction)(void *);
typedef int (*Opaque_CallOnFail)(void *);
typedef int (*Opaque_CallOnWrite)(FILE *, int, void *, int);
typedef Int (*Opaque_CallOnGCMark)(int, void *, Term *, Int);
typedef int (*Opaque_CallOnGCRelocate)(int, void *, Term *, Int);
typedef struct opaque_handler_struct {
Opaque_CallOnFail fail_handler;
Opaque_CallOnWrite write_handler;
Opaque_CallOnGCMark gc_mark_handler;
Opaque_CallOnGCRelocate gc_relocate_handler;
} opaque_handler_t;
extern Opaque_CallOnWrite Yap_blob_write_handler_from_slot(Int slot);
extern Opaque_CallOnGCMark Yap_blob_gc_mark_handler(Term t);
extern Opaque_CallOnGCRelocate Yap_blob_gc_relocate_handler(Term t);
extern Int Yap_blob_tag_from_slot(Int slot);
extern void *Yap_blob_info_from_slot(Int slot);
#ifndef INT_KEYS_DEFAULT_SIZE
#define INT_KEYS_DEFAULT_SIZE 256
#endif

8
H/Yapproto.h
View File

@ -107,10 +107,11 @@ extern int Yap_IsStringTerm(Term);
extern int Yap_IsWideStringTerm(Term);
extern Term Yap_RatTermToApplTerm(Term);
extern void Yap_InitBigNums(void);
extern Term Yap_AllocExternalDataInStack(CELL, size_t);
extern int Yap_CleanOpaqueVariable(CELL *);
extern Term Yap_AllocExternalDataInStack(CELL, size_t, CELL **);
extern int Yap_CleanOpaqueVariable(Term t);
extern CELL *Yap_HeapStoreOpaqueTerm(Term t);
extern size_t Yap_OpaqueTermToString(Term t, char *str, size_t max);
extern Int Yap_blob_tag(Term t);
/* c_interface.c */
#ifndef YAP_CPP_INTERFACE
@ -500,6 +501,9 @@ extern void Yap_init_optyap_preds(void);
// struct PL_local_data *Yap_InitThreadIO(int wid);
extern void Yap_flush(void);
extern X_API YAP_opaque_tag_t
YAP_NewOpaqueType(struct YAP_opaque_handler_struct *f);
/* pl-yap.c */
extern Int Yap_source_line_no(void);
extern Atom Yap_source_file_name(void);

45
H/cut_c.h
View File

@ -21,48 +21,13 @@ struct cut_c_str {
#define CBACK_CUT_ARG(Offset) B->cp_args[(Offset)-1]
#define CUT_C_PUSH(YAMOP, S_YREG) \
{ \
if ((YAMOP)->y_u.OtapFs.f) { \
S_YREG = S_YREG - CUT_C_STR_SIZE; \
cut_c_str_ptr new_top = (cut_c_str_ptr)S_YREG; \
new_top->try_userc_cut_yamop = YAMOP; \
cut_c_push(new_top); \
} \
}
#define CUT_C_PUSH(YAMOP, S_YREG)
#define POP_CHOICE_POINT(cp) \
(((CELL *)Yap_REGS.CUT_C_TOP != (CELL *)LOCAL_LocalBase) && \
((CELL *)(cp) > (CELL *)Yap_REGS.CUT_C_TOP))
#define POP_CHOICE_POINT(cp) false
#define POP_EXECUTE()
#define POP_EXECUTE() \
cut_c_str_ptr TOP = Yap_REGS.CUT_C_TOP; \
CPredicate func = \
(CPredicate)((yamop *)TOP->try_userc_cut_yamop)->y_u.OtapFs.f; \
PredEntry *pred = \
(PredEntry *)((yamop *)TOP->try_userc_cut_yamop)->y_u.OtapFs.p; \
YAP_ExecuteOnCut(pred, func, TOP); \
cut_c_pop();
#define POP_FAIL(handler) \
if (handler) { yamop *oap = handler->cp_ap; \
handler->cp_ap = NOCODE; \
P = (yamop *)FAILCODE; \
choiceptr olB = B; B = handler; \
HR = handler->cp_h; \
/* DBTerm *ref = Yap_RefToException(); */ \
Yap_exec_absmi(true, false); \
B = olB; handler->cp_ap = oap; }
#define POP_FAIL_EXECUTE(handler) \
POP_FAIL(handler); \
cut_c_str_ptr TOP = Yap_REGS.CUT_C_TOP; \
CPredicate func = \
(CPredicate)((yamop *)TOP->try_userc_cut_yamop)->y_u.OtapFs.f; \
PredEntry *pred = \
(PredEntry *)((yamop *)TOP->try_userc_cut_yamop)->y_u.OtapFs.p; \
YAP_ExecuteOnCut(pred, func, TOP); \
cut_c_pop();
#define POP_FAIL(handler)
#define POP_FAIL_EXECUTE(handler)
/*Initializes CUT_C_TOP*/
void cut_c_initialize(int wid);

2
H/generated/dhstruct.h
View File

@ -270,6 +270,8 @@
#define Yap_AttsSize Yap_heap_regs->Yap_AttsSize_
#endif
#define setup_call_catcher_cleanup_tag Yap_heap_regs->setup_call_catcher_cleanup_tag_
#define OpList Yap_heap_regs->OpList_
#define ForeignCodeLoaded Yap_heap_regs->ForeignCodeLoaded_

2
H/generated/h0globals.h
View File

@ -100,7 +100,7 @@ EXTERNAL YP_FILE* GLOBAL_logfile;
EXTERNAL char GLOBAL_Executable[YAP_FILENAME_MAX];
#endif
EXTERNAL int GLOBAL_OpaqueHandlersCount;
EXTERNAL struct opaque_handler_struct* GLOBAL_OpaqueHandlers;
EXTERNAL struct YAP_opaque_handler_struct* GLOBAL_OpaqueHandlers;
#if __simplescalar__
EXTERNAL char GLOBAL_pwd[YAP_FILENAME_MAX];
#endif

2
H/generated/h0struct.h
View File

@ -273,6 +273,8 @@ EXTERNAL int NUM_OF_ATTS;
/* initialised by memory allocator */
EXTERNAL UInt Yap_AttsSize;
#endif
/** opaque terms used to wake up on cut of call catcher meta-goal */
EXTERNAL UInt setup_call_catcher_cleanup_tag;
/* Operators */
EXTERNAL struct operator_entry *OpList;
/* foreign code loaded */

2
H/generated/hglobals.h
View File

@ -100,7 +100,7 @@ typedef struct global_data {
char Executable_[YAP_FILENAME_MAX];
#endif
int OpaqueHandlersCount_;
struct opaque_handler_struct* OpaqueHandlers_;
struct YAP_opaque_handler_struct* OpaqueHandlers_;
#if __simplescalar__
char pwd_[YAP_FILENAME_MAX];
#endif

2
H/generated/hstruct.h
View File

@ -273,6 +273,8 @@
/* initialised by memory allocator */
UInt Yap_AttsSize_;
#endif
/** opaque terms used to wake up on cut of call catcher meta-goal */
UInt setup_call_catcher_cleanup_tag_;
/* Operators */
struct operator_entry *OpList_;
/* foreign code loaded */

2
H/generated/iatoms.h
View File

@ -129,6 +129,7 @@
AtomError = Yap_LookupAtom("error"); TermError = MkAtomTerm(AtomError);
AtomException = Yap_LookupAtom("exception"); TermException = MkAtomTerm(AtomException);
AtomExtensions = Yap_LookupAtom("extensions"); TermExtensions = MkAtomTerm(AtomExtensions);
AtomExternalException = Yap_LookupAtom("external_exception"); TermExternalException = MkAtomTerm(AtomExternalException);
AtomEvaluable = Yap_LookupAtom("evaluable"); TermEvaluable = MkAtomTerm(AtomEvaluable);
AtomEvaluationError = Yap_LookupAtom("evaluation_error"); TermEvaluationError = MkAtomTerm(AtomEvaluationError);
AtomExecutable = Yap_LookupAtom("executable"); TermExecutable = MkAtomTerm(AtomExecutable);
@ -505,6 +506,7 @@
FunctorExecuteWithin = Yap_MkFunctor(AtomExecuteWithin,1);
FunctorExistenceError = Yap_MkFunctor(AtomExistenceError,2);
FunctorExoClause = Yap_MkFunctor(AtomExoClause,2);
FunctorExternalException = Yap_MkFunctor(AtomExternalException,1);
FunctorFunctor = Yap_MkFunctor(AtomFunctor,3);
FunctorGAtom = Yap_MkFunctor(AtomAtom,1);
FunctorGAtomic = Yap_MkFunctor(AtomAtomic,1);

2
H/generated/ihstruct.h
View File

@ -270,6 +270,8 @@
#endif
OpList = NULL;
ForeignCodeLoaded = NULL;

2
H/generated/ratoms.h
View File

@ -129,6 +129,7 @@
AtomError = AtomAdjust(AtomError); TermError = MkAtomTerm(AtomError);
AtomException = AtomAdjust(AtomException); TermException = MkAtomTerm(AtomException);
AtomExtensions = AtomAdjust(AtomExtensions); TermExtensions = MkAtomTerm(AtomExtensions);
AtomExternalException = AtomAdjust(AtomExternalException); TermExternalException = MkAtomTerm(AtomExternalException);
AtomEvaluable = AtomAdjust(AtomEvaluable); TermEvaluable = MkAtomTerm(AtomEvaluable);
AtomEvaluationError = AtomAdjust(AtomEvaluationError); TermEvaluationError = MkAtomTerm(AtomEvaluationError);
AtomExecutable = AtomAdjust(AtomExecutable); TermExecutable = MkAtomTerm(AtomExecutable);
@ -505,6 +506,7 @@
FunctorExecuteWithin = FuncAdjust(FunctorExecuteWithin);
FunctorExistenceError = FuncAdjust(FunctorExistenceError);
FunctorExoClause = FuncAdjust(FunctorExoClause);
FunctorExternalException = FuncAdjust(FunctorExternalException);
FunctorFunctor = FuncAdjust(FunctorFunctor);
FunctorGAtom = FuncAdjust(FunctorGAtom);
FunctorGAtomic = FuncAdjust(FunctorGAtomic);

2
H/generated/rhstruct.h
View File

@ -270,6 +270,8 @@
#endif
OpList = OpListAdjust(OpList);
RestoreForeignCode();

3
H/generated/tatoms.h
View File

@ -129,6 +129,7 @@ X_API EXTERNAL Atom AtomEq; X_API EXTERNAL Term TermEq;
X_API EXTERNAL Atom AtomError; X_API EXTERNAL Term TermError;
X_API EXTERNAL Atom AtomException; X_API EXTERNAL Term TermException;
X_API EXTERNAL Atom AtomExtensions; X_API EXTERNAL Term TermExtensions;
X_API EXTERNAL Atom AtomExternalException; X_API EXTERNAL Term TermExternalException;
X_API EXTERNAL Atom AtomEvaluable; X_API EXTERNAL Term TermEvaluable;
X_API EXTERNAL Atom AtomEvaluationError; X_API EXTERNAL Term TermEvaluationError;
X_API EXTERNAL Atom AtomExecutable; X_API EXTERNAL Term TermExecutable;
@ -571,6 +572,8 @@ X_API EXTERNAL Functor FunctorExistenceError;
X_API EXTERNAL Functor FunctorExoClause;
X_API EXTERNAL Functor FunctorExternalException;
X_API EXTERNAL Functor FunctorFunctor;
X_API EXTERNAL Functor FunctorGAtom;

328
H/trim_trail.h
View File

@ -1,168 +1,178 @@
#ifdef FROZEN_STACKS
{
tr_fr_ptr pt0, pt1, pbase;
{
tr_fr_ptr pt0, pt1, pbase;
pbase = B->cp_tr;
pt0 = pt1 = TR - 1;
while (pt1 >= pbase) {
BEGD(d1);
d1 = TrailTerm(pt1);
if (IsVarTerm(d1)) {
if (d1 < (CELL)HBREG || d1 > Unsigned(B->cp_b)) {
TrailTerm(pt0) = d1;
TrailVal(pt0) = TrailVal(pt1);
pt0--;
}
pt1--;
} else if (IsPairTerm(d1)) {
CELL *pt = RepPair(d1);
#ifdef LIMIT_TABLING
if ((ADDR) pt == LOCAL_TrailBase) {
sg_fr_ptr sg_fr = (sg_fr_ptr) TrailVal(pt1);
SgFr_state(sg_fr)--; /* complete_in_use --> complete : compiled_in_use --> compiled */
insert_into_global_sg_fr_list(sg_fr);
} else
#endif /* LIMIT_TABLING */
if (IN_BETWEEN(LOCAL_TrailBase, pt, LOCAL_TrailTop)) {
/* skip, this is a problem because we lose information,
namely active references */
pt1 = (tr_fr_ptr)pt;
} else if (IN_BETWEEN(H0,pt,HR) && IsAttVar(pt)) {
CELL val = Deref(*pt);
if (IsVarTerm(val)) {
YapBind(pt, MkAtomTerm(AtomCut));
Yap_WakeUp(pt);
}
} else if ((*pt & (LogUpdMask|IndexMask)) == (LogUpdMask|IndexMask)) {
LogUpdIndex *cl = ClauseFlagsToLogUpdIndex(pt);
int erase;
#if defined(THREADS) || defined(YAPOR)
PredEntry *ap = cl->ClPred;
#endif
LOCK(ap->PELock);
DEC_CLREF_COUNT(cl);
cl->ClFlags &= ~InUseMask;
erase = (cl->ClFlags & (ErasedMask|DirtyMask)) && !(cl->ClRefCount);
if (erase) {
/* at this point, we are the only ones accessing the clause,
hence we don't need to have a lock it */
if (cl->ClFlags & ErasedMask)
Yap_ErLogUpdIndex(cl);
else
Yap_CleanUpIndex(cl);
}
UNLOCK(ap->PELock);
} else {
TrailTerm(pt0) = d1;
TrailVal(pt0) = TrailVal(pt1);
pt0--;
}
pt1--;
} else if (IsApplTerm(d1)) {
if (IN_BETWEEN(HBREG,RepAppl(d1),B->cp_b)) {
/* deterministic binding to multi-assignment variable */
pt1 -= 2;
} else {
TrailVal(pt0) = TrailVal(pt1);
TrailTerm(pt0) = d1;
TrailVal(pt0-1) = TrailVal(pt1-1);
TrailTerm(pt0-1) = TrailTerm(pt1-1);
pt0 -= 2;
pt1 -= 2;
}
} else {
TrailTerm(pt0) = d1;
TrailVal(pt0) = TrailVal(pt1);
pt0--;
pt1--;
pbase = B->cp_tr;
pt0 = pt1 = TR - 1;
while (pt1 >= pbase) {
BEGD(d1);
d1 = TrailTerm(pt1);
if (IsVarTerm(d1)) {
if (d1 < (CELL)HBREG || d1 > Unsigned(B->cp_b)) {
TrailTerm(pt0) = d1;
TrailVal(pt0) = TrailVal(pt1);
pt0--;
}
ENDD(d1);
}
if (pt0 != pt1) {
int size;
pt0++;
size = TR - pt0;
memmove(pbase, pt0, size * sizeof(struct trail_frame));
TR = pbase + size;
}
}
#else
{
tr_fr_ptr pt1, pt0;
pt1 = pt0 = B->cp_tr;
while (pt1 != TR) {
BEGD(d1);
d1 = TrailTerm(pt1);
if (IsVarTerm(d1)) {
if (d1 < (CELL)HBREG || d1 > Unsigned(B->cp_b)) {
#ifdef FROZEN_STACKS
TrailVal(pt0) = TrailVal(pt1);
#endif /* FROZEN_STACKS */
TrailTerm(pt0) = d1;
pt0++;
}
pt1++;
} else if (IsApplTerm(d1)) {
if (IN_BETWEEN(HBREG,RepAppl(d1),B->cp_b)) {
#ifdef FROZEN_STACKS
pt1 += 2;
#else
pt1 += 3;
pt1--;
} else if (IsPairTerm(d1)) {
CELL *pt = RepPair(d1);
#ifdef LIMIT_TABLING
if ((ADDR)pt == LOCAL_TrailBase) {
sg_fr_ptr sg_fr = (sg_fr_ptr)TrailVal(pt1);
SgFr_state(sg_fr)--; /* complete_in_use --> complete : compiled_in_use
--> compiled */
insert_into_global_sg_fr_list(sg_fr);
} else
#endif /* LIMIT_TABLING */
if (IN_BETWEEN(LOCAL_TrailBase, pt, LOCAL_TrailTop)) {
/* skip, this is a problem because we lose information,
namely active references */
pt1 = (tr_fr_ptr)pt;
} else if (IN_BETWEEN(H0, pt, HR) && IsApplTerm(HeadOfTerm(d1))) {
Term t = HeadOfTerm(d1);
Functor f = FunctorOfTerm(t);
if (f == FunctorBigInt) {
Int tag = Yap_blob_tag(t) - USER_BLOB_START;
RESET_VARIABLE(&TrailTerm(pt1));
GLOBAL_OpaqueHandlers[tag].cut_handler(d1);
} else {
pt0--;
}
pt1--;
continue;
} else if ((*pt & (LogUpdMask | IndexMask)) == (LogUpdMask | IndexMask)) {
LogUpdIndex *cl = ClauseFlagsToLogUpdIndex(pt);
int erase;
#if defined(THREADS) || defined(YAPOR)
PredEntry *ap = cl->ClPred;
#endif
} else {
#ifdef FROZEN_STACKS
TrailVal(pt0) = TrailVal(pt1);
TrailTerm(pt0) = d1;
TrailVal(pt0+1) = TrailVal(pt1+1);
TrailTerm(pt0+1) = TrailTerm(pt1+1);
pt0 += 2;
pt1 += 2;
#else
TrailTerm(pt0+1) = TrailTerm(pt1+1);
TrailTerm(pt0) = TrailTerm(pt0+2) = d1;
pt0 += 3;
pt1 += 3;
#endif /* FROZEN_STACKS */
}
} else if (IsPairTerm(d1)) {
CELL *pt = RepPair(d1);
if (IN_BETWEEN(H0,pt,HR) && IsAttVar(pt)) {
CELL val = Deref(*pt);
if (IsVarTerm(val)) {
YapBind(VarOfTerm(val), MkAtomTerm(AtomCut));
Yap_WakeUp(pt);
}
} else if ((*pt & (LogUpdMask|IndexMask)) == (LogUpdMask|IndexMask)) {
LogUpdIndex *cl = ClauseFlagsToLogUpdIndex(pt);
#if defined(YAPOR) || defined(THREADS)
PredEntry *ap = cl->ClPred;
#endif
int erase;
LOCK(ap->PELock);
DEC_CLREF_COUNT(cl);
cl->ClFlags &= ~InUseMask;
erase = (cl->ClFlags & (DirtyMask|ErasedMask)) && !(cl->ClRefCount);
if (erase) {
/* at this point, we are the only ones accessing the clause,
hence we don't need to have a lock it */
if (cl->ClFlags & ErasedMask)
Yap_ErLogUpdIndex(cl);
else
Yap_CleanUpIndex(cl);
}
UNLOCK(ap->PELock);
} else {
TrailTerm(pt0) = d1;
pt0++;
}
pt1++;
LOCK(ap->PELock);
DEC_CLREF_COUNT(cl);
cl->ClFlags &= ~InUseMask;
erase = (cl->ClFlags & (ErasedMask | DirtyMask)) && !(cl->ClRefCount);
if (erase) {
/* at this point, we are the only ones accessing the clause,
hence we don't need to have a lock it */
if (cl->ClFlags & ErasedMask)
Yap_ErLogUpdIndex(cl);
else
Yap_CleanUpIndex(cl);
}
UNLOCK(ap->PELock);
} else {
TrailTerm(pt0) = d1;
pt0++;
pt1++;
TrailTerm(pt0) = d1;
TrailVal(pt0) = TrailVal(pt1);
pt0--;
}
pt1--;
} else if (IsApplTerm(d1)) {
if (IN_BETWEEN(HBREG, RepAppl(d1), B->cp_b)) {
/* deterministic binding to multi-assignment variable */
pt1 -= 2;
} else {
TrailVal(pt0) = TrailVal(pt1);
TrailTerm(pt0) = d1;
TrailVal(pt0 - 1) = TrailVal(pt1 - 1);
TrailTerm(pt0 - 1) = TrailTerm(pt1 - 1);
pt0 -= 2;
pt1 -= 2;
}
} else {
TrailTerm(pt0) = d1;
TrailVal(pt0) = TrailVal(pt1);
pt0--;
pt1--;
}
ENDD(d1);
}
if (pt0 != pt1) {
int size;
pt0++;
size = TR - pt0;
memmove(pbase, pt0, size * sizeof(struct trail_frame));
TR = pbase + size;
}
}
#else
{
tr_fr_ptr pt1, pt0;
pt1 = pt0 = B->cp_tr;
while (pt1 != TR) {
BEGD(d1);
d1 = TrailTerm(pt1);
if (IsVarTerm(d1)) {
if (d1 < (CELL)HBREG || d1 > Unsigned(B->cp_b)) {
#ifdef FROZEN_STACKS
TrailVal(pt0) = TrailVal(pt1);
#endif /* FROZEN_STACKS */
TrailTerm(pt0) = d1;
pt0++;
}
pt1++;
} else if (IsApplTerm(d1)) {
if (IN_BETWEEN(HBREG, RepAppl(d1), B->cp_b)) {
#ifdef FROZEN_STACKS
pt1 += 2;
#else
pt1 += 3;
#endif
} else {
#ifdef FROZEN_STACKS
TrailVal(pt0) = TrailVal(pt1);
TrailTerm(pt0) = d1;
TrailVal(pt0 + 1) = TrailVal(pt1 + 1);
TrailTerm(pt0 + 1) = TrailTerm(pt1 + 1);
pt0 += 2;
pt1 += 2;
#else
TrailTerm(pt0 + 1) = TrailTerm(pt1 + 1);
TrailTerm(pt0) = TrailTerm(pt0 + 2) = d1;
pt0 += 3;
pt1 += 3;
#endif /* FROZEN_STACKS */
}
} else if (IsPairTerm(d1)) {
CELL *pt = RepPair(d1);
else if (IN_BETWEEN(H0, pt, HR) && IsApplTerm(HeadOfTerm(d1))) {
Term t = HeadOfTerm(d1);
Functor f = FunctorOfTerm(t);
if (f == FunctorBigInt) {
RESET_VARIABLE(&TrailTerm(pt1));
Int tag = Yap_blob_tag(t);
GLOBAL_OpaqueHandlers[tag].cut_handler(d1);
} else if ((*pt & (LogUpdMask | IndexMask)) ==
(LogUpdMask | IndexMask)) {
LogUpdIndex *cl = ClauseFlagsToLogUpdIndex(pt);
#if defined(YAPOR) || defined(THREADS)
PredEntry *ap = cl->ClPred;
#endif
int erase;
LOCK(ap->PELock);
DEC_CLREF_COUNT(cl);
cl->ClFlags &= ~InUseMask;
erase = (cl->ClFlags & (DirtyMask | ErasedMask)) && !(cl->ClRefCount);
if (erase) {
/* at this point, we are the only ones accessing the clause,
hence we don't need to have a lock it */
if (cl->ClFlags & ErasedMask)
Yap_ErLogUpdIndex(cl);
else
Yap_CleanUpIndex(cl);
}
UNLOCK(ap->PELock);
} else {
TrailTerm(pt0) = d1;
pt0++;
}
pt1++;
}
else {
TrailTerm(pt0) = d1;
pt0++;
pt1++;
}
ENDD(d1);
}

3
pl/boot.yap
View File

@ -854,8 +854,8 @@ number of steps.
format(user_error,'.~n', []).
'$another' :-
'$clear_input'(user_input),
format(user_error,' ? ',[]),
'$clear_input'(user_input),
get_code(user_input,C),
'$do_another'(C).
@ -1399,7 +1399,6 @@ Command = (H --> B) ->
'$enter_command'(Stream, Mod, Status) :-
'$clear_input'(Stream),
prompt1(': '), prompt(_,' '),
Options = [module(Mod), syntax_errors(dec10),variable_names(Vars), term_position(Pos)],
(

11
pl/control.yap
View File

@ -262,10 +262,12 @@ This is similar to call_cleanup/1 but with an additional
*/
call_cleanup(Goal, Cleanup) :-
setup_call_catcher_cleanup(true, Goal, _Catcher, Cleanup).
call_cleanup(Goal, _Catcher, Cleanup).
call_cleanup(Goal, Catcher, Cleanup) :-
setup_call_catcher_cleanup(true, Goal, Catcher, Cleanup).
'$tag_cleanup'(CP0, cleanup( false, Catcher, Cleanup, Tag, 0, Done)),
call( Goal ),
'$cleanup_on_exit'(CP0, cleanup( false, Catcher, Cleanup, Tag, 1, Done )).
/** @pred setup_call_cleanup(: _Setup_,: _Goal_, : _CleanUpGoal_)
@ -285,6 +287,11 @@ finally undone by _Cleanup_.
setup_call_cleanup(Setup,Goal, Cleanup) :-
setup_call_catcher_cleanup(Setup, Goal, _Catcher, Cleanup).
setup_call_catcher_cleanup(Setup, Goal, Catcher, Cleanup) :-
'$setup_call_catcher_cleanup'(Setup),
call_cleanup(Goal, Catcher, Cleanup).
/** @pred call_with_args(+ _Name_,...,? _Ai_,...)