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

ugh

Browse Source
This commit is contained in:
Vitor Santos Costa 2019-01-28 15:02:55 +00:00
parent 36fedfa321
commit 09d8d07b7e
6 changed files with 2186 additions and 1187 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

603
C/globals.c
View File

@ -1,19 +1,19 @@
/************************************************************************* /*************************************************************************
* * * *
* YAP Prolog * * YAP Prolog *
* * * *
* Yap Prolog was developed at NCCUP - Universidade do Porto * * Yap Prolog was developed at NCCUP - Universidade do Porto *
* * * *
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 * * Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
* * * *
************************************************************************** **************************************************************************
* * * *
* File: non backtrackable term support * * File: non backtrackable term support *
* Last rev: 2/8/06 * * Last rev: 2/8/06 *
* mods: * * mods: *
* comments: non-backtrackable term support * * comments: non-backtrackable term support *
* * * *
*************************************************************************/ *************************************************************************/
#ifdef SCCS #ifdef SCCS
static char SccsId[] = "%W% %G%"; static char SccsId[] = "%W% %G%";
#endif #endif
@ -31,81 +31,81 @@ static char SccsId[] = "%W% %G%";
/** /**
@defgroup Global_Variables Global Variables @defgroup Global_Variables Global Variables
@ingroup builtins @ingroup builtins
@{ @{
Global variables are associations between names (atoms) and Global variables are associations between names (atoms) and
terms. They differ in various ways from storing information using terms. They differ in various ways from storing information using
assert/1 or recorda/3. assert/1 or recorda/3.
+ The value lives on the Prolog (global) stack. This implies that + The value lives on the Prolog (global) stack. This implies that
lookup time is independent from the size of the term. This is lookup time is independent from the size of the term. This is
particularly interesting for large data structures such as parsed XML particularly interesting for large data structures such as parsed XML
documents or the CHR global constraint store. documents or the CHR global constraint store.
+ They support both global assignment using nb_setval/2 and + They support both global assignment using nb_setval/2 and
backtrackable assignment using b_setval/2. backtrackable assignment using b_setval/2.
+ Only one value (which can be an arbitrary complex Prolog term) + Only one value (which can be an arbitrary complex Prolog term)
can be associated to a variable at a time. can be associated to a variable at a time.
+ Their value cannot be shared among threads. Each thread has its own + Their value cannot be shared among threads. Each thread has its own
namespace and values for global variables. namespace and values for global variables.
Currently global variables are scoped globally. We may consider module Currently global variables are scoped globally. We may consider module
scoping in future versions. Both b_setval/2 and scoping in future versions. Both b_setval/2 and
nb_setval/2 implicitly create a variable if the referenced name nb_setval/2 implicitly create a variable if the referenced name
does not already refer to a variable. does not already refer to a variable.
Global variables may be initialized from directives to make them Global variables may be initialized from directives to make them
available during the program lifetime, but some considerations are available during the program lifetime, but some considerations are
necessary for saved-states and threads. Saved-states to not store necessary for saved-states and threads. Saved-states to not store
global variables, which implies they have to be declared with global variables, which implies they have to be declared with
initialization/1 to recreate them after loading the saved initialization/1 to recreate them after loading the saved
state. Each thread has its own set of global variables, starting with state. Each thread has its own set of global variables, starting with
an empty set. Using `thread_initialization/1` to define a global an empty set. Using `thread_initialization/1` to define a global
variable it will be defined, restored after reloading a saved state variable it will be defined, restored after reloading a saved state
and created in all threads that are created after the and created in all threads that are created after the
registration. Finally, global variables can be initialized using the registration. Finally, global variables can be initialized using the
exception hook called exception/3. The latter technique is used exception hook called exception/3. The latter technique is used
by CHR. by CHR.
SWI-Prolog global variables are associations between names (atoms) and SWI-Prolog global variables are associations between names (atoms) and
terms. They differ in various ways from storing information using terms. They differ in various ways from storing information using
assert/1 or recorda/3. assert/1 or recorda/3.
+ The value lives on the Prolog (global) stack. This implies + The value lives on the Prolog (global) stack. This implies
that lookup time is independent from the size of the term. that lookup time is independent from the size of the term.
This is particulary interesting for large data structures This is particulary interesting for large data structures
such as parsed XML documents or the CHR global constraint such as parsed XML documents or the CHR global constraint
store. store.
They support both global assignment using nb_setval/2 and They support both global assignment using nb_setval/2 and
backtrackable assignment using b_setval/2. backtrackable assignment using b_setval/2.
+ Only one value (which can be an arbitrary complex Prolog + Only one value (which can be an arbitrary complex Prolog
term) can be associated to a variable at a time. term) can be associated to a variable at a time.
+ Their value cannot be shared among threads. Each thread + Their value cannot be shared among threads. Each thread
has its own namespace and values for global variables. has its own namespace and values for global variables.
+ Currently global variables are scoped globally. We may + Currently global variables are scoped globally. We may
consider module scoping in future versions. consider module scoping in future versions.
Both b_setval/2 and nb_setval/2 implicitly create a variable if the Both b_setval/2 and nb_setval/2 implicitly create a variable if the
referenced name does not already refer to a variable. referenced name does not already refer to a variable.
Global variables may be initialized from directives to make them Global variables may be initialized from directives to make them
available during the program lifetime, but some considerations are available during the program lifetime, but some considerations are
necessary for saved-states and threads. Saved-states to not store global necessary for saved-states and threads. Saved-states to not store global
variables, which implies they have to be declared with initialization/1 variables, which implies they have to be declared with initialization/1
to recreate them after loading the saved state. Each thread has to recreate them after loading the saved state. Each thread has
its own set of global variables, starting with an empty set. Using its own set of global variables, starting with an empty set. Using
`thread_inititialization/1` to define a global variable it will be `thread_inititialization/1` to define a global variable it will be
defined, restored after reloading a saved state and created in all defined, restored after reloading a saved state and created in all
threads that are created <em>after</em> the registration. threads that are created <em>after</em> the registration.
*/ */
@ -123,7 +123,7 @@ static char SccsId[] = "%W% %G%";
special term on the heap. Arenas automatically contract as we add terms to special term on the heap. Arenas automatically contract as we add terms to
the front. the front.
*/ */
#define QUEUE_FUNCTOR_ARITY 4 #define QUEUE_FUNCTOR_ARITY 4
@ -145,13 +145,13 @@ static char SccsId[] = "%W% %G%";
#define Global_MkIntegerTerm(I) MkIntegerTerm(I) #define Global_MkIntegerTerm(I) MkIntegerTerm(I)
static size_t big2arena_sz(CELL *arena_base) { static UInt big2arena_sz(CELL *arena_base) {
return (((MP_INT *)(arena_base + 2))->_mp_alloc * sizeof(mp_limb_t) + return (((MP_INT *)(arena_base + 2))->_mp_alloc * sizeof(mp_limb_t) +
sizeof(MP_INT) + sizeof(Functor) + 2 * sizeof(CELL)) / sizeof(MP_INT) + sizeof(Functor) + 2 * sizeof(CELL)) /
sizeof(CELL); sizeof(CELL);
} }
static size_t arena2big_sz(size_t sz) { static UInt arena2big_sz(UInt sz) {
return sz - return sz -
(sizeof(MP_INT) + sizeof(Functor) + 2 * sizeof(CELL)) / sizeof(CELL); (sizeof(MP_INT) + sizeof(Functor) + 2 * sizeof(CELL)) / sizeof(CELL);
} }
@ -159,7 +159,7 @@ static size_t arena2big_sz(size_t sz) {
/* pointer to top of an arena */ /* pointer to top of an arena */
static inline CELL *ArenaLimit(Term arena) { static inline CELL *ArenaLimit(Term arena) {
CELL *arena_base = RepAppl(arena); CELL *arena_base = RepAppl(arena);
size_t sz = big2arena_sz(arena_base); UInt sz = big2arena_sz(arena_base);
return arena_base + sz; return arena_base + sz;
} }
@ -171,9 +171,9 @@ CELL *Yap_ArenaLimit(Term arena) {
/* pointer to top of an arena */ /* pointer to top of an arena */
static inline CELL *ArenaPt(Term arena) { return (CELL *)RepAppl(arena); } static inline CELL *ArenaPt(Term arena) { return (CELL *)RepAppl(arena); }
static inline size_t ArenaSz(Term arena) { return big2arena_sz(RepAppl(arena)); } static inline UInt ArenaSz(Term arena) { return big2arena_sz(RepAppl(arena)); }
static Term CreateNewArena(CELL *ptr, size_t size) { static Term CreateNewArena(CELL *ptr, UInt size) {
Term t = AbsAppl(ptr); Term t = AbsAppl(ptr);
MP_INT *dst; MP_INT *dst;
@ -186,9 +186,9 @@ static Term CreateNewArena(CELL *ptr, size_t size) {
return t; return t;
} }
static Term NewArena(size_t size, int wid, UInt arity, CELL *where) { static Term NewArena(UInt size, int wid, UInt arity, CELL *where) {
Term t; Term t;
size_t new_size; UInt new_size;
WORKER_REGS(wid) WORKER_REGS(wid)
if (where == NULL || where == HR) { if (where == NULL || where == HR) {
@ -232,7 +232,7 @@ void Yap_AllocateDefaultArena(size_t gsize, int wid) {
REMOTE_GlobalArena(wid) = NewArena(gsize, wid, 2, NULL); REMOTE_GlobalArena(wid) = NewArena(gsize, wid, 2, NULL);
} }
static void adjust_cps(size_t size USES_REGS) { static void adjust_cps(UInt size USES_REGS) {
/* adjust possible back pointers in choice-point stack */ /* adjust possible back pointers in choice-point stack */
choiceptr b_ptr = B; choiceptr b_ptr = B;
while (b_ptr->cp_h == HR) { while (b_ptr->cp_h == HR) {
@ -290,14 +290,14 @@ static int GrowArena(Term arena, CELL *pt, size_t old_size, size_t size,
return TRUE; return TRUE;
} }
CELL *Yap_GetFromArena(Term *arenap, size_t cells, UInt arity) { CELL *Yap_GetFromArena(Term *arenap, UInt cells, UInt arity) {
CACHE_REGS CACHE_REGS
restart : { restart : {
Term arena = *arenap; Term arena = *arenap;
CELL *max = ArenaLimit(arena); CELL *max = ArenaLimit(arena);
CELL *base = ArenaPt(arena); CELL *base = ArenaPt(arena);
CELL *newH; CELL *newH;
size_t old_sz = ArenaSz(arena), new_size; UInt old_sz = ArenaSz(arena), new_size;
if (IN_BETWEEN(base, HR, max)) { if (IN_BETWEEN(base, HR, max)) {
base = HR; base = HR;
@ -315,12 +315,12 @@ CELL *Yap_GetFromArena(Term *arenap, size_t cells, UInt arity) {
new_size = old_sz - cells; new_size = old_sz - cells;
*arenap = CreateNewArena(newH, new_size); *arenap = CreateNewArena(newH, new_size);
return base; return base;
} }
} }
static void CloseArena(CELL *oldH, CELL *oldHB, CELL *oldASP, Term *oldArenaP, static void CloseArena(CELL *oldH, CELL *oldHB, CELL *oldASP, Term *oldArenaP,
size_t old_size USES_REGS) { UInt old_size USES_REGS) {
size_t new_size; UInt new_size;
if (HR == oldH) if (HR == oldH)
return; return;
@ -331,6 +331,319 @@ static void CloseArena(CELL *oldH, CELL *oldHB, CELL *oldASP, Term *oldArenaP,
ASP = oldASP; ASP = oldASP;
} }
static inline void clean_dirty_tr(tr_fr_ptr TR0 USES_REGS) {
if (TR != TR0) {
tr_fr_ptr pt = TR0;
do {
Term p = TrailTerm(pt++);
if (IsVarTerm(p)) {
RESET_VARIABLE(p);
} else {
/* copy downwards */
TrailTerm(TR0 + 1) = TrailTerm(pt);
TrailTerm(TR0) = TrailTerm(TR0 + 2) = p;
pt += 2;
TR0 += 3;
}
} while (pt != TR);
TR = TR0;
}
}
#define expand_stack(S0,SP,SF,TYPE) \
{ size_t sz = SF-S0, used = SP-S0; \
S0 = Realloc(S0, (1024+sz)*sizeof(TYPE) PASS_REGS); \
SP = S0+used; SF = S0+sz; }
static int copy_complex_term(register CELL *pt0, register CELL *pt0_end,
int share, int copy_att_vars, CELL *ptf,
CELL *HLow USES_REGS) {
int lvl = push_text_stack();
struct cp_frame *to_visit0, *to_visit = Malloc(1024*sizeof(struct cp_frame));
struct cp_frame *to_visit_max;
CELL *HB0 = HB;
tr_fr_ptr TR0 = TR;
int ground = TRUE;
HB = HLow;
to_visit0 = to_visit;
to_visit_max = to_visit+1024;
loop:
while (pt0 < pt0_end) {
register CELL d0;
register CELL *ptd0;
++pt0;
ptd0 = pt0;
d0 = *ptd0;
deref_head(d0, copy_term_unk);
copy_term_nvar : {
if (IsPairTerm(d0)) {
CELL *ap2 = RepPair(d0);
if ((share && ap2 < HB) || (ap2 >= HB && ap2 < HR)) {
/* If this is newer than the current term, just reuse */
*ptf++ = d0;
continue;
}
*ptf = AbsPair(HR);
ptf++;
#ifdef RATIONAL_TREES
if (to_visit >= to_visit_max-32) {
expand_stack(to_visit0, to_visit, to_visit_max, struct cp_frame);
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->oldv = *pt0;
to_visit->ground = ground;
/* fool the system into thinking we had a variable there */
*pt0 = AbsPair(HR);
to_visit++;
#else
if (pt0 < pt0_end) {
if (to_visit + 32 >= to_visit_max - 32) {
expand_stack(to_visit0, to_visit, to_visit_max, struct cp_frame);
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->ground = ground;
to_visit++;
}
#endif
ground = TRUE;
pt0 = ap2 - 1;
pt0_end = ap2 + 1;
ptf = HR;
HR += 2;
if (HR > ASP - MIN_ARENA_SIZE) {
goto overflow;
}
} else if (IsApplTerm(d0)) {
register Functor f;
register CELL *ap2;
/* store the terms to visit */
ap2 = RepAppl(d0);
if ((share && ap2 < HB) || (ap2 >= HB && ap2 < HR)) {
/* If this is newer than the current term, just reuse */
*ptf++ = d0;
continue;
}
f = (Functor)(*ap2);
if (IsExtensionFunctor(f)) {
switch ((CELL)f) {
case (CELL) FunctorDBRef:
case (CELL) FunctorAttVar:
*ptf++ = d0;
break;
case (CELL) FunctorLongInt:
if (HR > ASP - (MIN_ARENA_SIZE + 3)) {
goto overflow;
}
*ptf++ = AbsAppl(HR);
HR[0] = (CELL)f;
HR[1] = ap2[1];
HR[2] = EndSpecials;
HR += 3;
if (HR > ASP - MIN_ARENA_SIZE) {
goto overflow;
}
break;
case (CELL) FunctorDouble:
if (HR >
ASP - (MIN_ARENA_SIZE + (2 + SIZEOF_DOUBLE / sizeof(CELL)))) {
goto overflow;
}
*ptf++ = AbsAppl(HR);
HR[0] = (CELL)f;
HR[1] = ap2[1];
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
HR[2] = ap2[2];
HR[3] = EndSpecials;
HR += 4;
#else
HR[2] = EndSpecials;
HR += 3;
#endif
break;
case (CELL) FunctorString:
if (ASP - HR < MIN_ARENA_SIZE + 3 + ap2[1]) {
goto overflow;
}
*ptf++ = AbsAppl(HR);
memmove(HR, ap2, sizeof(CELL) * (3 + ap2[1]));
HR += ap2[1] + 3;
break;
default: {
/* big int */
UInt sz = (sizeof(MP_INT) + 3 * CellSize +
((MP_INT *)(ap2 + 2))->_mp_alloc * sizeof(mp_limb_t)) /
CellSize,
i;
if (HR > ASP - (MIN_ARENA_SIZE + sz)) {
goto overflow;
}
*ptf++ = AbsAppl(HR);
HR[0] = (CELL)f;
for (i = 1; i < sz; i++) {
HR[i] = ap2[i];
}
HR += sz;
}
}
continue;
}
*ptf = AbsAppl(HR);
ptf++;
/* store the terms to visit */
#ifdef RATIONAL_TREES
if (to_visit + 32 >= to_visit_max) {
expand_stack(to_visit0, to_visit, to_visit_max, struct cp_frame);
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->oldv = *pt0;
to_visit->ground = ground;
/* fool the system into thinking we had a variable there */
*pt0 = AbsAppl(HR);
to_visit++;
#else
if (pt0 < pt0_end) {
if (to_visit++ >= (CELL **)AuxSp) {
expand_stack(to_visit0, to_visit, to_visit_max, struct cp_frame);
}
to_visit->start_cp = pt0;
to_visit->end_cp = pt0_end;
to_visit->to = ptf;
to_visit->ground = ground;
to_visit++;
}
#endif
ground = (f != FunctorMutable);
d0 = ArityOfFunctor(f);
pt0 = ap2;
pt0_end = ap2 + d0;
/* store the functor for the new term */
HR[0] = (CELL)f;
ptf = HR + 1;
HR += 1 + d0;
if (HR > ASP - MIN_ARENA_SIZE) {
goto overflow;
}
} else {
/* just copy atoms or integers */
*ptf++ = d0;
}
continue;
}
derefa_body(d0, ptd0, copy_term_unk, copy_term_nvar);
ground = FALSE;
/* don't need to copy variables if we want to share the global term */
if ((share && ptd0 < HB && ptd0 > H0) || (ptd0 >= HLow && ptd0 < HR)) {
/* we have already found this cell */
*ptf++ = (CELL)ptd0;
} else {
#if COROUTINING
if (copy_att_vars && GlobalIsAttachedTerm((CELL)ptd0)) {
/* if unbound, call the standard copy term routine */
struct cp_frame *bp;
CELL new;
bp = to_visit;
if (!GLOBAL_attas[ExtFromCell(ptd0)].copy_term_op(ptd0, &bp,
ptf PASS_REGS)) {
goto overflow;
}
to_visit = bp;
new = *ptf;
if (TR > (tr_fr_ptr)LOCAL_TrailTop - 256) {
/* Trail overflow */
if (!Yap_growtrail((TR - TR0) * sizeof(tr_fr_ptr *), TRUE)) {
goto trail_overflow;
}
}
Bind_and_Trail(ptd0, new);
ptf++;
} else {
#endif
/* first time we met this term */
RESET_VARIABLE(ptf);
if ((ADDR)TR > LOCAL_TrailTop - MIN_ARENA_SIZE)
goto trail_overflow;
Bind_and_Trail(ptd0, (CELL)ptf);
ptf++;
#ifdef COROUTINING
}
#endif
}
}
/* Do we still have compound terms to visit */
if (to_visit > to_visit0) {
to_visit--;
pt0 = to_visit->start_cp;
pt0_end = to_visit->end_cp;
ptf = to_visit->to;
#ifdef RATIONAL_TREES
*pt0 = to_visit->oldv;
#endif
ground = (ground && to_visit->ground);
goto loop;
}
/* restore our nice, friendly, term to its original state */
HB = HB0;
clean_dirty_tr(TR0 PASS_REGS);
/* follow chain of multi-assigned variables */
pop_text_stack(lvl);
return 0;
overflow:
/* oops, we're in trouble */
HR = HLow;
/* we've done it */
/* restore our nice, friendly, term to its original state */
HB = HB0;
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit--;
pt0 = to_visit->start_cp;
pt0_end = to_visit->end_cp;
ptf = to_visit->to;
*pt0 = to_visit->oldv;
}
#endif
reset_trail(TR0);
pop_text_stack(lvl);
return -1;
trail_overflow:
/* oops, we're in trouble */
HR = HLow;
/* we've done it */
/* restore our nice, friendly, term to its original state */
HB = HB0;
#ifdef RATIONAL_TREES
while (to_visit > to_visit0) {
to_visit--;
pt0 = to_visit->start_cp;
pt0_end = to_visit->end_cp;
ptf = to_visit->to;
*pt0 = to_visit->oldv;
}
#endif
reset_trail(TR0);
pop_text_stack(lvl);
return -4;
}
static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars, static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
UInt arity, Term *newarena, UInt arity, Term *newarena,
size_t min_grow USES_REGS) { size_t min_grow USES_REGS) {
@ -341,7 +654,7 @@ static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
int res = 0; int res = 0;
Term tn; Term tn;
restart: restart:
t = Deref(t); t = Deref(t);
if (IsVarTerm(t)) { if (IsVarTerm(t)) {
ASP = ArenaLimit(arena); ASP = ArenaLimit(arena);
@ -353,7 +666,7 @@ static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
*HR = t; *HR = t;
Hi = HR + 1; Hi = HR + 1;
HR += 2; HR += 2;
if ((res = Yap_copy_complex_term(Hi - 2, Hi - 1, share, NULL, copy_att_vars, Hi, if ((res = copy_complex_term(Hi - 2, Hi - 1, share, copy_att_vars, Hi,
Hi PASS_REGS)) < 0) Hi PASS_REGS)) < 0)
goto error_handler; goto error_handler;
CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS); CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS);
@ -373,22 +686,108 @@ static Term CopyTermToArena(Term t, Term arena, bool share, bool copy_att_vars,
return tn; return tn;
} else if (IsAtomOrIntTerm(t)) { } else if (IsAtomOrIntTerm(t)) {
return t; return t;
} else { } else if (IsPairTerm(t)) {
Term tf;
CELL *ap;
CELL *Hi; CELL *Hi;
Hi = HR; if (share && ArenaPt(arena) > RepPair(t)) {
HR++; return t;
oldH = HR; }
HR = HB = ArenaPt(arena); HR = HB = ArenaPt(arena);
ASP = ArenaLimit(arena); ASP = ArenaLimit(arena);
if ((res = Yap_copy_complex_term(&t - 1, &t, share, NULL, copy_att_vars, Hi, ap = RepPair(t);
HR PASS_REGS)) < 0) { Hi = HR;
tf = AbsPair(HR);
HR += 2;
if ((res = copy_complex_term(ap - 1, ap + 1, share, copy_att_vars, Hi,
Hi PASS_REGS)) < 0) {
goto error_handler; goto error_handler;
} }
CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS); CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS);
return Hi[0]; return tf;
} else {
Functor f;
Term tf;
CELL *HB0;
CELL *ap;
if (share && ArenaPt(arena) > RepAppl(t)) {
return t;
} }
error_handler: HR = HB = ArenaPt(arena);
ASP = ArenaLimit(arena);
f = FunctorOfTerm(t);
HB0 = HR;
ap = RepAppl(t);
tf = AbsAppl(HR);
HR[0] = (CELL)f;
if (IsExtensionFunctor(f)) {
switch ((CELL)f) {
case (CELL) FunctorDBRef:
CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS);
return t;
case (CELL) FunctorLongInt:
if (HR > ASP - (MIN_ARENA_SIZE + 3)) {
res = -1;
goto error_handler;
}
HR[1] = ap[1];
HR[2] = EndSpecials;
HR += 3;
break;
case (CELL) FunctorDouble:
if (HR > ASP - (MIN_ARENA_SIZE + (2 + SIZEOF_DOUBLE / sizeof(CELL)))) {
res = -1;
goto error_handler;
}
HR[1] = ap[1];
#if SIZEOF_DOUBLE == 2 * SIZEOF_INT_P
HR[2] = ap[2];
HR[3] = EndSpecials;
HR += 4;
#else
HR[2] = EndSpecials;
HR += 3;
#endif
break;
case (CELL) FunctorString:
if (HR > ASP - (MIN_ARENA_SIZE + 3 + ap[1])) {
res = -1;
goto error_handler;
}
memmove(HR, ap, sizeof(CELL) * (3 + ap[1]));
HR += ap[1] + 3;
break;
default: {
UInt sz = ArenaSz(t), i;
if (HR > ASP - (MIN_ARENA_SIZE + sz)) {
res = -1;
goto error_handler;
}
for (i = 1; i < sz; i++) {
HR[i] = ap[i];
}
HR += sz;
}
}
} else {
HR += 1 + ArityOfFunctor(f);
if (HR > ASP - MIN_ARENA_SIZE) {
res = -1;
goto error_handler;
}
if ((res = copy_complex_term(ap, ap + ArityOfFunctor(f), share,
copy_att_vars, HB0 + 1, HB0 PASS_REGS)) <
0) {
goto error_handler;
}
}
CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS);
return tf;
}
error_handler:
HR = HB; HR = HB;
CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS); CloseArena(oldH, oldHB, oldASP, newarena, old_size PASS_REGS);
XREGS[arity + 1] = t; XREGS[arity + 1] = t;
@ -436,7 +835,7 @@ static Term CreateTermInArena(Term arena, Atom Na, UInt Nar, UInt arity,
Functor f = Yap_MkFunctor(Na, Nar); Functor f = Yap_MkFunctor(Na, Nar);
UInt i; UInt i;
restart: restart:
HR = HB = ArenaPt(arena); HR = HB = ArenaPt(arena);
ASP = ArenaLimit(arena); ASP = ArenaLimit(arena);
HB0 = HR; HB0 = HR;
@ -1560,7 +1959,7 @@ static Int p_nb_heap_add_to_heap(USES_REGS1) {
if (!qd) if (!qd)
return FALSE; return FALSE;
restart: restart:
hsize = IntegerOfTerm(qd[HEAP_SIZE]); hsize = IntegerOfTerm(qd[HEAP_SIZE]);
hmsize = IntegerOfTerm(qd[HEAP_MAX]); hmsize = IntegerOfTerm(qd[HEAP_MAX]);
if (hsize == hmsize) { if (hsize == hmsize) {
@ -2098,7 +2497,7 @@ static Int p_nb_beam_keys(USES_REGS1) {
CELL *pt, *ho; CELL *pt, *ho;
UInt i; UInt i;
restart: restart:
qd = GetHeap(ARG1, "beam_keys"); qd = GetHeap(ARG1, "beam_keys");
if (!qd) if (!qd)
return FALSE; return FALSE;
@ -2418,5 +2817,5 @@ void Yap_InitGlobals(void) {
} }
/** /**
@} @}
*/ */

7
C/qlyr.c
View File

@ -863,6 +863,9 @@ static void read_clauses(FILE *stream, PredEntry *pp, UInt nclauses,
} while (cl != NULL); } while (cl != NULL);
} }
if (!nclauses) { if (!nclauses) {
pp->CodeOfPred = pp->cs.p_code.TrueCodeOfPred = FAILCODE;
pp->OpcodeOfPred = FAIL_OPCODE;
return; return;
} }
while ((read_tag(stream) == QLY_START_LU_CLAUSE)) { while ((read_tag(stream) == QLY_START_LU_CLAUSE)) {
@ -947,6 +950,10 @@ static void read_clauses(FILE *stream, PredEntry *pp, UInt nclauses,
Yap_EraseStaticClause(cl, pp, CurrentModule); Yap_EraseStaticClause(cl, pp, CurrentModule);
cl = ncl; cl = ncl;
} while (cl != NULL); } while (cl != NULL);
} else if (flags & MultiFileFlag) {
pp->CodeOfPred = pp->cs.p_code.TrueCodeOfPred = FAILCODE;
pp->OpcodeOfPred = FAIL_OPCODE;
} }
for (i = 0; i < nclauses; i++) { for (i = 0; i < nclauses; i++) {
char *base = (void *)read_UInt(stream); char *base = (void *)read_UInt(stream);

2025
C/utilpreds.c
View File

File diff suppressed because it is too large Load Diff

81
C/write.c
View File

@ -77,8 +77,6 @@ typedef struct write_globs {
int last_atom_minus; int last_atom_minus;
UInt MaxDepth, MaxArgs; UInt MaxDepth, MaxArgs;
wtype lw; wtype lw;
yhandle_t sl0, sl;
bool protectedEntry;
} wglbs; } wglbs;
#define lastw wglb->lw #define lastw wglb->lw
@ -104,8 +102,9 @@ static bool callPortray(Term t, int sno USES_REGS) {
#define PROTECT(t, F) \ #define PROTECT(t, F) \
{ \ { \
yhandle_t yt = Yap_InitHandle(t); \
F; \ F; \
t = Yap_GetFromSlot(wglb->sl); \ t = Yap_PopHandle(yt); \
} }
static void wrputn(Int, struct write_globs *); static void wrputn(Int, struct write_globs *);
static void wrputf(Float, struct write_globs *); static void wrputf(Float, struct write_globs *);
@ -117,11 +116,6 @@ static wtype AtomIsSymbols(unsigned char *);
static void putAtom(Atom, int, struct write_globs *); static void putAtom(Atom, int, struct write_globs *);
static void writeTerm(Term, int, int, int, struct write_globs *, static void writeTerm(Term, int, int, int, struct write_globs *,
struct rewind_term *); struct rewind_term *);
static void writeTerm__(Term t, yhandle_t sl, int p, int depth, int rinfixarg,
struct write_globs *wglb, struct rewind_term *rwt);
static void write_list(Term t, int direction, int depth,
struct write_globs *wglb, struct rewind_term *rwt);
#define wrputc(WF, X) \ #define wrputc(WF, X) \
(X)->stream_wputc(X - GLOBAL_Stream, WF) /* writes a character */ (X)->stream_wputc(X - GLOBAL_Stream, WF) /* writes a character */
@ -273,7 +267,7 @@ static void writebig(Term t, int p, int depth, int rinfixarg,
return; return;
} else if (big_tag == BIG_RATIONAL) { } else if (big_tag == BIG_RATIONAL) {
Term trat = Yap_RatTermToApplTerm(t); Term trat = Yap_RatTermToApplTerm(t);
writeTerm__(trat,wglb->sl, p, depth, rinfixarg, wglb, rwt); writeTerm(trat, p, depth, rinfixarg, wglb, rwt);
return; return;
#endif #endif
} else if (big_tag >= USER_BLOB_START && big_tag < USER_BLOB_END) { } else if (big_tag >= USER_BLOB_START && big_tag < USER_BLOB_END) {
@ -387,7 +381,8 @@ int Yap_FormatFloat(Float f, char **s, size_t sz) {
struct write_globs wglb; struct write_globs wglb;
int sno; int sno;
sno = Yap_open_buf_write_stream(GLOBAL_Stream[LOCAL_c_output_stream].encoding, 0); sno = Yap_open_buf_write_stream(GLOBAL_Stream[LOCAL_c_output_stream].encoding,
0);
if (sno < 0) if (sno < 0)
return false; return false;
wglb.lw = separator; wglb.lw = separator;
@ -706,9 +701,7 @@ static void write_var(CELL *t, struct write_globs *wglb,
wrputs("$AT(", wglb->stream); wrputs("$AT(", wglb->stream);
write_var(t, wglb, rwt); write_var(t, wglb, rwt);
wrputc(',', wglb->stream); wrputc(',', wglb->stream);
CELL tt = (CELL)t; PROTECT(*t, writeTerm(*l, 999, 1, FALSE, wglb, &nrwt));
PROTECT(tt, writeTerm(*l, 999, 1, FALSE, wglb, &nrwt));
t = (CELL *)tt;
attv = RepAttVar(t); attv = RepAttVar(t);
wrputc(',', wglb->stream); wrputc(',', wglb->stream);
l++; l++;
@ -725,32 +718,13 @@ static void write_var(CELL *t, struct write_globs *wglb,
} }
} }
static bool check_for_loops(Term t, struct write_globs *wglb) static void write_list(Term t, int direction, int depth,
{
yhandle_t i, sl = wglb->sl;
if ((wglb->Write_Loops)) {
return false;
}
for (i=sl-1; i>wglb->sl0;i--) {
if (Yap_GetFromHandle(i) == t) {
char buf[64];
snprintf(buf,63," @{ ^^%ld } " ,sl-i);
wrputs(buf, wglb->stream);
return true;
}
}
return false;
}
static void write_list__(Term t, yhandle_t sl, int direction, int depth,
struct write_globs *wglb, struct rewind_term *rwt) { struct write_globs *wglb, struct rewind_term *rwt) {
Term ti; Term ti;
struct rewind_term nrwt; struct rewind_term nrwt;
nrwt.parent = rwt; nrwt.parent = rwt;
nrwt.u_sd.s.ptr = 0; nrwt.u_sd.s.ptr = 0;
while (1) { while (1) {
int ndirection; int ndirection;
int do_jump; int do_jump;
@ -761,18 +735,16 @@ static void write_list__(Term t, yhandle_t sl, int direction, int depth,
break; break;
if (!IsPairTerm(ti)) if (!IsPairTerm(ti))
break; break;
if (check_for_loops(ti,wglb)) return;
wglb->sl = Yap_InitHandle(ti);
ndirection = RepPair(ti) - RepPair(t); ndirection = RepPair(ti) - RepPair(t);
/* make sure we're not trapped in loops */ /* make sure we're not trapped in loops */
if (ndirection > 0) { if (ndirection > 0) {
do_jump = (direction <= 0); do_jump = (direction <= 0);
} /*else if (ndirection == 0) { } else if (ndirection == 0) {
wrputc(',', wglb->stream); wrputc(',', wglb->stream);
putAtom(AtomFoundVar, wglb->Quote_illegal, wglb); putAtom(AtomFoundVar, wglb->Quote_illegal, wglb);
lastw = separator; lastw = separator;
return; return;
} */ else { } else {
do_jump = (direction >= 0); do_jump = (direction >= 0);
} }
if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) { if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) {
@ -806,24 +778,16 @@ static void write_list__(Term t, yhandle_t sl, int direction, int depth,
} }
} }
static void write_list(Term t, int direction, int depth, static void writeTerm(Term t, int p, int depth, int rinfixarg,
struct write_globs *wglb, struct rewind_term *rwt) {
if (check_for_loops(t,wglb)) return;
yhandle_t sl = wglb->sl = Yap_InitHandle(t);
write_list__(t, sl, direction, depth,
wglb, rwt);
Yap_PopHandle(sl);
wglb->sl = sl-1;
}
static void writeTerm__(Term t, yhandle_t sl, int p, int depth, int rinfixarg,
struct write_globs *wglb, struct rewind_term *rwt) struct write_globs *wglb, struct rewind_term *rwt)
/* term to write */ /* term to write */
/* context priority */ /* context priority */
{ {
CACHE_REGS CACHE_REGS
struct rewind_term nrwt; struct rewind_term nrwt;
nrwt.parent = rwt;
nrwt.u_sd.s.ptr = 0;
if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) { if (wglb->MaxDepth != 0 && depth > wglb->MaxDepth) {
putAtom(Atom3Dots, wglb->Quote_illegal, wglb); putAtom(Atom3Dots, wglb->Quote_illegal, wglb);
return; return;
@ -857,7 +821,7 @@ static void writeTerm__(Term t, yhandle_t sl, int p, int depth, int rinfixarg,
wrputc('[', wglb->stream); wrputc('[', wglb->stream);
lastw = separator; lastw = separator;
/* we assume t was already saved in the stack */ /* we assume t was already saved in the stack */
write_list__(t, wglb->sl, 0, depth, wglb, rwt); write_list(t, 0, depth, wglb, rwt);
wrputc(']', wglb->stream); wrputc(']', wglb->stream);
lastw = separator; lastw = separator;
} }
@ -909,7 +873,7 @@ static void writeTerm__(Term t, yhandle_t sl, int p, int depth, int rinfixarg,
*p++; *p++;
lastw = separator; lastw = separator;
/* cannot use the term directly with the SBA */ /* cannot use the term directly with the SBA */
writeTerm(*p, 999, depth + 1, FALSE, wglb, &nrwt); PROTECT(t, writeTerm(*p, 999, depth + 1, FALSE, wglb, &nrwt));
if (*p) if (*p)
wrputc(',', wglb->stream); wrputc(',', wglb->stream);
argno++; argno++;
@ -1126,17 +1090,6 @@ static void writeTerm__(Term t, yhandle_t sl, int p, int depth, int rinfixarg,
} }
} }
static void writeTerm(Term t, int p, int depth, int rinfixarg,
struct write_globs *wglb, struct rewind_term *rwt)
{
if (check_for_loops(t,wglb)) return;
yhandle_t sl = wglb->sl = Yap_InitHandle(t);
writeTerm__(t, sl, p, depth, rinfixarg,
wglb, rwt);
Yap_PopHandle(sl);
wglb->sl = sl-1;
}
void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags, void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags,
int priority) int priority)
/* term to be written */ /* term to be written */
@ -1171,7 +1124,6 @@ void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags,
rwt.parent = NULL; rwt.parent = NULL;
wglb.Ignore_ops = flags & Ignore_ops_f; wglb.Ignore_ops = flags & Ignore_ops_f;
wglb.Write_strings = flags & BackQuote_String_f; wglb.Write_strings = flags & BackQuote_String_f;
wglb.Write_Loops = flags & YAP_WRITE_HANDLE_CYCLES;
if (!(flags & Ignore_cyclics_f) && false) { if (!(flags & Ignore_cyclics_f) && false) {
Term ts[2]; Term ts[2];
ts[0] = Yap_BreakRational(t, 0, ts + 1, TermNil PASS_REGS); ts[0] = Yap_BreakRational(t, 0, ts + 1, TermNil PASS_REGS);
@ -1183,8 +1135,7 @@ void Yap_plwrite(Term t, StreamDesc *mywrite, int max_depth, int flags,
} }
} }
/* protect slots for portray */ /* protect slots for portray */
wglb.sl0 = (wglb.sl = Yap_InitHandle(t))-1; writeTerm(t, priority, 1, FALSE, &wglb, &rwt);
writeTerm__(t,wglb.sl, priority, 1, FALSE, &wglb, &rwt);
if (flags & New_Line_f) { if (flags & New_Line_f) {
if (flags & Fullstop_f) { if (flags & Fullstop_f) {
wrputc('.', wglb.stream); wrputc('.', wglb.stream);

6
pl/messages.yap
View File

@ -108,7 +108,8 @@ In YAP, the info field describes:
:- use_system_module( user, [message_hook/3]). :- use_system_module( user, [message_hook/3]).
%:- start_low_level_trace. %:- start_low_level_trace.
:- multifile prolog:message/3. :- dynamic prolog:message//1.
:- multifile prolog:message//1.
%:- stop_low_level_trace. %:- stop_low_level_trace.
:- multifile user:message_hook/3. :- multifile user:message_hook/3.
@ -374,7 +375,8 @@ display_consulting( F, Level, Info, LC) -->
'$error_descriptor'(Info, Desc), '$error_descriptor'(Info, Desc),
query_exception(prologParserFile, Desc, F0), query_exception(prologParserFile, Desc, F0),
query_exception(prologParserLine, Desc, L), query_exception(prologParserLine, Desc, L),
F \= F0 integer(L)
, F \= F0
}, !, }, !,
[ '~a:~d:0: ~a raised at:'-[F0,L,Level], nl ]. [ '~a:~d:0: ~a raised at:'-[F0,L,Level], nl ].
display_consulting( F, Level, _, LC) --> display_consulting( F, Level, _, LC) -->

7
pl/undefined.yap
View File

@ -97,7 +97,7 @@ undefined_query(G0, M0, Cut) :-
'$undefp'([M0|G0],MG) :- '$undefp'([M0|G0],MG) :-
% make sure we do not loop on undefined predicates % make sure we do not loop on undefined predicates
'$undef_setup'(M0:G0, Action,Debug,Current, MGI), '$undef_setup'(M0:G0, Action,Debug,Current, MGI),
('$get_undefined_predicates'(Current, MGI, MG ) , MG) ('$get_undefined_predicates'( MGI, MG ) , MG)
-> ->
true true
; ;
@ -119,10 +119,11 @@ undefined_query(G0, M0, Cut) :-
'$handle_error'(fail,_Goal,_Mod) :- '$handle_error'(fail,_Goal,_Mod) :-
fail. fail.
'$undef_setup'(Action,Debug,Current) :- '$undef_setup'(G0,Action,Debug,Current,GI) :-
yap_flag( unknown, Action, fail), yap_flag( unknown, Action, fail),
yap_flag( debug, Debug, false), yap_flag( debug, Debug, false),
'$stop_creeping'(Current). '$stop_creeping'(Current),
'$g2i'(G0,GI).
'$g2i'(user:G, Na/Ar ) :- '$g2i'(user:G, Na/Ar ) :-
!, !,