nb_ extra stuff plus an indexing overflow fix.

git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1933 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2007-09-22 08:38:05 +00:00
parent 0860b141de
commit 0dc508eda0
4 changed files with 186 additions and 210 deletions

View File

@ -908,197 +908,6 @@ CopyTermToArena(Term t, Term arena, int share, UInt arity, Term *newarena, Term
goto restart;
}
static Term
AddTermToArena(Term t, Term arena, UInt arity, Term *newarena, Term *att_arenap, UInt min_grow)
{
UInt old_size = ArenaSz(arena);
CELL *oldH = H;
CELL *oldHB = HB;
CELL *oldASP = ASP;
int res;
#if COROUTINING
Term old_delay_arena;
#endif
restart:
#if COROUTINING
old_delay_arena = *att_arenap;
#endif
t = Deref(t);
if (IsVarTerm(t)) {
ASP = ArenaLimit(arena);
H = HB = ArenaPt(arena);
#if COROUTINING
if (IsAttachedTerm(t)) {
return 0;
}
#endif
Term tn = MkVarTerm();
if (H > ASP - 128) {
res = -1;
goto error_handler;
}
CloseArena(oldH, oldHB, oldASP, newarena, old_size);
return tn;
} else if (IsAtomOrIntTerm(t)) {
return t;
} else if (IsPairTerm(t)) {
Term tf;
CELL *ap;
CELL *Hi;
H = HB = ArenaPt(arena);
ASP = ArenaLimit(arena);
ap = RepPair(t);
if (H > ASP - (128+2)) {
res = -1;
goto error_handler;
}
Hi = H;
tf = AbsPair(H);
H[0] = ap[0];
H[1] = ap[1];
H += 2;
CloseArena(oldH, oldHB, oldASP, newarena, old_size);
return tf;
} else {
Functor f;
Term tf;
CELL *HB0;
CELL *ap;
H = HB = ArenaPt(arena);
ASP = ArenaLimit(arena);
f = FunctorOfTerm(t);
HB0 = H;
ap = RepAppl(t);
tf = AbsAppl(H);
H[0] = (CELL)f;
if (IsExtensionFunctor(f)) {
switch((CELL)f) {
case (CELL)FunctorDBRef:
CloseArena(oldH, oldHB, oldASP, newarena, old_size);
return t;
case (CELL)FunctorLongInt:
if (H > ASP - (128+3)) {
res = -1;
goto error_handler;
}
H[1] = ap[1];
H[2] = EndSpecials;
H += 3;
break;
case (CELL)FunctorDouble:
if (H > ASP - (128+(2+SIZEOF_DOUBLE/sizeof(CELL)))) {
res = -1;
goto error_handler;
}
H[1] = ap[1];
#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
H[2] = ap[2];
H[3] = EndSpecials;
H += 4;
#else
H[2] = EndSpecials;
H += 3;
#endif
break;
default:
{
UInt sz = ArenaSz(t), i;
if (H > ASP - (128+sz)) {
res = -1;
goto error_handler;
}
for (i = 1; i < sz; i++) {
H[i] = ap[i];
}
H += sz;
}
}
} else {
UInt i;
if (H+(1+ArityOfFunctor(f)) > ASP-128) {
res = -1;
goto error_handler;
}
for (i=0; i<=ArityOfFunctor(f);i++)
*H++ = *ap++;
}
CloseArena(oldH, oldHB, oldASP, newarena, old_size);
return tf;
}
error_handler:
H = HB;
CloseArena(oldH, oldHB, oldASP, newarena, old_size);
#if COROUTINING
if (old_delay_arena != MkIntTerm(0))
ResetDelayArena(old_delay_arena, att_arenap);
#endif
XREGS[arity+1] = t;
XREGS[arity+2] = arena;
XREGS[arity+3] = (CELL)newarena;
XREGS[arity+4] = (CELL)att_arenap;
{
CELL *old_top = ArenaLimit(*newarena);
ASP = oldASP;
H = oldH;
HB = oldHB;
switch (res) {
case -1:
if (arena == GlobalArena)
GlobalArenaOverflows++;
/* handle arena overflow */
/* first, take care of useless stuff */
if (!Yap_gc(arity+4, ENV, P)) {
Yap_Error(OUT_OF_STACK_ERROR,TermNil,Yap_ErrorMessage);
return 0L;
}
arena = XREGS[arity+2];
old_top = ArenaLimit(*newarena);
if (!GrowArena(arena, old_top, old_size, min_grow, arity+4)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return 0L;
}
break;
#if COROUTINING
case -3:
/* handle delay arena overflow */
old_size = DelayArenaSz(*att_arenap);
if (!GrowDelayArena(att_arenap, old_size, 0L, arity+4)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return 0L;
}
break;
#endif
case -4:
/* handle trail overflow */
if(!Yap_growtrail (sizeof(CELL) * 16 * 1024L, FALSE)) {
Yap_Error(OUT_OF_TRAIL_ERROR, TermNil, Yap_ErrorMessage);
return 0L;
}
break;
default: /* temporary space overflow */
if (!Yap_ExpandPreAllocCodeSpace(0,NULL)) {
Yap_Error(OUT_OF_AUXSPACE_ERROR, TermNil, Yap_ErrorMessage);
return 0L;
}
}
}
oldH = H;
oldHB = HB;
oldASP = ASP;
att_arenap = (Term *)XREGS[arity+4];
newarena = (CELL *)XREGS[arity+3];
arena = Deref(XREGS[arity+2]);
t = XREGS[arity+1];
old_size = ArenaSz(arena);
goto restart;
}
inline static GlobalEntry *
FindGlobalEntry(Atom at)
/* get predicate entry for ap/arity; create it if neccessary. */
@ -1174,22 +983,119 @@ garena_overflow_size(CELL *arena)
}
static Int
p_nb_copyterm(void)
p_nb_setarg(void)
{
Term to = CopyTermToArena(ARG1, GlobalArena, TRUE, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena)));
Term wheret = Deref(ARG1);
Term dest = Deref(ARG2);
Term to;
UInt arity, pos;
CELL *destp;
if (IsVarTerm(wheret)) {
Yap_Error(INSTANTIATION_ERROR,wheret,"nb_setarg");
return FALSE;
}
if (!IsIntegerTerm(wheret)) {
Yap_Error(TYPE_ERROR_INTEGER,wheret,"nb_setarg");
return FALSE;
}
pos = IntegerOfTerm(wheret);
if (IsVarTerm(dest)) {
Yap_Error(INSTANTIATION_ERROR,dest,"nb_setarg");
return FALSE;
} else if (IsPrimitiveTerm(dest)) {
arity = 0;
destp = NULL;
} else if (IsPairTerm(dest)) {
arity = 2;
destp = RepPair(dest)-1;
} else {
arity = ArityOfFunctor(FunctorOfTerm(dest));
destp = RepAppl(dest);
}
if (pos < 1 || pos > arity)
return FALSE;
to = CopyTermToArena(ARG3, GlobalArena, FALSE, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena)));
if (to == 0L)
return FALSE;
return Yap_unify(ARG2,to);
destp[pos] = to;
return TRUE;
}
static Int
p_nb_maketerm(void)
p_nb_set_shared_arg(void)
{
Term to = Deref(ARG1);
to = AddTermToArena(ARG1, GlobalArena, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena)));
Term wheret = Deref(ARG1);
Term dest = Deref(ARG2);
Term to;
UInt arity, pos;
CELL *destp;
if (IsVarTerm(wheret)) {
Yap_Error(INSTANTIATION_ERROR,wheret,"nb_setarg");
return FALSE;
}
if (!IsIntegerTerm(wheret)) {
Yap_Error(TYPE_ERROR_INTEGER,wheret,"nb_setarg");
return FALSE;
}
pos = IntegerOfTerm(wheret);
if (IsVarTerm(dest)) {
Yap_Error(INSTANTIATION_ERROR,dest,"nb_setarg");
return FALSE;
} else if (IsPrimitiveTerm(dest)) {
arity = 0;
destp = NULL;
} else if (IsPairTerm(dest)) {
arity = 2;
destp = RepPair(dest)-1;
} else {
arity = ArityOfFunctor(FunctorOfTerm(dest));
destp = RepAppl(dest);
}
if (pos < 1 || pos > arity)
return FALSE;
to = CopyTermToArena(ARG3, GlobalArena, TRUE, 2, &GlobalArena, &GlobalDelayArena, garena_overflow_size(ArenaPt(GlobalArena)));
if (to == 0L)
return FALSE;
return Yap_unify(ARG2,to);
destp[pos] = to;
return TRUE;
}
static Int
p_nb_linkarg(void)
{
Term wheret = Deref(ARG1);
Term dest = Deref(ARG2);
UInt arity, pos;
CELL *destp;
if (IsVarTerm(wheret)) {
Yap_Error(INSTANTIATION_ERROR,wheret,"nb_setarg");
return FALSE;
}
if (!IsIntegerTerm(wheret)) {
Yap_Error(TYPE_ERROR_INTEGER,wheret,"nb_setarg");
return FALSE;
}
pos = IntegerOfTerm(wheret);
if (IsVarTerm(dest)) {
Yap_Error(INSTANTIATION_ERROR,dest,"nb_setarg");
return FALSE;
} else if (IsPrimitiveTerm(dest)) {
arity = 0;
destp = NULL;
} else if (IsPairTerm(dest)) {
arity = 2;
destp = RepPair(dest)-1;
} else {
arity = ArityOfFunctor(FunctorOfTerm(dest));
destp = RepAppl(dest);
}
if (pos < 1 || pos > arity)
return FALSE;
destp[pos] = Deref(ARG3);
return TRUE;
}
static Int
@ -2480,12 +2386,13 @@ void Yap_InitGlobals(void)
Yap_InitCPred("arena_size", 1, p_default_arena_size, 0);
Yap_InitCPred("b_setval", 2, p_b_setval, SafePredFlag);
Yap_InitCPred("b_getval", 2, p_nb_getval, SafePredFlag);
Yap_InitCPred("nb_copy_term", 2, p_nb_copyterm, 0L);
Yap_InitCPred("nb_make_term", 2, p_nb_maketerm, 0L);
Yap_InitCPred("nb_setval", 2, p_nb_setval, 0L);
Yap_InitCPred("nb_set_shared_val", 2, p_nb_set_shared_val, 0L);
Yap_InitCPred("nb_linkval", 2, p_nb_linkval, 0L);
Yap_InitCPred("nb_getval", 2, p_nb_getval, SafePredFlag);
Yap_InitCPred("nb_setarg", 3, p_nb_setarg, 0L);
Yap_InitCPred("nb_set_shared_arg", 3, p_nb_set_shared_arg, 0L);
Yap_InitCPred("nb_linkarg", 3, p_nb_linkarg, 0L);
Yap_InitCPred("nb_delete", 1, p_nb_delete, 0L);
Yap_InitCPredBack("$nb_current", 1, 1, init_current_nb, cont_current_nb, SafePredFlag);
CurrentModule = GLOBALS_MODULE;

View File

@ -11,8 +11,11 @@
* File: index.c *
* comments: Indexing a Prolog predicate *
* *
* Last rev: $Date: 2007-06-20 13:48:45 $,$Author: vsc $ *
* Last rev: $Date: 2007-09-22 08:38:05 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.186 2007/06/20 13:48:45 vsc
* fix bug in index emulator
*
* Revision 1.185 2007/05/02 11:01:37 vsc
* get rid of type punning warnings.
*
@ -3338,7 +3341,7 @@ valid_instructions(yamop *end, yamop *cl)
}
static UInt
groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp)
groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp, struct intermediates *cint)
{
UInt groups = 0;
@ -3392,6 +3395,21 @@ groups_in(ClauseDef *min, ClauseDef *max, GroupDef *grp)
}
groups++;
grp++;
while (grp+16 > (GroupDef *)Yap_TrailTop) {
UInt sz = (groups+16)*sizeof(GroupDef);
#if USE_SYSTEM_MALLOC
Yap_Error_Size = sz;
/* grow stack */
save_machine_regs();
longjmp(cint->CompilerBotch,4);
#else
if (!Yap_growtrail(sz, TRUE)) {
save_machine_regs();
longjmp(cint->CompilerBotch,4);
return 0;
}
#endif
}
}
return groups;
}
@ -4365,7 +4383,7 @@ do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno,
} else {
found_pvar = cls_info(min, max, argno);
}
ngroups = groups_in(min, max, group);
ngroups = groups_in(min, max, group, cint);
if (IsVarTerm(t)) {
lablx = new_label(cint);
Yap_emit(label_op, lablx, Zero, cint);
@ -4390,7 +4408,7 @@ do_index(ClauseDef *min, ClauseDef* max, struct intermediates *cint, UInt argno,
} else {
found_pvar = cls_info(min, max, argno);
}
ngroups = groups_in(min, max, group);
ngroups = groups_in(min, max, group, cint);
}
labl0 = labl = new_label(cint);
} else {
@ -4527,7 +4545,7 @@ do_compound_index(ClauseDef *min0, ClauseDef* max0, Term* sreg, struct intermedi
cl++;
}
group = (GroupDef *)top;
ngroups = groups_in(min, max, group);
ngroups = groups_in(min, max, group, cint);
if (ngroups == 1 && group->VarClauses == 0) {
/* ok, we are doing a sub-argument */
/* process group */
@ -4566,7 +4584,7 @@ do_dbref_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cin
cl->Tag = cl->u.t_ptr;
cl++;
}
ngroups = groups_in(min, max, group);
ngroups = groups_in(min, max, group, cint);
if (ngroups > 1 || group->VarClauses) {
return do_index(min, max, cint, argno+1, fail_l, first, clleft, top);
} else {
@ -4603,7 +4621,7 @@ do_blob_index(ClauseDef *min, ClauseDef* max, Term t, struct intermediates *cint
}
cl++;
}
ngroups = groups_in(min, max, group);
ngroups = groups_in(min, max, group, cint);
if (ngroups > 1 || group->VarClauses) {
return do_index(min, max, cint, argno+1, fail_l, first, clleft, top);
} else {

View File

@ -16,6 +16,8 @@
<h2>Yap-5.1.3:</h2>
<ul>
<li> NEW: add nb_*arg versions.</li>
<li> FIXED: overflow in indexing code (obs from Jesse Davis).</li>
<li> NEW: improve nb_ routines with linkvar and set_shared_var.</li>
<li> NEW: make copy_term share ground-terms and add non-sharing
version, duplicate_term/2.</li>

View File

@ -5867,7 +5867,7 @@ order of dispatch.
@end table
@node Term Modification, Profiling, OS, Top
@node Term Modification, Global Variables, OS, Top
@section Term Modification
@cindex updating terms
@ -5923,14 +5923,14 @@ Unify the current value of mutable term @var{M} with term @var{D}.
Set the current value of mutable term @var{M} to term @var{D}.
@end table
@node Global Variables, Profiling, Profiling, Term Modification, Top
@node Global Variables, Profiling, Term Modification, Top
@section Global Variables
@cindex global variables
Global variables are associations between names (atoms) and
terms. They differ in various ways from storing information using
@node{assert/1} or @node{recorda/3}.
@code{assert/1} or @code{recorda/3}.
@itemize @bullet
@item The value lives on the Prolog (global) stack. This implies that
@ -6053,6 +6053,55 @@ A = a(_A),
B = t(C,a(_A)) ?
@end example
@item nb_setarg(+@{Arg], +@var{Term}, +@var{Value})
@findex nb_setarg/3
@snindex nb_setarg/3
@cnindex nb_setarg/3
Assigns the @var{Arg}-th argument of the compound term @var{Term} with
the given @var{Value} as setarg/3, but on backtracking the assignment
is not reversed. If @var{Term} is not atomic, it is duplicated using
duplicate_term/2. This predicate uses the same technique as
@code{nb_setval/2}. We therefore refer to the description of
@code{nb_setval/2} for details on non-backtrackable assignment of
terms. This predicate is compatible to GNU-Prolog
@code{setarg(A,T,V,false)}, removing the type-restriction on
@var{Value}. See also @code{nb_linkarg/3}. Below is an example for
counting the number of solutions of a goal. Note that this
implementation is thread-safe, reentrant and capable of handling
exceptions. Realising these features with a traditional implementation
based on assert/retract or flag/3 is much more complicated.
@example
succeeds_n_times(Goal, Times) :-
Counter = counter(0),
( Goal,
arg(1, Counter, N0),
N is N0 + 1,
nb_setarg(1, Counter, N),
fail
; arg(1, Counter, Times)
).
@end example
@item nb_set_shared_arg(+@var{Arg}, +@var{Term}, +@var{Value})
@findex nb_set_shared_arg/3
@snindex nb_set_shared_arg/3
@cnindex nb_set_shared_arg/3
As @code{nb_setarg/3}, but like @code{nb_linkval/2} it does not
duplicate the global sub-terms in @var{Value}. Use with extreme care
and consult the documentation of @code{nb_linkval/2} before use.
@item nb_linkarg(+@var{Arg}, +@var{Term}, +@var{Value})
@findex nb_linkarg/3
@snindex nb_lnkarg/3
@cnindex nb_linkarg/3
As @code{nb_setarg/3}, but like @code{nb_linkval/2} it does not
duplicate @var{Value}. Use with extreme care and consult the
documentation of @code{nb_linkval/2} before use.
@item nb_current(?@var{Name}, ?@var{Value})
@findex nb_current/2