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

valgrind it!

Browse Source 
enable atom garbage collection.


git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@2055 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2008-01-23 17:57:56 +00:00
parent 2a7d514d3f
commit 637f381d94
31 changed files with 595 additions and 227 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
C/absmi.c
View File

@ -10,8 +10,11 @@
* *
* File: absmi.c *
* comments: Portable abstract machine interpreter *
* Last rev: $Date: 2007-11-28 23:52:14 $,$Author: vsc $ *
* Last rev: $Date: 2008-01-23 17:57:44 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.232 2007/11/28 23:52:14 vsc
* junction tree algorithm
*
* Revision 1.231 2007/11/26 23:43:07 vsc
* fixes to support threads and assert correctly, even if inefficiently.
*
@ -751,6 +754,7 @@ Yap_absmi(int inp)
CELL cut_b = LCL0-(CELL *)(SREG[E_CB]);
saveregs();
/* do a garbage collection first to check if we can recover memory */
if (!Yap_growheap(FALSE, 0, NULL)) {
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, "YAP failed to grow heap: %s", Yap_ErrorMessage);
setregs();
@ -11514,6 +11518,7 @@ Yap_absmi(int inp)
*/
HBREG = H;
B = (choiceptr) H;
B->cp_h = H;
SET_BB(B);
save_hb();
opresult = Yap_IUnify(d0, d1);

5
C/agc.c
View File

@ -270,7 +270,7 @@ mark_trail(void)
static void
mark_local(void)
{
register CELL *pt;
CELL *pt;
/* Adjusting the local */
pt = LCL0;
@ -434,9 +434,12 @@ atom_gc(void)
UInt time_start, agc_time;
#if defined(YAPOR) || defined(THREADS)
return;
#endif
if (Yap_GetValue(AtomGcTrace) != TermNil)
gc_trace = 1;
agc_calls++;
agc_collected = 0;

12
C/alloc.c
View File

@ -12,7 +12,7 @@
* Last rev: *
* mods: *
* comments: allocating space *
* version:$Id: alloc.c,v 1.86 2006-05-19 14:31:31 vsc Exp $ *
* version:$Id: alloc.c,v 1.87 2008-01-23 17:57:44 vsc Exp $ *
*************************************************************************/
#ifdef SCCS
static char SccsId[] = "%W% %G%";
@ -171,9 +171,11 @@ Yap_ExpandPreAllocCodeSpace(UInt sz0, void *cip)
UInt sz = ScratchPad.msz;
if (sz0 < SCRATCH_INC_SIZE)
sz0 = SCRATCH_INC_SIZE;
ScratchPad.msz =
ScratchPad.sz =
sz = sz + sz0;
if (sz0 < ScratchPad.sz)
sz = ScratchPad.sz+sz0;
else
sz = sz0;
sz = AdjustLargePageSize(sz+sz/4);
#if INSTRUMENT_MALLOC
if (reallocs % 1024*4 == 0)
@ -214,6 +216,8 @@ void
Yap_InitHeap(void *heap_addr)
{
InitHeap();
Yap_HoleSize = 0;
HeapMax = 0;
}
static void

8
C/amasm.c
View File

@ -11,8 +11,11 @@
* File: amasm.c *
* comments: abstract machine assembler *
* *
* Last rev: $Date: 2007-11-26 23:43:07 $ *
* Last rev: $Date: 2008-01-23 17:57:44 $ *
* $Log: not supported by cvs2svn $
* Revision 1.98 2007/11/26 23:43:07 vsc
* fixes to support threads and assert correctly, even if inefficiently.
*
* Revision 1.97 2007/11/07 09:25:27 vsc
* speedup meta-calls
*
@ -460,8 +463,9 @@ static yamop *
a_lucl(op_numbers opcode, yamop *code_p, int pass_no, struct intermediates *cip, clause_info *cla)
{
if (pass_no) {
LogUpdIndex *lcl = (LogUpdIndex *)cip->code_addr;
code_p->opc = emit_op(opcode);
code_p->u.Ill.I = (LogUpdIndex *)cip->code_addr;
code_p->u.Ill.I = lcl;
cip->current_try_lab = &code_p->u.Ill.l1;
cip->current_trust_lab = &code_p->u.Ill.l2;
code_p->u.Ill.s = cip->cpc->rnd3;

305
C/cdmgr.c
View File

@ -11,8 +11,12 @@
* File: cdmgr.c *
* comments: Code manager *
* *
* Last rev: $Date: 2007-12-26 19:50:40 $,$Author: vsc $ *
* Last rev: $Date: 2008-01-23 17:57:44 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.217 2007/12/26 19:50:40 vsc
* new version of clp(fd)
* fix deadlock with empty args facts in clause/2.
*
* Revision 1.216 2007/12/23 22:48:44 vsc
* recover stack space
*
@ -589,7 +593,7 @@ static_in_use(PredEntry *p, int check_everything)
#else
CELL pflags = p->PredFlags;
if (pflags & (DynamicPredFlag|LogUpdatePredFlag)) {
return (FALSE);
return FALSE;
}
if (STATIC_PREDICATES_MARKED) {
return (p->PredFlags & InUsePredFlag);
@ -964,37 +968,40 @@ decrease_ref_counter(yamop *ptr, yamop *b, yamop *e, yamop *sc)
}
}
static void
static yamop *
release_wcls(yamop *cop, OPCODE ecs)
{
if (cop->opc == ecs) {
cop->u.sp.s3--;
if (!cop->u.sp.s3) {
LOCK(ExpandClausesListLock);
if (ExpandClausesFirst == cop)
ExpandClausesFirst = cop->u.sp.snext;
if (ExpandClausesLast == cop) {
ExpandClausesLast = cop->u.sp.sprev;
}
if (cop->u.sp.sprev) {
cop->u.sp.sprev->u.sp.snext = cop->u.sp.snext;
}
if (cop->u.sp.snext) {
cop->u.sp.snext->u.sp.sprev = cop->u.sp.sprev;
}
UNLOCK(ExpandClausesListLock);
#if DEBUG
Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sp)+cop->u.sp.s1*sizeof(yamop *));
UInt sz = (UInt)NEXTOP((yamop *)NULL,sp)+cop->u.sp.s1*sizeof(yamop *);
LOCK(ExpandClausesListLock);
#ifdef DEBUG
Yap_expand_clauses_sz -= sz;
Yap_ExpandClauses--;
#endif
Yap_InformOfRemoval((CODEADDR)cop);
if (cop->u.sp.p->PredFlags & LogUpdatePredFlag) {
Yap_LUIndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sp)+cop->u.sp.s1*sizeof(yamop *);
Yap_LUIndexSpace_EXT -= sz;
} else {
Yap_IndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sp)+cop->u.sp.s1*sizeof(yamop *);
Yap_IndexSpace_EXT -= sz;
}
if (ExpandClausesFirst == cop)
ExpandClausesFirst = cop->u.sp.snext;
if (ExpandClausesLast == cop) {
ExpandClausesLast = cop->u.sp.sprev;
}
if (cop->u.sp.sprev) {
cop->u.sp.sprev->u.sp.snext = cop->u.sp.snext;
}
if (cop->u.sp.snext) {
cop->u.sp.snext->u.sp.sprev = cop->u.sp.sprev;
}
UNLOCK(ExpandClausesListLock);
Yap_InformOfRemoval((CODEADDR)cop);
Yap_FreeCodeSpace((char *)cop);
}
}
return FAILCODE;
}
@ -1015,13 +1022,9 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
ipc = NEXTOP(ipc,e);
break;
case _lock_lu:
/* just skip for now, but should worry about locking */
ipc = NEXTOP(ipc,p);
break;
case _unlock_lu:
/* just skip for now, but should worry about locking */
/* locking should be done already */
ipc = NEXTOP(ipc,e);
break;
case _retry_profiled:
case _count_retry:
ipc = NEXTOP(ipc,p);
@ -1065,7 +1068,6 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
Yap_FreedCps++;
#endif
}
end = ipc;
break;
case _trust_logical:
case _count_trust_logical:
@ -1077,56 +1079,60 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
decrease_ref_counter(ipc->u.lld.d->ClCode, beg, end, suspend_code);
Yap_LUIndexSpace_CP -= (UInt)NEXTOP((yamop *)NULL,lld);
Yap_FreeCodeSpace((ADDR)ipc);
end = ipc;
return;
case _enter_lu_pred:
if (ipc->u.Ill.I->ClFlags & InUseMask || ipc->u.Ill.I->ClRefCount)
return;
{
yamop *oipc = ipc;
if (ipc->u.Ill.I->ClFlags & InUseMask || ipc->u.Ill.I->ClRefCount)
return;
#ifdef DEBUG
Yap_DirtyCps+=ipc->u.Ill.s;
Yap_LiveCps-=ipc->u.Ill.s;
Yap_DirtyCps+=ipc->u.Ill.s;
Yap_LiveCps-=ipc->u.Ill.s;
#endif
ipc = ipc->u.Ill.l1;
end = ipc;
ipc = ipc->u.Ill.l1;
/* in case we visit again */
oipc->u.Ill.l1 = FAILCODE;
oipc->u.Ill.s = 0;
}
break;
case _try_in:
case _jump:
case _jump_if_var:
release_wcls(ipc->u.l.l, ecs);
ipc->u.l.l = release_wcls(ipc->u.l.l, ecs);
ipc = NEXTOP(ipc,l);
break;
/* instructions type xl */
case _jump_if_nonvar:
release_wcls(ipc->u.xll.l1, ecs);
ipc->u.xll.l1 = release_wcls(ipc->u.xll.l1, ecs);
ipc = NEXTOP(ipc,xll);
break;
/* instructions type e */
case _switch_on_type:
release_wcls(ipc->u.llll.l1, ecs);
release_wcls(ipc->u.llll.l2, ecs);
release_wcls(ipc->u.llll.l3, ecs);
release_wcls(ipc->u.llll.l4, ecs);
ipc->u.llll.l1 = release_wcls(ipc->u.llll.l1, ecs);
ipc->u.llll.l2 = release_wcls(ipc->u.llll.l2, ecs);
ipc->u.llll.l3 = release_wcls(ipc->u.llll.l3, ecs);
ipc->u.llll.l4 = release_wcls(ipc->u.llll.l4, ecs);
ipc = NEXTOP(ipc,llll);
break;
case _switch_list_nl:
release_wcls(ipc->u.ollll.l1, ecs);
release_wcls(ipc->u.ollll.l2, ecs);
release_wcls(ipc->u.ollll.l3, ecs);
release_wcls(ipc->u.ollll.l4, ecs);
ipc->u.ollll.l1 = release_wcls(ipc->u.ollll.l1, ecs);
ipc->u.ollll.l2 = release_wcls(ipc->u.ollll.l2, ecs);
ipc->u.ollll.l3 = release_wcls(ipc->u.ollll.l3, ecs);
ipc->u.ollll.l4 = release_wcls(ipc->u.ollll.l4, ecs);
ipc = NEXTOP(ipc,ollll);
break;
case _switch_on_arg_type:
release_wcls(ipc->u.xllll.l1, ecs);
release_wcls(ipc->u.xllll.l2, ecs);
release_wcls(ipc->u.xllll.l3, ecs);
release_wcls(ipc->u.xllll.l4, ecs);
ipc->u.xllll.l1 = release_wcls(ipc->u.xllll.l1, ecs);
ipc->u.xllll.l2 = release_wcls(ipc->u.xllll.l2, ecs);
ipc->u.xllll.l3 = release_wcls(ipc->u.xllll.l3, ecs);
ipc->u.xllll.l4 = release_wcls(ipc->u.xllll.l4, ecs);
ipc = NEXTOP(ipc,xllll);
break;
case _switch_on_sub_arg_type:
release_wcls(ipc->u.sllll.l1, ecs);
release_wcls(ipc->u.sllll.l2, ecs);
release_wcls(ipc->u.sllll.l3, ecs);
release_wcls(ipc->u.sllll.l4, ecs);
ipc->u.sllll.l1 = release_wcls(ipc->u.sllll.l1, ecs);
ipc->u.sllll.l2 = release_wcls(ipc->u.sllll.l2, ecs);
ipc->u.sllll.l3 = release_wcls(ipc->u.sllll.l3, ecs);
ipc->u.sllll.l4 = release_wcls(ipc->u.sllll.l4, ecs);
ipc = NEXTOP(ipc,sllll);
break;
case _if_not_then:
@ -1140,6 +1146,8 @@ cleanup_dangling_indices(yamop *ipc, yamop *beg, yamop *end, yamop *suspend_code
case _go_on_cons:
ipc = NEXTOP(ipc,sssl);
break;
case _op_fail:
return;
default:
Yap_Error(SYSTEM_ERROR,TermNil,"Bug in Indexing Code: opcode %d", op);
return;
@ -1168,10 +1176,9 @@ decrease_log_indices(LogUpdIndex *c, yamop *suspend_code)
OPCODE ecs = Yap_opcode(_expand_clauses);
while (beg < end) {
yamop *cop;
cop = (yamop *)beg[1];
yamop **x = (yamop **)(beg+1);
beg += 2;
release_wcls(cop, ecs);
*x = release_wcls(*x, ecs);
}
return;
}
@ -1221,6 +1228,7 @@ kill_children(LogUpdIndex *c, PredEntry *ap)
c->ClRefCount--;
}
/* assumes c is already locked */
static void
kill_off_lu_block(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
@ -1242,17 +1250,14 @@ kill_off_lu_block(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
}
}
}
{
LogUpdIndex *parent = DBErasedIList, *c0 = NULL;
while (parent != NULL) {
if (c == parent) {
if (c0) c0->SiblingIndex = c->SiblingIndex;
else DBErasedIList = c->SiblingIndex;
break;
}
c0 = parent;
parent = parent->SiblingIndex;
}
decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
/* remove from list */
if (c->SiblingIndex)
c->SiblingIndex->PrevSiblingIndex = c->PrevSiblingIndex;
if (c->PrevSiblingIndex) {
c->PrevSiblingIndex->SiblingIndex = c->SiblingIndex;
} else {
DBErasedIList = c->SiblingIndex;
}
Yap_InformOfRemoval((CODEADDR)c);
if (c->ClFlags & SwitchTableMask)
@ -1288,10 +1293,16 @@ kill_first_log_iblock(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
RemoveMainIndex(ap);
}
}
decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
/* make sure that a child cannot remove us */
kill_children(c, ap);
/* check if we are still the main index */
decrease_log_indices(c, (yamop *)&(ap->cs.p_code.ExpandCode));
/* always add to erased list */
c->SiblingIndex = DBErasedIList;
c->PrevSiblingIndex = NULL;
if (DBErasedIList)
DBErasedIList->PrevSiblingIndex = c;
DBErasedIList = c;
if (!((c->ClFlags & InUseMask) || c->ClRefCount)) {
kill_off_lu_block(c, parent, ap);
} else {
@ -1306,8 +1317,6 @@ kill_first_log_iblock(LogUpdIndex *c, LogUpdIndex *parent, PredEntry *ap)
parent->ParentIndex->ClRefCount++;
parent->ClRefCount--;
}
c->SiblingIndex = DBErasedIList;
DBErasedIList = c;
}
}
@ -1536,6 +1545,15 @@ add_first_static(PredEntry *p, yamop *cp, int spy_flag)
}
p->cs.p_code.TrueCodeOfPred = pt;
p->cs.p_code.FirstClause = p->cs.p_code.LastClause = cp;
p->OpcodeOfPred = pt->opc;
#if defined(YAPOR) || defined(THREADS)
if (p->PredFlags & LogUpdatePredFlag &&
p->ModuleOfPred != IDB_MODULE) {
p->OpcodeOfPred = LOCKPRED_OPCODE;
p->CodeOfPred = (yamop *)(&(p->OpcodeOfPred));
} else
#endif
p->CodeOfPred = pt;
p->cs.p_code.NOfClauses = 1;
p->StatisticsForPred.NOfEntries = 0;
p->StatisticsForPred.NOfHeadSuccesses = 0;
@ -4944,6 +4962,144 @@ p_continue_log_update_clause(void)
return fetch_next_lu_clause(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_cp, FALSE);
}
static Int
fetch_next_lu_clause_erase(PredEntry *pe, yamop *i_code, Term th, Term tb, Term tr, yamop *cp_ptr, int first_time)
{
LogUpdClause *cl;
Term rtn;
Term Terms[3];
Terms[0] = th;
Terms[1] = tb;
Terms[2] = tr;
cl = Yap_FollowIndexingCode(pe, i_code, Terms, NEXTOP(PredLogUpdClauseErase->CodeOfPred,ld), cp_ptr);
th = Terms[0];
tb = Terms[1];
tr = Terms[2];
/* don't do this!! I might have stored a choice-point and changed ASP
Yap_RecoverSlots(3);
*/
if (cl == NULL) {
UNLOCK(pe->PELock);
return FALSE;
}
rtn = MkDBRefTerm((DBRef)cl);
#if defined(YAPOR) || defined(THREADS)
TRAIL_CLREF(cl); /* So that fail will erase it */
INC_CLREF_COUNT(cl);
#else
if (!(cl->ClFlags & InUseMask)) {
cl->ClFlags |= InUseMask;
TRAIL_CLREF(cl); /* So that fail will erase it */
}
#endif
if (cl->ClFlags & FactMask) {
if (!Yap_unify_constant(tb, MkAtomTerm(AtomTrue)) ||
!Yap_unify(tr, rtn)) {
UNLOCK(pe->PELock);
return FALSE;
}
if (pe->ArityOfPE) {
Functor f = FunctorOfTerm(th);
UInt arity = ArityOfFunctor(f), i;
CELL *pt = RepAppl(th)+1;
for (i=0; i<arity; i++) {
XREGS[i+1] = pt[i];
}
/* don't need no ENV */
if (first_time) {
CP = P;
ENV = YENV;
YENV = ASP;
YENV[E_CB] = (CELL) B;
}
P = cl->ClCode;
#if defined(YAPOR) || defined(THREADS)
PP = pe;
#endif
} else {
/* we don't actually need to execute code */
UNLOCK(pe->PELock);
}
Yap_ErLogUpdCl(cl);
return TRUE;
} else {
Term t;
Int res;
while ((t = Yap_FetchTermFromDB(cl->ClSource)) == 0L) {
if (first_time) {
ARG5 = th;
ARG6 = tb;
ARG7 = tr;
if (Yap_Error_TYPE == OUT_OF_ATTVARS_ERROR) {
Yap_Error_TYPE = YAP_NO_ERROR;
if (!Yap_growglobal(NULL)) {
UNLOCK(pe->PELock);
Yap_Error(OUT_OF_ATTVARS_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
} else {
Yap_Error_TYPE = YAP_NO_ERROR;
if (!Yap_gcl(Yap_Error_Size, 7, YENV, P)) {
UNLOCK(pe->PELock);
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
}
th = ARG5;
tb = ARG6;
tr = ARG7;
} else {
ARG6 = th;
ARG7 = tb;
ARG8 = tr;
if (!Yap_gcl(Yap_Error_Size, 8, ENV, CP)) {
UNLOCK(pe->PELock);
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return FALSE;
}
th = ARG6;
tb = ARG7;
tr = ARG8;
}
}
res = Yap_unify(th, ArgOfTerm(1,t)) &&
Yap_unify(tb, ArgOfTerm(2,t)) &&
Yap_unify(tr, rtn);
if (res)
Yap_ErLogUpdCl(cl);
UNLOCK(pe->PELock);
return res;
}
}
static Int /* $hidden_predicate(P) */
p_log_update_clause_erase(void)
{
PredEntry *pe;
Term t1 = Deref(ARG1);
Int ret;
pe = get_pred(t1, Deref(ARG2), "clause/3");
if (pe == NULL || EndOfPAEntr(pe))
return FALSE;
LOCK(pe->PELock);
ret = fetch_next_lu_clause_erase(pe, pe->CodeOfPred, t1, ARG3, ARG4, P, TRUE);
return ret;
}
static Int /* $hidden_predicate(P) */
p_continue_log_update_clause_erase(void)
{
PredEntry *pe = (PredEntry *)IntegerOfTerm(Deref(ARG1));
yamop *ipc = (yamop *)IntegerOfTerm(ARG2);
LOCK(pe->PELock);
return fetch_next_lu_clause_erase(pe, ipc, Deref(ARG3), ARG4, ARG5, B->cp_cp, FALSE);
}
static Int
fetch_next_lu_clause0(PredEntry *pe, yamop *i_code, Term th, Term tb, yamop *cp_ptr, int first_time)
{
@ -5097,6 +5253,7 @@ Yap_UpdateTimestamps(PredEntry *ap)
choiceptr bptr = B;
yamop *cl0 = NEXTOP(PredLogUpdClause0->CodeOfPred,ld);
yamop *cl = NEXTOP(PredLogUpdClause->CodeOfPred,ld);
yamop *cle = NEXTOP(PredLogUpdClauseErase->CodeOfPred,ld);
UInt ar = ap->ArityOfPE;
UInt *arp, *top, *base;
LogUpdClause *lcl;
@ -5137,7 +5294,7 @@ Yap_UpdateTimestamps(PredEntry *ap)
bptr = bptr->cp_b;
break;
case _retry:
if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl) &&
if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl || bptr->cp_ap == cle) &&
((PredEntry *)IntegerOfTerm(bptr->cp_args[0]) == ap)) {
UInt ts = IntegerOfTerm(bptr->cp_args[5]);
if (ts != arp[0]) {
@ -5193,7 +5350,7 @@ Yap_UpdateTimestamps(PredEntry *ap)
bptr = bptr->cp_b;
break;
case _retry:
if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl) &&
if ((bptr->cp_ap == cl0 || bptr->cp_ap == cl || bptr->cp_ap == cle) &&
((PredEntry *)IntegerOfTerm(bptr->cp_args[0]) == ap)) {
UInt ts = IntegerOfTerm(bptr->cp_args[5]);
while (ts != arp[0])
@ -5601,8 +5758,8 @@ p_predicate_erased_statistics(void)
PredEntry *pe;
LogUpdClause *cl = DBErasedList;
LogUpdIndex *icl = DBErasedIList;
Term tpred = ArgOfTerm(1,Deref(ARG1));
Term tmod = ArgOfTerm(2,Deref(ARG1));
Term tpred = ArgOfTerm(2,Deref(ARG1));
Term tmod = ArgOfTerm(1,Deref(ARG1));
if (EndOfPAEntr(pe=get_pred(tpred, tmod, "predicate_erased_statistics")))
return FALSE;
@ -5966,6 +6123,8 @@ Yap_InitCdMgr(void)
Yap_InitCPred("$current_stack", 1, p_current_stack, SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$log_update_clause", 4, p_log_update_clause, SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$continue_log_update_clause", 5, p_continue_log_update_clause, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$log_update_clause_erase", 4, p_log_update_clause_erase, SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$continue_log_update_clause_erase", 5, p_continue_log_update_clause_erase, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$log_update_clause", 3, p_log_update_clause0, SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$continue_log_update_clause", 4, p_continue_log_update_clause0, SafePredFlag|SyncPredFlag|HiddenPredFlag);
Yap_InitCPred("$static_clause", 4, p_static_clause, SyncPredFlag|HiddenPredFlag);

14
C/dbase.c
View File

@ -3807,14 +3807,10 @@ p_total_erased(void)
LogUpdClause *cl = DBErasedList;
LogUpdIndex *icl = DBErasedIList;
int i=200000;
while (cl && i>0)
cl=cl->ClNext,i--;
if (cl)
fprintf(stderr,"cl=%p\n",cl);
/* only for log upds */
while (cl) {
cls++;
fprintf(stderr,"cl=%p, %x %d\n",cl,cl->ClFlags,cl->ClRefCount);
sz += cl->ClSize;
cl = cl->ClNext;
}
@ -4007,6 +4003,7 @@ static void
complete_lu_erase(LogUpdClause *clau)
{
DBRef *cp;
if (clau->ClSource)
cp = clau->ClSource->DBRefs;
else
@ -4015,6 +4012,7 @@ complete_lu_erase(LogUpdClause *clau)
return;
}
if (clau->ClFlags & LogUpdRuleMask &&
clau->ClExt &&
clau->ClExt->u.EC.ClRefs > 0) {
return;
}
@ -4116,9 +4114,12 @@ EraseLogUpdCl(LogUpdClause *clau)
ap->LastCallOfPred = LUCALL_RETRACT;
} else {
/* OK, there's noone left */
#ifndef THREADS
if (ap->cs.p_code.NOfClauses == 0) {
/* Other threads may hold refs to clauses */
ap->TimeStampOfPred = 0L;
}
#endif
/* fprintf(stderr,"- %x--%d--%ul\n",ap,ap->TimeStampOfPred,ap->ArityOfPE);*/
ap->LastCallOfPred = LUCALL_ASSERT;
}
@ -4201,8 +4202,9 @@ PrepareToEraseLogUpdClause(LogUpdClause *clau, DBRef dbr)
PredEntry *p = clau->ClPred;
yamop *cl = code_p;
if (clau->ClFlags & ErasedMask)
if (clau->ClFlags & ErasedMask) {
return;
}
clau->ClFlags |= ErasedMask;
if (p->cs.p_code.FirstClause != cl) {
/* we are not the first clause... */

4
C/exec.c
View File

@ -1983,9 +1983,11 @@ Yap_InitYaamRegs(void)
CreepFlag = CalculateStackGap();
UNLOCK(SignalLock);
EX = 0L;
init_stack(0, NULL, TRUE, NULL);
/* for slots to work */
Yap_StartSlots();
init_stack(0, NULL, TRUE, NULL);
/* the first real choice-point will also have AP=FAIL */
Yap_StartSlots();
GlobalArena = TermNil;
h0var = MkVarTerm();
#if COROUTINING

3
C/globals.c
View File

@ -488,6 +488,9 @@ copy_complex_term(register CELL *pt0, register CELL *pt0_end, int share, CELL *p
H[1] = ap2[1];
H[2] = EndSpecials;
H += 3;
if (H > ASP - 128) {
goto overflow;
}
break;
case (CELL)FunctorDouble:
if (H > ASP - (128+(2+SIZEOF_DOUBLE/sizeof(CELL)))) {

113
C/grow.c
View File

@ -67,13 +67,13 @@ STATIC_PROTO(void MoveLocalAndTrail, (void));
STATIC_PROTO(void SetHeapRegs, (void));
STATIC_PROTO(void AdjustTrail, (int));
STATIC_PROTO(void AdjustLocal, (void));
STATIC_PROTO(void AdjustGlobal, (void));
STATIC_PROTO(void AdjustGlobal, (long));
STATIC_PROTO(void AdjustGrowStack, (void));
STATIC_PROTO(int static_growheap, (long,int,struct intermediates *,tr_fr_ptr *, TokEntry **, VarEntry **));
STATIC_PROTO(void cpcellsd, (CELL *, CELL *, CELL));
STATIC_PROTO(CELL AdjustAppl, (CELL));
STATIC_PROTO(CELL AdjustPair, (CELL));
STATIC_PROTO(void AdjustStacksAndTrail, (void));
STATIC_PROTO(void AdjustStacksAndTrail, (long));
STATIC_PROTO(void AdjustRegs, (int));
static void
@ -127,6 +127,7 @@ SetHeapRegs(void)
OldTR = TR;
OldHeapBase = Yap_HeapBase;
OldHeapTop = HeapTop;
OldDelayTop = CurrentDelayTop;
/* Adjust stack addresses */
Yap_TrailBase = TrailAddrAdjust(Yap_TrailBase);
Yap_TrailTop = TrailAddrAdjust(Yap_TrailTop);
@ -155,6 +156,8 @@ SetHeapRegs(void)
HB = PtoGloAdjust(HB);
if (B)
B = ChoicePtrAdjust(B);
if (CurrentDelayTop)
CurrentDelayTop = PtoGloAdjust(CurrentDelayTop);
#ifdef CUT_C
if (Yap_REGS.CUT_C_TOP)
Yap_REGS.CUT_C_TOP = (cut_c_str_ptr)ChoicePtrAdjust((choiceptr)Yap_REGS.CUT_C_TOP);
@ -291,7 +294,7 @@ AdjustPair(register CELL t0)
static void
AdjustTrail(int adjusting_heap)
{
register tr_fr_ptr ptt;
volatile tr_fr_ptr ptt;
ptt = TR;
/* moving the trail is simple */
@ -382,8 +385,10 @@ AdjustGlobTerm(Term reg)
return AtomTermAdjust(reg);
}
static volatile CELL *cpt=NULL;
static void
AdjustGlobal(void)
AdjustGlobal(long sz)
{
CELL *pt;
ArrayEntry *al = DynamicArrays;
@ -419,10 +424,11 @@ AdjustGlobal(void)
* to clean the global now that functors are just variables pointing to
* the code
*/
pt = CellPtr(Yap_GlobalBase);
while (pt < H) {
pt = CurrentDelayTop;
while (pt < (H-sz/CellSize)) {
CELL reg;
cpt = pt;
reg = *pt;
if (IsVarTerm(reg)) {
if (IsOldGlobal(reg))
@ -431,32 +437,33 @@ AdjustGlobal(void)
*pt = LocalAdjust(reg);
else if (IsOldCode(reg)) {
Functor f;
f = (Functor)(*pt = CodeAdjust(reg));
if (f <= FunctorDouble && f >= FunctorLongInt) {
/* skip bitmaps */
switch((CELL)f) {
case (CELL)FunctorDouble:
f = (Functor)reg;
/* skip bitmaps */
switch((CELL)f) {
case (CELL)FunctorDouble:
#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
pt += 3;
pt += 3;
#else
pt += 2;
pt += 2;
#endif
break;
break;
#if USE_GMP
case (CELL)FunctorBigInt:
{
Int sz = 1+
sizeof(MP_INT)+
(((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t));
pt += sz;
}
break;
#endif
case (CELL)FunctorLongInt:
default:
pt += 2;
break;
case (CELL)FunctorBigInt:
{
Int sz = 1+
(sizeof(MP_INT)+
(((MP_INT *)(pt+1))->_mp_alloc*sizeof(mp_limb_t)))/CellSize;
pt += sz;
}
break;
#endif
case (CELL)0L:
break;
case (CELL)FunctorLongInt:
pt += 2;
break;
default:
*pt = CodeAdjust(reg);
}
}
#ifdef MULTI_ASSIGNMENT_VARIABLES
@ -479,17 +486,17 @@ AdjustGlobal(void)
* (just once) the trail cells pointing both to the global and to the local
*/
static void
AdjustStacksAndTrail(void)
AdjustStacksAndTrail(long sz)
{
AdjustTrail(TRUE);
AdjustLocal();
AdjustGlobal();
AdjustGlobal(sz);
}
void
Yap_AdjustStacksAndTrail(void)
{
AdjustStacksAndTrail();
AdjustStacksAndTrail(0);
}
/*
@ -622,6 +629,7 @@ static_growheap(long size, int fix_code, struct intermediates *cip, tr_fr_ptr *o
int gc_verbose;
UInt minimal_request = 0L;
CurrentDelayTop = (CELL *)DelayTop();
/* adjust to a multiple of 256) */
size = AdjustPageSize(size);
Yap_ErrorMessage = NULL;
@ -641,7 +649,10 @@ static_growheap(long size, int fix_code, struct intermediates *cip, tr_fr_ptr *o
gc_verbose = Yap_is_gc_verbose();
heap_overflows++;
if (gc_verbose) {
fprintf(Yap_stderr, "%% Database overflow %d\n", heap_overflows);
#if defined(YAPOR) || defined(THREADS)
fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
#endif
fprintf(Yap_stderr, "%% Database Overflow %d\n", heap_overflows);
fprintf(Yap_stderr, "%% growing the heap %ld bytes\n", size);
}
/* CreepFlag is set to force heap expansion */
@ -672,10 +683,10 @@ static_growheap(long size, int fix_code, struct intermediates *cip, tr_fr_ptr *o
nTR = TR;
*old_trp = PtoTRAdjust(*old_trp);
TR = *old_trp;
AdjustStacksAndTrail();
AdjustStacksAndTrail(0);
TR = nTR;
} else {
AdjustStacksAndTrail();
AdjustStacksAndTrail(0);
}
AdjustRegs(MaxTemps);
YAPLeaveCriticalSection();
@ -705,6 +716,7 @@ static_growglobal(long size, CELL **ptr, CELL *hsplit)
char vb_msg1 = '\0', *vb_msg2;
int do_grow = TRUE;
CurrentDelayTop = (CELL *)omax;
if (hsplit) {
/* just a little bit of sanity checking */
if (hsplit < (CELL*)omax ||
@ -757,7 +769,10 @@ static_growglobal(long size, CELL **ptr, CELL *hsplit)
vb_msg1 = 'D';
vb_msg2 = "Delay";
}
fprintf(Yap_stderr, "%% %cO %s overflow %d\n", vb_msg1, vb_msg2, delay_overflows);
#if defined(YAPOR) || defined(THREADS)
fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
#endif
fprintf(Yap_stderr, "%% %cO %s Overflow %d\n", vb_msg1, vb_msg2, delay_overflows);
fprintf(Yap_stderr, "%% %cO growing the stacks %ld bytes\n", vb_msg1, size);
}
ASP -= 256;
@ -810,7 +825,12 @@ static_growglobal(long size, CELL **ptr, CELL *hsplit)
MoveExpandedGlobal();
}
}
AdjustStacksAndTrail();
/* don't run through garbage */
if (hsplit && (OldH != hsplit)) {
AdjustStacksAndTrail(sz);
} else {
AdjustStacksAndTrail(0);
}
AdjustRegs(MaxTemps);
if (ptr) {
*ptr = PtoLocAdjust(*ptr);
@ -1151,7 +1171,10 @@ growatomtable(void)
}
atom_table_overflows++;
if (gc_verbose) {
fprintf(Yap_stderr, "%% Atom Table overflow %d\n", atom_table_overflows);
#if defined(YAPOR) || defined(THREADS)
fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
#endif
fprintf(Yap_stderr, "%% Atom Table Overflow %d\n", atom_table_overflows);
fprintf(Yap_stderr, "%% growing the atom table to %ld entries\n", (long int)(nsize));
}
YAPEnterCriticalSection();
@ -1170,7 +1193,7 @@ growatomtable(void)
#if USE_SYSTEM_MALLOC
return TRUE;
#else
if (HeapTop + sizeof(YAP_SEG_SIZE) < HeapLim) {
if (HeapTop + sizeof(YAP_SEG_SIZE) > HeapLim - MinHeapGap) {
/* make sure there is no heap overflow */
int res;
YAPEnterCriticalSection();
@ -1274,6 +1297,7 @@ execute_growstack(long size0, int from_trail, int in_parser, tr_fr_ptr *old_trp,
long size = size0;
ADDR old_Yap_GlobalBase = Yap_GlobalBase;
CurrentDelayTop = (CELL *)DelayTop();
if (!Yap_ExtendWorkSpace(size)) {
/* make sure stacks and trail are contiguous */
@ -1331,10 +1355,10 @@ execute_growstack(long size0, int from_trail, int in_parser, tr_fr_ptr *old_trp,
nTR = TR;
*old_trp = PtoTRAdjust(*old_trp);
TR = *old_trp;
AdjustStacksAndTrail();
AdjustStacksAndTrail(0);
TR = nTR;
} else {
AdjustStacksAndTrail();
AdjustStacksAndTrail(0);
}
AdjustRegs(MaxTemps);
#ifdef TABLING
@ -1379,6 +1403,9 @@ growstack(long size)
gc_verbose = Yap_is_gc_verbose();
stack_overflows++;
if (gc_verbose) {
#if defined(YAPOR) || defined(THREADS)
fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
#endif
fprintf(Yap_stderr, "%% Stack Overflow %d\n", stack_overflows);
fprintf(Yap_stderr, "%% Global: %8ld cells (%p-%p)\n", (unsigned long int)(H-(CELL *)Yap_GlobalBase),Yap_GlobalBase,H);
fprintf(Yap_stderr, "%% Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);
@ -1413,6 +1440,9 @@ Yap_growstack_in_parser(tr_fr_ptr *old_trp, TokEntry **tksp, VarEntry **vep)
gc_verbose = Yap_is_gc_verbose();
stack_overflows++;
if (gc_verbose) {
#if defined(YAPOR) || defined(THREADS)
fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
#endif
fprintf(Yap_stderr, "%% Stack Overflow %d\n", stack_overflows);
fprintf(Yap_stderr, "%% Global: %8ld cells (%p-%p)\n", (unsigned long int)(H-(CELL *)Yap_GlobalBase),Yap_GlobalBase,H);
fprintf(Yap_stderr, "%% Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);
@ -1455,7 +1485,10 @@ static int do_growtrail(long size, int contiguous_only, int in_parser, tr_fr_ptr
size = AdjustPageSize(size);
trail_overflows++;
if (gc_verbose) {
fprintf(Yap_stderr, "%% Trail overflow %d\n", trail_overflows);
#if defined(YAPOR) || defined(THREADS)
fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
#endif
fprintf(Yap_stderr, "%% Trail Overflow %d\n", trail_overflows);
#if USE_SYSTEM_MALLOC
fprintf(Yap_stderr, "%% Heap: %8ld cells (%p-%p)\n", (unsigned long int)(H-(CELL *)Yap_GlobalBase),(CELL *)Yap_GlobalBase,H);
fprintf(Yap_stderr, "%% Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);

30
C/heapgc.c
View File

@ -937,7 +937,7 @@ init_dbtable(tr_fr_ptr trail_ptr) {
#ifdef SBA
(ADDR) pt0 >= HeapTop
#else
(ADDR) pt0 >= Yap_TrailBase
(ADDR) pt0 >= Yap_TrailBase && (ADDR) pt0 < Yap_TrailTop
#endif
) {
continue;
@ -1347,7 +1347,7 @@ mark_variable(CELL_PTR current)
case (CELL)FunctorBigInt:
{
UInt sz = (sizeof(MP_INT)+
(((MP_INT *)(next+1))->_mp_alloc*sizeof(mp_limb_t)))/CellSize;
((MP_INT *)(next+1))->_mp_alloc*sizeof(mp_limb_t))/CellSize;
MARK(next);
/* size is given by functor + friends */
if (next < HGEN)
@ -1819,6 +1819,7 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
yamop *lu_cl0 = NEXTOP(PredLogUpdClause0->CodeOfPred,ld),
*lu_cl = NEXTOP(PredLogUpdClause->CodeOfPred,ld),
*lu_cle = NEXTOP(PredLogUpdClauseErase->CodeOfPred,ld),
*su_cl = NEXTOP(PredStaticClause->CodeOfPred,ld);
#ifdef TABLING
dep_fr_ptr depfr = LOCAL_top_dep_fr;
@ -2133,9 +2134,16 @@ mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
if (gc_B->cp_ap == lu_cl0 ||
gc_B->cp_ap == lu_cl ||
gc_B->cp_ap == lu_cle ||
gc_B->cp_ap == su_cl) {
CELL *pt = (CELL *)IntegerOfTerm(gc_B->cp_args[1]);
mark_db_fixed(pt);
yamop *pt = (yamop *)IntegerOfTerm(gc_B->cp_args[1]);
if (gc_B->cp_ap == su_cl) {
mark_db_fixed((CELL *)pt);
} else {
while (pt->opc != trust_lu)
pt = pt->u.lld.n;
mark_ref_in_use((DBRef)pt->u.lld.t.block);
}
}
/* for each saved register */
for (saved_reg = &gc_B->cp_a1;
@ -3595,6 +3603,9 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop)
if (gc_trace) {
fprintf(Yap_stderr, "%% gc\n");
} else if (gc_verbose) {
#if defined(YAPOR) || defined(THREADS)
fprintf(Yap_stderr, "%% Worker Id %d:\n", worker_id);
#endif
fprintf(Yap_stderr, "%% Start of garbage collection %d:\n", GcCalls);
fprintf(Yap_stderr, "%% Global: %8ld cells (%p-%p)\n", (long int)heap_cells,H0,H);
fprintf(Yap_stderr, "%% Local:%8ld cells (%p-%p)\n", (unsigned long int)(LCL0-ASP),LCL0,ASP);
@ -3815,15 +3826,16 @@ call_gc(UInt gc_lim, Int predarity, CELL *current_env, yamop *nextop)
UInt gc_margin = MinStackGap;
Term Tgc_margin;
Int effectiveness = 0;
int gc_on = FALSE;
int gc_on = FALSE, gc_t = FALSE;
if (Yap_GetValue(AtomGc) != TermNil)
gc_on = TRUE;
if (IsIntegerTerm(Tgc_margin = Yap_GetValue(AtomGcMargin)) &&
gc_margin > 0) {
gc_margin = (UInt)IntegerOfTerm(Tgc_margin);
gc_t = TRUE;
} else {
/* only go exponential for the first 8 calls */
/* only go exponential for the first 6 calls, that would ask about 2MB minimum */
if (GcCalls < 8)
gc_margin <<= GcCalls;
else {
@ -3845,8 +3857,8 @@ call_gc(UInt gc_lim, Int predarity, CELL *current_env, yamop *nextop)
effectiveness = do_gc(predarity, current_env, nextop);
if (effectiveness < 0)
return FALSE;
if (effectiveness > 90) {
while (gc_margin < H-H0)
if (effectiveness > 90 && !gc_t) {
while (gc_margin < (H-H0)/sizeof(CELL))
gc_margin <<= 1;
}
} else {
@ -3856,7 +3868,7 @@ call_gc(UInt gc_lim, Int predarity, CELL *current_env, yamop *nextop)
if (ASP - H < gc_margin/sizeof(CELL) ||
effectiveness < 20) {
LeaveGCMode();
return Yap_growstack(gc_margin);
return Yap_growstack(gc_margin-((ASP-H)*sizeof(CELL)));
}
/*
* debug for(save_total=1; save_total<=N; ++save_total)

51
C/index.c
View File

@ -11,8 +11,11 @@
* File: index.c *
* comments: Indexing a Prolog predicate *
* *
* Last rev: $Date: 2007-11-26 23:43:08 $,$Author: vsc $ *
* Last rev: $Date: 2008-01-23 17:57:46 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.192 2007/11/26 23:43:08 vsc
* fixes to support threads and assert correctly, even if inefficiently.
*
* Revision 1.191 2007/11/08 15:52:15 vsc
* fix some bugs in new dbterm code.
*
@ -488,10 +491,10 @@ cleanup_sw_on_clauses(CELL larg, UInt sz, OPCODE ecls)
}
UNLOCK(ExpandClausesListLock);
#if DEBUG
Yap_ExpandClauses--;
Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sp))+xp->u.sp.s1*sizeof(yamop *);
#endif
if (xp->u.sp.p->PredFlags & LogUpdatePredFlag) {
// fprintf(stderr,"VSC %p %d - %d\n",xp,(UInt)NEXTOP((yamop *)NULL,sp)+xp->u.sp.s1*sizeof(yamop *),Yap_LUIndexSpace_EXT);
Yap_LUIndexSpace_EXT -= (UInt)NEXTOP((yamop *)NULL,sp)+xp->u.sp.s1*sizeof(yamop *);
} else
Yap_IndexSpace_EXT -= (UInt)(NEXTOP((yamop *)NULL,sp))+xp->u.sp.s1*sizeof(yamop *);
@ -2521,7 +2524,6 @@ add_info(ClauseDef *clause, UInt regno)
return;
#ifdef BEAM
case _run_eam:
// clause->Tag = (CELL)NULL;
cl = NEXTOP(cl,os);
break;
case _retry_eam:
@ -3563,7 +3565,7 @@ emit_type_switch(compiler_vm_op op, struct intermediates *cint)
static yamop *
emit_switch_space(UInt n, UInt item_size, struct intermediates *cint)
emit_switch_space(UInt n, UInt item_size, struct intermediates *cint, CELL func_mask)
{
PredEntry *ap = cint->CurrentPred;
@ -3576,7 +3578,7 @@ emit_switch_space(UInt n, UInt item_size, struct intermediates *cint)
longjmp(cint->CompilerBotch,2);
}
Yap_LUIndexSpace_SW += sz;
cl->ClFlags = SwitchTableMask|LogUpdMask;
cl->ClFlags = SwitchTableMask|LogUpdMask|func_mask;
cl->ClSize = sz;
cl->ClPred = cint->CurrentPred;
/* insert into code chain */
@ -3622,7 +3624,7 @@ emit_cswitch(int n, yamop *fail_l, struct intermediates *cint)
while (cases < n) cases *= 2;
n = cases;
op = switch_c_op;
target = (AtomSwiEntry *)emit_switch_space(n, sizeof(AtomSwiEntry), cint);
target = (AtomSwiEntry *)emit_switch_space(n, sizeof(AtomSwiEntry), cint, 0);
for (i=0; i<n; i++) {
target[i].Tag = Zero;
target[i].u.labp = fail_l;
@ -3632,7 +3634,7 @@ emit_cswitch(int n, yamop *fail_l, struct intermediates *cint)
UInt i;
op = if_c_op;
target = (AtomSwiEntry *)emit_switch_space(n+1, sizeof(AtomSwiEntry), cint);
target = (AtomSwiEntry *)emit_switch_space(n+1, sizeof(AtomSwiEntry), cint, 0);
for (i=0; i<n; i++) {
target[i].u.labp = fail_l;
@ -3689,7 +3691,7 @@ emit_fswitch(int n, yamop *fail_l, struct intermediates *cint)
while (cases < n) cases *= 2;
n = cases;
op = switch_f_op;
target = (FuncSwiEntry *)emit_switch_space(n, sizeof(FuncSwiEntry), cint);
target = (FuncSwiEntry *)emit_switch_space(n, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
for (i=0; i<n; i++) {
target[i].Tag = NULL;
target[i].u.labp = fail_l;
@ -3699,7 +3701,7 @@ emit_fswitch(int n, yamop *fail_l, struct intermediates *cint)
UInt i;
op = if_f_op;
target = (FuncSwiEntry *)emit_switch_space(n+1, sizeof(FuncSwiEntry), cint);
target = (FuncSwiEntry *)emit_switch_space(n+1, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
for (i=0; i<n; i++) {
target[i].u.labp = fail_l;
}
@ -3913,15 +3915,15 @@ suspend_indexing(ClauseDef *min, ClauseDef *max, PredEntry *ap, struct intermedi
tels = cls;
}
sz = (UInt)NEXTOP((yamop *)NULL,sp)+tels*sizeof(yamop *), sz;
#if DEBUG
Yap_expand_clauses_sz += sz;
#endif
if ((ncode = (yamop *)Yap_AllocCodeSpace(sz)) == NULL) {
save_machine_regs();
longjmp(cint->CompilerBotch, 2);
}
#if DEBUG
Yap_ExpandClauses++;
Yap_expand_clauses_sz += sz;
#endif
if (ap->PredFlags & LogUpdatePredFlag) {
// fprintf(stderr,"VSC %p %d + %d\n",ncode,sz,Yap_LUIndexSpace_EXT);
Yap_LUIndexSpace_EXT += sz;
} else {
Yap_IndexSpace_EXT += sz;
@ -3980,6 +3982,7 @@ recover_ecls_block(yamop *ipc)
}
UNLOCK(ExpandClausesListLock);
#if DEBUG
Yap_ExpandClauses--;
Yap_expand_clauses_sz -= (UInt)(NEXTOP((yamop *)NULL,sp))+ipc->u.sp.s1*sizeof(yamop *);
#endif
/* no dangling pointers for gprof */
@ -6158,7 +6161,8 @@ replace_index_block(ClauseUnion *parent_block, yamop *cod, yamop *ncod, PredEntr
if (c == cl) {
parent_block->lui.ChildIndex = ncl;
} else {
cl->PrevSiblingIndex->SiblingIndex = ncl;
if (cl->PrevSiblingIndex)
cl->PrevSiblingIndex->SiblingIndex = ncl;
}
if (cl->SiblingIndex) {
cl->SiblingIndex->PrevSiblingIndex = ncl;
@ -6221,7 +6225,7 @@ expand_ctable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Term at)
return fetch_centry(old_ae, at, n-1, n);
}
/* initialise */
target = (AtomSwiEntry *)emit_switch_space(cases, sizeof(AtomSwiEntry), cint);
target = (AtomSwiEntry *)emit_switch_space(cases, sizeof(AtomSwiEntry), cint, 0);
pc->opc = Yap_opcode(_switch_on_cons);
pc->u.sssl.s = cases;
for (i=0; i<cases; i++) {
@ -6231,7 +6235,7 @@ expand_ctable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Term at)
} else {
pc->opc = Yap_opcode(_if_cons);
pc->u.sssl.s = n;
target = (AtomSwiEntry *)emit_switch_space(n+1, sizeof(AtomSwiEntry), cint);
target = (AtomSwiEntry *)emit_switch_space(n+1, sizeof(AtomSwiEntry), cint, 0);
target[n].Tag = Zero;
target[n].u.Label = fail_l;
}
@ -6285,7 +6289,7 @@ expand_ftable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Functor f
pc->u.sssl.e = n;
pc->u.sssl.w = 0;
/* initialise */
target = (FuncSwiEntry *)emit_switch_space(cases, sizeof(FuncSwiEntry), cint);
target = (FuncSwiEntry *)emit_switch_space(cases, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
for (i=0; i<cases; i++) {
target[i].Tag = NULL;
target[i].u.Label = fail_l;
@ -6295,7 +6299,7 @@ expand_ftable(yamop *pc, ClauseUnion *blk, struct intermediates *cint, Functor f
pc->u.sssl.s = n;
pc->u.sssl.e = n;
pc->u.sssl.w = 0;
target = (FuncSwiEntry *)emit_switch_space(n+1, sizeof(FuncSwiEntry), cint);
target = (FuncSwiEntry *)emit_switch_space(n+1, sizeof(FuncSwiEntry), cint, FuncSwitchMask);
target[n].Tag = Zero;
target[n].u.Label = fail_l;
}
@ -7354,7 +7358,6 @@ remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg
yamop *ipc = ap->cs.p_code.TrueCodeOfPred;
UInt current_arity = 0;
sp = init_block_stack(sp, ipc, ap);
if (ap->cs.p_code.NOfClauses == 1) {
if (ap->PredFlags & IndexedPredFlag) {
Yap_RemoveIndexation(ap);
@ -7377,6 +7380,7 @@ remove_from_index(PredEntry *ap, path_stack_entry *sp, ClauseDef *cls, yamop *bg
}
return;
}
sp = init_block_stack(sp, ipc, ap);
/* try to refine the interval using the indexing code */
while (ipc != NULL) {
op_numbers op = Yap_op_from_opcode(ipc->opc);
@ -7819,15 +7823,14 @@ Yap_RemoveClauseFromIndex(PredEntry *ap, yamop *beg) {
if (ap->PredFlags & LogUpdatePredFlag &&
ap->ModuleOfPred != IDB_MODULE) {
ap->cs.p_code.TrueCodeOfPred = FAILCODE;
ap->OpcodeOfPred = LOCKPRED_OPCODE;
ap->CodeOfPred = (yamop *)(&(ap->OpcodeOfPred));
} else {
#endif
ap->CodeOfPred = ap->cs.p_code.TrueCodeOfPred = FAILCODE;
ap->OpcodeOfPred = Yap_opcode(_op_fail);
#if defined(YAPOR) || defined(THREADS)
}
#endif
ap->OpcodeOfPred = Yap_opcode(_op_fail);
} else {
remove_from_index(ap, sp, &cl, beg, last, &cint);
}
@ -8078,7 +8081,7 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
update_clause_choice_point(ipc->u.lld.n, ap_pc);
}
{
UInt timestamp = ((CELL *)(B+1))[5];
UInt timestamp = IntegerOfTerm(((CELL *)(B+1))[5]);
if (!VALID_TIMESTAMP(timestamp, ipc->u.lld.d)) {
/* jump to next instruction */
@ -8091,7 +8094,7 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
case _profiled_retry_logical:
case _count_retry_logical:
{
UInt timestamp = ((CELL *)(B+1))[5];
UInt timestamp = IntegerOfTerm(((CELL *)(B+1))[5]);
if (!VALID_TIMESTAMP(timestamp, ipc->u.lld.d)) {
/* jump to next instruction */
ipc = ipc->u.lld.n;
@ -8139,7 +8142,7 @@ Yap_FollowIndexingCode(PredEntry *ap, yamop *ipc, Term Terms[3], yamop *ap_pc, y
/* next, recover space for the indexing code if it was erased */
if (cl->ClFlags & (ErasedMask|DirtyMask)) {
LogUpdClause *lcl = ipc->u.lld.d;
/* make sure we don't erase the clause we are jumping too */
/* make sure we don't erase the clause we are jumping to */
if (lcl->ClRefCount == 1 && !(lcl->ClFlags & (DirtyMask|InUseMask))) {
lcl->ClFlags |= InUseMask;
TRAIL_CLREF(lcl);

16
C/init.c
View File

@ -915,6 +915,7 @@ InitCodes(void)
Yap_heap_regs->expand_op_code = Yap_opcode(_expand_index);
Yap_heap_regs->expand_clauses_first = NULL;
Yap_heap_regs->expand_clauses_last = NULL;
Yap_heap_regs->expand_clauses = 0;
Yap_heap_regs->failcode->opc = Yap_opcode(_op_fail);
Yap_heap_regs->failcode_1 = Yap_opcode(_op_fail);
Yap_heap_regs->failcode_2 = Yap_opcode(_op_fail);
@ -986,8 +987,14 @@ InitCodes(void)
Yap_heap_regs->wl[i].static_arrays = NULL;
Yap_heap_regs->wl[i].global_variables = NULL;
Yap_heap_regs->wl[i].global_arena = 0L;
Yap_heap_regs->wl[i].global_arena_overflows = 0;
Yap_heap_regs->wl[i].global_delay_arena = 0L;
Yap_heap_regs->wl[i].allow_restart = FALSE;
Yap_heap_regs->wl[i].tot_gc_time = 0;
Yap_heap_regs->wl[i].tot_gc_recovered = 0;
Yap_heap_regs->wl[i].gc_calls = 0;
Yap_heap_regs->wl[i].last_gc_time = 0;
Yap_heap_regs->wl[i].last_ss_time = 0;
Yap_heap_regs->wl[i].consultlow = (consult_obj *)Yap_AllocCodeSpace(sizeof(consult_obj)*InitialConsultCapacity);
if (Yap_heap_regs->wl[i].consultlow == NULL) {
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"No Heap Space in InitCodes");
@ -1003,8 +1010,14 @@ InitCodes(void)
Yap_heap_regs->wl.static_arrays = NULL;
Yap_heap_regs->wl.global_variables = NULL;
Yap_heap_regs->wl.global_arena = 0L;
Yap_heap_regs->wl.global_arena_overflows = 0;
Yap_heap_regs->wl.allow_restart = FALSE;
Yap_heap_regs->wl.global_delay_arena = 0L;
Yap_heap_regs->wl.tot_gc_time = 0;
Yap_heap_regs->wl.tot_gc_recovered = 0;
Yap_heap_regs->wl.gc_calls = 0;
Yap_heap_regs->wl.last_gc_time = 0;
Yap_heap_regs->wl.last_ss_time = 0;
Yap_heap_regs->wl.consultlow = (consult_obj *)Yap_AllocCodeSpace(sizeof(consult_obj)*InitialConsultCapacity);
if (Yap_heap_regs->wl.consultlow == NULL) {
Yap_Error(OUT_OF_HEAP_ERROR,TermNil,"No Heap Space in InitCodes");
@ -1251,6 +1264,7 @@ InitCodes(void)
Yap_heap_regs->pred_dollar_catch = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$catch"),3),PROLOG_MODULE));
Yap_heap_regs->pred_recorded_with_key = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$recorded_with_key"),3),PROLOG_MODULE));
Yap_heap_regs->pred_log_upd_clause = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$do_log_upd_clause"),6),PROLOG_MODULE));
Yap_heap_regs->pred_log_upd_clause_erase = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$do_log_upd_clause_erase"),6),PROLOG_MODULE));
Yap_heap_regs->pred_log_upd_clause0 = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$do_log_upd_clause0"),6),PROLOG_MODULE));
Yap_heap_regs->pred_static_clause = RepPredProp(PredPropByFunc(Yap_MkFunctor(Yap_FullLookupAtom("$do_static_clause"),5),PROLOG_MODULE));
Yap_heap_regs->pred_throw = RepPredProp(PredPropByFunc(FunctorThrow,PROLOG_MODULE));
@ -1271,6 +1285,7 @@ InitCodes(void)
Yap_heap_regs->db_erased_marker =
(DBRef)Yap_AllocCodeSpace(sizeof(DBStruct));
Yap_LUClauseSpace += sizeof(DBStruct);
Yap_heap_regs->dbterms_list = NULL;
Yap_heap_regs->db_erased_marker->id = FunctorDBRef;
Yap_heap_regs->db_erased_marker->Flags = ErasedMask;
Yap_heap_regs->db_erased_marker->Code = NULL;
@ -1420,7 +1435,6 @@ Yap_InitWorkspace(int Heap, int Stack, int Trail, int max_table_size,
for (i = 0; i <= LAST_FLAG; i++) {
yap_flags[i] = 0;
}
GcCalls = 0;
#ifdef LOW_PROF
ProfilerOn = FALSE;
FPreds = NULL;

1
C/inlines.c
View File

@ -406,6 +406,7 @@ p_dif(void)
*/
HBREG = H;
B = (choiceptr) H;
B->cp_h = H;
SET_BB(B);
save_hb();
d0 = Yap_IUnify(d0, d1);

3
C/iopreds.c
View File

@ -3087,6 +3087,8 @@ static Int
init_cur_s (void)
{ /* Init current_stream */
Term t3 = Deref(ARG3);
/* make valgrind happy by always filling in memory */
EXTRA_CBACK_ARG (3, 1) = MkIntTerm (0);
if (!IsVarTerm(t3)) {
Int i;
@ -3107,7 +3109,6 @@ init_cur_s (void)
cut_fail();
}
} else {
EXTRA_CBACK_ARG (3, 1) = MkIntTerm (0);
return (cont_cur_s ());
}
}

15
C/load_foreign.c
View File

@ -39,8 +39,8 @@ STD_PROTO(Int p_load_foreign, (void));
Int
p_load_foreign(void)
{
StringList ofiles = NIL;
StringList libs = NIL;
StringList ofiles = NULL;
StringList libs = NULL;
char *InitProcName;
YapInitProc InitProc = NULL;
Term t, t1;
@ -94,6 +94,17 @@ p_load_foreign(void)
f_code->next = ForeignCodeLoaded;
f_code->module = CurrentModule;
ForeignCodeLoaded = (void *)f_code;
} else {
while (ofiles) {
new = ofiles->next;
Yap_FreeCodeSpace((ADDR)ofiles);
ofiles = new;
}
while (libs) {
new = libs->next;
Yap_FreeCodeSpace((ADDR)libs);
libs = new;
}
}
return returncode;
}

2
C/save.c
View File

@ -1672,7 +1672,7 @@ UnmarkTrEntries(void)
if (FlagOn(ErasedMask, flags))
Yap_ErLogUpdIndex(ClauseFlagsToLogUpdIndex(ent));
else
Yap_CleanUpIndex(ClauseFlagsToLogUpdIndex(ent));
Yap_CleanUpIndex(ClauseFlagsToLogUpdIndex(ent));
} else {
Yap_ErLogUpdCl(ClauseFlagsToLogUpdClause(ent));
}

26
C/stdpreds.c
View File

@ -11,8 +11,11 @@
* File: stdpreds.c *
* comments: General-purpose C implemented system predicates *
* *
* Last rev: $Date: 2007-11-26 23:43:08 $,$Author: vsc $ *
* Last rev: $Date: 2008-01-23 17:57:53 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.124 2007/11/26 23:43:08 vsc
* fixes to support threads and assert correctly, even if inefficiently.
*
* Revision 1.123 2007/11/06 17:02:12 vsc
* compile ground terms away.
*
@ -727,9 +730,6 @@ runtime(void)
return(Yap_cputime()-Yap_total_gc_time()-Yap_total_stack_shift_time());
}
Int last_gc_time = 0;
Int last_ss_time = 0;
/* $runtime(-SinceInterval,-SinceStart) */
static Int
p_runtime(void)
@ -737,16 +737,20 @@ p_runtime(void)
Int now, interval,
gc_time,
ss_time;
Term tnow, tinterval;
Yap_cputime_interval(&now, &interval);
gc_time = Yap_total_gc_time();
now -= gc_time;
ss_time = Yap_total_stack_shift_time();
now -= gc_time+ss_time;
interval -= (gc_time-last_gc_time)+(ss_time-last_ss_time);
last_gc_time = gc_time;
last_ss_time = ss_time;
return( Yap_unify_constant(ARG1, MkIntegerTerm(now)) &&
Yap_unify_constant(ARG2, MkIntegerTerm(interval)) );
now -= ss_time;
interval -= (gc_time-LastGcTime)+(ss_time-LastSSTime);
LastGcTime = gc_time;
LastSSTime = ss_time;
tnow = MkIntegerTerm(now);
tinterval = MkIntegerTerm(interval);
return( Yap_unify_constant(ARG1, tnow) &&
Yap_unify_constant(ARG2, tinterval) );
}
/* $cputime(-SinceInterval,-SinceStart) */
@ -3229,7 +3233,7 @@ p_statistics_heap_info(void)
Term tmax = MkIntegerTerm((mi.arena+mi.hblkhd)-Yap_HoleSize);
#else
Term tmax = MkIntegerTerm((Unsigned(H0) - Unsigned(Yap_HeapBase))-Yap_HoleSize);
Term tmax = MkIntegerTerm((Yap_GlobalBase - Yap_HeapBase)-Yap_HoleSize);
#endif
return(Yap_unify(tmax, ARG1) && Yap_unify(tusage,ARG2));

6
C/tracer.c
View File

@ -161,6 +161,8 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
LOCK(Yap_heap_regs->low_level_trace_lock);
sc = Yap_heap_regs;
vsc_count++;
//*(H0+(0xb65f2850-0xb64b2008)/sizeof(CELL))==0xc ||
//0x4fd4d
#ifdef COMMENTED
if (vsc_count == 40650191LL)
jmp_deb(1);
@ -273,8 +275,8 @@ low_level_trace(yap_low_level_port port, PredEntry *pred, CELL *args)
arity = pred->ArityOfPE;
if (arity == 0)
s = RepAtom((Atom)pred->FunctorOfPred)->StrOfAE;
else
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
else
s = RepAtom(NameOfFunctor((pred->FunctorOfPred)))->StrOfAE;
/* if ((pred->ModuleOfPred == 0) && (s[0] == '$'))
return; */
send_tracer_message("CALL: ", s, arity, mname, args);

12
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.122 2007-12-05 12:17:23 vsc Exp $ *
* version: $Id: Heap.h,v 1.123 2008-01-23 17:57:53 vsc Exp $ *
*************************************************************************/
/* information that can be stored in Code Space */
@ -88,6 +88,7 @@ typedef struct restore_info {
CELL *g_split;
tr_fr_ptr old_TR;
CELL *old_GlobalBase, *old_H, *old_H0;
CELL *old_DelayTop, *current_DelayTop;
ADDR old_TrailBase, old_TrailTop;
ADDR old_HeapBase, old_HeapTop;
} restoreinfo;
@ -131,6 +132,7 @@ typedef struct worker_local_struct {
unsigned int gc_calls; /* number of times GC has been called */
Int tot_gc_time; /* total time spent in GC */
YAP_ULONG_LONG tot_gc_recovered; /* number of heap objects in all garbage collections */
Int last_gc_time, last_ss_time; /* number of heap objects in all garbage collections */
/* in a single gc */
#if defined(YAPOR) || defined(THREADS)
/* otherwise, use global variables for speed */
@ -238,6 +240,7 @@ typedef struct various_codes {
#endif /* TABLING */
OPCODE expand_op_code;
yamop *expand_clauses_first, *expand_clauses_last;
UInt expand_clauses;
#if defined(YAPOR) || defined(THREADS)
lockvar expand_clauses_list_lock;
lockvar op_list_lock;
@ -504,6 +507,7 @@ typedef struct various_codes {
struct pred_entry *pred_dollar_catch;
struct pred_entry *pred_recorded_with_key;
struct pred_entry *pred_log_upd_clause;
struct pred_entry *pred_log_upd_clause_erase;
struct pred_entry *pred_log_upd_clause0;
struct pred_entry *pred_static_clause;
struct pred_entry *pred_throw;
@ -611,6 +615,7 @@ struct various_codes *Yap_heap_regs;
#define ExpandClausesFirst Yap_heap_regs->expand_clauses_first
#define ExpandClausesLast Yap_heap_regs->expand_clauses_last
#define ExpandClausesListLock Yap_heap_regs->expand_clauses_list_lock
#define Yap_ExpandClauses Yap_heap_regs->expand_clauses
#define OpListLock Yap_heap_regs->op_list_lock
#define COMMA_CODE Yap_heap_regs->comma_code
#define FAILCODE Yap_heap_regs->failcode
@ -809,6 +814,7 @@ struct various_codes *Yap_heap_regs;
#define PredDollarCatch Yap_heap_regs->pred_dollar_catch
#define PredRecordedWithKey Yap_heap_regs->pred_recorded_with_key
#define PredLogUpdClause Yap_heap_regs->pred_log_upd_clause
#define PredLogUpdClauseErase Yap_heap_regs->pred_log_upd_clause_erase
#define PredLogUpdClause0 Yap_heap_regs->pred_log_upd_clause0
#define PredStaticClause Yap_heap_regs->pred_static_clause
#define PredThrow Yap_heap_regs->pred_throw
@ -886,6 +892,8 @@ struct various_codes *Yap_heap_regs;
#define OldTrailTop RINFO.old_TrailTop
#define OldHeapBase RINFO.old_HeapBase
#define OldHeapTop RINFO.old_HeapTop
#define OldDelayTop RINFO.old_DelayTop
#define CurrentDelayTop RINFO.current_DelayTop
#define ClDiff RINFO.cl_diff
#define GDiff RINFO.g_diff
#define GDiff0 RINFO.g_diff0
@ -924,6 +932,8 @@ struct various_codes *Yap_heap_regs;
#define GcCalls Yap_heap_regs->WL.gc_calls
#define TotGcTime Yap_heap_regs->WL.tot_gc_time
#define TotGcRecovered Yap_heap_regs->WL.tot_gc_recovered
#define LastGcTime Yap_heap_regs->WL.last_gc_time
#define LastSSTime Yap_heap_regs->WL.last_ss_time
#define Yap_gc_restore Yap_heap_regs->WL.gc_restore
#define TrustLUCode Yap_heap_regs->WL.trust_lu_code
#define DynamicArrays Yap_heap_regs->WL.dynamic_arrays

1
H/Yatom.h
View File

@ -798,6 +798,7 @@ IsPredProperty (int flags)
/* There are several flags for code and data base entries */
typedef enum
{
FuncSwitchMask = 0x800000, /* is a switch of functors */
HasDBTMask = 0x400000, /* includes a pointer to a DBTerm */
MegaMask = 0x200000, /* mega clause */
FactMask = 0x100000, /* a fact */

12
H/alloc.h
View File

@ -80,15 +80,17 @@ typedef struct FREEB {
/* I'll assume page size is always a power of two */
#if _WIN32
/* in WIN32 VirtualAlloc works in multiples of 64K */
#define ALLOC_SIZE (64*1024)
#define YAP_ALLOC_SIZE (64*1024)
#define LG_PAGE_SIZE ALLOC_SIZE
#define AdjustPageSize(X) (((X)+ (ALLOC_SIZE-1))/ALLOC_SIZE)*ALLOC_SIZE;
#else
#define AdjustPageSize(X) ((X) & (Yap_page_size-1) ? \
((X) + Yap_page_size) & (~(Yap_page_size-1)) : \
(X) )
#define YAP_ALLOC_SIZE Yap_page_size
#define LGPAGE_SIZE (16*Yap_page_size)
#endif
#define AdjustPageSize(X) (((X)+ (YAP_ALLOC_SIZE-1))/YAP_ALLOC_SIZE)*YAP_ALLOC_SIZE;
#define AdjustLargePageSize(X) (((X)+ (LGPAGE_SIZE-1))/LGPAGE_SIZE)*LGPAGE_SIZE;
#define BlockTrailer(b) ((YAP_SEG_SIZE *)b)[((BlockHeader *) b)->b_size]
/* Operating system and architecture dependent page size */

1
H/clause.h
View File

@ -221,6 +221,7 @@ Term STD_PROTO(Yap_cp_as_integer,(choiceptr));
yamop *STD_PROTO(Yap_PredIsIndexable,(PredEntry *, UInt));
yamop *STD_PROTO(Yap_ExpandIndex,(PredEntry *, UInt));
void STD_PROTO(Yap_CleanUpIndex,(struct logic_upd_index *));
void STD_PROTO(Yap_CleanKids,(struct logic_upd_index *));
void STD_PROTO(Yap_AddClauseToIndex,(PredEntry *,yamop *,int));
void STD_PROTO(Yap_RemoveClauseFromIndex,(PredEntry *,yamop *));
LogUpdClause *STD_PROTO(Yap_NthClause,(PredEntry *,Int));

7
H/rclause.h
View File

@ -12,8 +12,11 @@
* File: rclause.h *
* comments: walk through a clause *
* *
* Last rev: $Date: 2007-11-26 23:43:09 $,$Author: vsc $ *
* Last rev: $Date: 2008-01-23 17:57:55 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.21 2007/11/26 23:43:09 vsc
* fixes to support threads and assert correctly, even if inefficiently.
*
* Revision 1.20 2007/11/07 09:25:27 vsc
* speedup meta-calls
*
@ -360,7 +363,7 @@ restore_opcodes(yamop *pc)
break;
case _expand_clauses:
Yap_Error(SYSTEM_ERROR, TermNil,
"Invalid Opcode expand_clauses at %p", pc);
"Invalid Opcode expand_clauses at %p", pc);
break;
/* instructions type y */
case _save_b_y:

50
H/rheap.h
View File

@ -11,8 +11,13 @@
* File: rheap.h *
* comments: walk through heap code *
* *
* Last rev: $Date: 2007-12-05 12:17:23 $,$Author: vsc $ *
* Last rev: $Date: 2008-01-23 17:57:55 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.82 2007/12/05 12:17:23 vsc
* improve JT
* fix graph compatibility with SICStus
* re-export declaration.
*
* Revision 1.81 2007/11/26 23:43:09 vsc
* fixes to support threads and assert correctly, even if inefficiently.
*
@ -360,14 +365,45 @@ RestoreDBTermEntry(struct dbterm_list *dbl) {
}
}
static void
restore_switch(CELL *start, CELL *end, int is_func)
{
CELL *pt = start;
if (is_func) {
while (pt < end) {
yamop **x = (yamop **)(pt+1);
Functor *fp = (Functor *)pt;
*fp = FuncAdjust(*fp);
*x = PtoOpAdjust(*x);
pt += 2;
}
} else {
while (pt < end) {
Term *tp = (Term *)pt;
Term t = *tp;
yamop **x = (yamop **)(pt+1);
if (IsAtomTerm(t))
*tp = AtomTermAdjust(t);
else if (IsApplTerm(t) && *(Functor *)DBRefAdjust(DBRefOfTerm(t)) == FunctorDBRef)
*tp = AbsAppl((CELL *)DBRefAdjust(DBRefOfTerm(t)));
*x = PtoOpAdjust(*x);
pt += 2;
}
}
}
static void
CleanLUIndex(LogUpdIndex *idx)
{
idx->ClRefCount = 0;
INIT_LOCK(idx->ClLock);
idx->ClPred = PtoPredAdjust(idx->ClPred);
if (idx->ParentIndex)
idx->ParentIndex = LUIndexAdjust(idx->ParentIndex);
if (idx->PrevSiblingIndex) {
idx->PrevSiblingIndex = LUIndexAdjust(idx->PrevSiblingIndex);
}
if (idx->SiblingIndex) {
idx->SiblingIndex = LUIndexAdjust(idx->SiblingIndex);
CleanLUIndex(idx->SiblingIndex);
@ -376,7 +412,9 @@ CleanLUIndex(LogUpdIndex *idx)
idx->ChildIndex = LUIndexAdjust(idx->ChildIndex);
CleanLUIndex(idx->ChildIndex);
}
if (!(idx->ClFlags & SwitchTableMask)) {
if (idx->ClFlags & SwitchTableMask) {
restore_switch((CELL *)idx->ClCode, (CELL *)((char *)idx+idx->ClSize), ((idx->ClFlags & FuncSwitchMask) == FuncSwitchMask));
} else {
restore_opcodes(idx->ClCode);
}
}
@ -393,7 +431,9 @@ CleanSIndex(StaticIndex *idx)
idx->ChildIndex = SIndexAdjust(idx->ChildIndex);
CleanSIndex(idx->ChildIndex);
}
if (!(idx->ClFlags & SwitchTableMask)) {
if (idx->ClFlags & SwitchTableMask) {
restore_switch((CELL *)idx->ClCode, (CELL *)((char *)idx+idx->ClSize), ((idx->ClFlags & FuncSwitchMask) == FuncSwitchMask));
} else {
restore_opcodes(idx->ClCode);
}
}
@ -760,6 +800,8 @@ restore_codes(void)
PredEntryAdjust(Yap_heap_regs->pred_recorded_with_key);
Yap_heap_regs->pred_log_upd_clause =
PredEntryAdjust(Yap_heap_regs->pred_log_upd_clause);
Yap_heap_regs->pred_log_upd_clause_erase =
PredEntryAdjust(Yap_heap_regs->pred_log_upd_clause_erase);
Yap_heap_regs->pred_log_upd_clause0 =
PredEntryAdjust(Yap_heap_regs->pred_log_upd_clause0);
Yap_heap_regs->pred_static_clause =

8
H/sshift.h
View File

@ -31,7 +31,11 @@ inline EXTERN int IsHeapP (CELL *);
inline EXTERN int
IsHeapP (CELL * ptr)
{
#if USE_SYSTEM_MALLOC
return (int) ((ptr < (CELL *) Yap_GlobalBase || ptr > (CELL *) Yap_TrailTop));
#else
return (int) ((ptr >= (CELL *) Yap_HeapBase && ptr <= (CELL *) HeapTop));
#endif
}
@ -740,7 +744,11 @@ inline EXTERN int IsOldCode (CELL);
inline EXTERN int
IsOldCode (CELL reg)
{
#if USE_SYSTEM_MALLOC
return reg < (CELL)OldGlobalBase || reg > (CELL)OldTrailTop;
#else
return (int) (IN_BETWEEN (OldHeapBase, reg, OldHeapTop));
#endif
}

8
changes-5.1.html
View File

@ -17,6 +17,14 @@
<h2>Yap-5.1.3:</h2>
<ul>
<li> NEW: start atom garbage collector by default (except for threads).</li>
<li> FIXED: restore indices should run over the indices, and not mess
them up.</li>
<li> FIXED: make sure to always remove try-trust chains.</li>
<li> FIXED: don't adjust garbage when doing stack shift.</li>
<li> FIXED: stack shifter would get ignore big terms.</li>
<li> FIXED: retract and friends should remove mf pointers.</li>
<li> FIXED: small memory leaks and use of uninitialised memory (valgrind).</li>
<li> NEW: char_type/2 and code_type/2 (request from Brian DeVries).</li>
<li> FIXED: memory leak where I'd try to clear refs from an index
block before I released the kids (so the refs would never be released).</li>

1
pl/consult.yap
View File

@ -297,6 +297,7 @@ use_module(M,F,Is) :-
'$show_consult_level'(Level1),
% it will be done after we leave the current consult level.
Level is Level1-1,
format(user_error,'add~w~n',[G]),
recorda('$initialisation',do(Level,G),_),
fail.
'$initialization'(_).

8
pl/errors.yap
View File

@ -11,8 +11,11 @@
* File: errors.yap *
* comments: error messages for YAP *
* *
* Last rev: $Date: 2007-11-26 23:43:10 $,$Author: vsc $ *
* Last rev: $Date: 2008-01-23 17:57:55 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.83 2007/11/26 23:43:10 vsc
* fixes to support threads and assert correctly, even if inefficiently.
*
* Revision 1.82 2007/09/27 23:02:00 vsc
* encoding/1
*
@ -666,6 +669,9 @@ print_message(Level, Mss) :-
'$output_error_message'(existence_error(stream,Stream), Where) :-
format(user_error,'% EXISTENCE ERROR- ~w: ~w not an open stream~n',
[Where,Stream]).
'$output_error_message'(existence_error(thread,Thread), Where) :-
format(user_error,'% EXISTENCE ERROR- ~w: ~w not a running thread~n',
[Where,Thread]).
'$output_error_message'(evaluation_error(int_overflow), Where) :-
format(user_error,'% INTEGER OVERFLOW ERROR- ~w~n',
[Where]).

57
pl/preds.yap
View File

@ -339,6 +339,13 @@ clause(V,Q,R) :-
:- '$do_log_upd_clause'(_,_,_,_,_,_), !.
'$do_log_upd_clause_erase'(_,_,_,_,_,_).
'$do_log_upd_clause_erase'(A,B,C,D,E,_) :-
'$continue_log_update_clause_erase'(A,B,C,D,E).
'$do_log_upd_clause_erase'(_,_,_,_,_,_).
:- '$do_log_upd_clause_erase'(_,_,_,_,_,_), !.
'$do_log_upd_clause0'(_,_,_,_,_,_).
'$do_log_upd_clause0'(A,B,C,D,_,_) :-
'$continue_log_update_clause'(A,B,C,D).
@ -405,21 +412,27 @@ retract(C) :-
'$retract'(C,M).
'$retract'(C,M) :-
'$check_head_and_body'(C,H,B,retract(M:C)), !,
'$retract2'(H,M,B).
'$flags'(H, M, F, F),
'$retract2'(F, H,M,B,_).
'$retract2'(H,M,B) :-
'$is_log_updatable'(H, M), !,
'$retract2'(F, H, M, B, R) :-
F /\ 0x08000000 =:= 0x08000000, !,
% '$is_log_updatable'(H, M), !,
'$log_update_clause'(H,M,B,R),
( F /\ 0x20000000 =:= 0x20000000, recorded('$mf','$mf_clause'(_,_,_,_,R),MR), erase(MR), fail ; true),
erase(R).
'$retract2'(H,M,B) :-
'$is_dynamic'(H,M), !,
'$recordedp'(M:H,(H:-B),R), erase(R).
'$retract2'(H,M,_) :-
'$retract2'(F, H, M, B, R) :-
% '$is_dynamic'(H,M), !,
F /\ 0x00002000 =:= 0x00002000, !,
'$recordedp'(M:H,(H:-B),R),
( F /\ 0x20000000 =:= 0x20000000, recorded('$mf','$mf_clause'(_,_,_,_,MRef),MR), erase(MR), fail ; true),
erase(R).
'$retract2'(_, H,M,_,_) :-
'$undefined'(H,M), !,
functor(H,Na,Ar),
'$dynamic'(Na/Ar,M),
fail.
'$retract2'(H,M,B) :-
'$retract2'(_, H,M,B,_) :-
functor(H,Na,Ar),
'$do_error'(permission_error(modify,static_procedure,Na/Ar),retract(M:(H:-B))).
@ -439,16 +452,8 @@ retract(C,R) :-
instance(R,(H:-B)), erase(R).
'$retract'(C,M,R) :-
'$check_head_and_body'(C,H,B,retract(C,R)),
'$is_dynamic'(H,M), !,
var(R),
'$recordedp'(M:H,(H:-B),R),
erase(R).
'$retract'(C,M,R) :-
'$check_head_and_body'(C,H,_,retract(M:C,R)),
'$undefined'(H,M), !,
functor(H,Na,Ar),
'$dynamic'(Na/Ar,M),
fail.
var(R), !,
'$retract2'(H, M, B, R).
'$retract'(C,M,_) :-
'$fetch_predicate_indicator_from_clause'(C, PI),
'$do_error'(permission_error(modify,static_procedure,PI),retract(M:C)).
@ -472,7 +477,11 @@ retractall(V) :-
'$retractall'(T,M) :-
(
'$is_log_updatable'(T, M) ->
'$retractall_lu'(T,M)
( '$is_multifile'(T, M) ->
'$retractall_lu_mf'(T,M)
;
'$retractall_lu'(T,M)
)
;
'$undefined'(T,M) ->
functor(T,Na,Ar),
@ -485,13 +494,19 @@ retractall(V) :-
'$do_error'(permission_error(modify,static_procedure,Na/Ar),retractall(T))
).
'$retractall_lu'(T,M) :-
'$log_update_clause'(T,M,_,R),
erase(R),
fail.
'$retractall_lu'(_,_).
'$retractall_lu_mf'(T,M) :-
'$log_update_clause'(T,M,_,R),
( recorded('$mf','$mf_clause'(_,_,_,_,R),MR), erase(MR), fail ; true),
erase(R),
fail.
'$retractall_lu_mf'(_,_).
'$erase_all_clauses_for_dynamic'(T, M) :-
'$recordedp'(M:T,(T :- _),R), erase(R), fail.
'$erase_all_clauses_for_dynamic'(T,M) :-
@ -777,7 +792,7 @@ hide_predicate(M:P) :- !,
'$hide_predicate2'(P, M).
hide_predicate(P) :-
'$current_module'(M),
'$hide_predicate2'(M, P).
'$hide_predicate2'(P, M).
'$hide_predicate2'(V, M) :- var(V), !,
'$do_error'(instantiation_error,hide_predicate(M:V)).

11
pl/threads.yap
View File

@ -38,18 +38,19 @@
'$thread_self'(Id),
(Detached == true -> '$detach_thread'(Id) ; true),
'$current_module'(Module),
'$system_catch'((G,'$close_thread'(Detached,true) ; '$close_thread'(Detached,false)),Module,Exception,'$thread_exception'(Exception,Detached)).
% always finish with a throw to make sure we clean stacks.
'$system_catch'((G -> throw('$thread_finished'(true)) ; throw('$thread_finished'(false))),Module,Exception,'$close_thread'(Exception,Detached)).
'$close_thread'(Detached, Status) :-
'$close_thread'('$thread_finished'(Status), Detached) :- !,
'$thread_self'(Id0),
(Detached == true ->
true
;
recorda('$thread_exit_status', [Id0|Status], _)
),
'$run_at_thread_exit'(Id0).
'$thread_exception'(Exception,Detached) :-
format(user_error,'closing thread ~w~n',[v([Id0|Status])]).
'$run_at_thread_exit'(Id0).
'$close_thread'(Exception,Detached) :-
'$thread_self'(Id0),
(Detached == true ->
true

25
pl/utils.yap
View File

@ -200,17 +200,24 @@ call_cleanup(Goal, Catcher, Cleanup) :-
'$call_cleanup'(Goal, Cleanup, Result) :-
'$freeze_goal'(Result, '$clean_call'(Cleanup)),
yap_hacks:trail_suspension_marker(Result),
yap_hacks:current_choice_point(CP0),
( '$execute'(Goal),
yap_hacks:current_choice_point(CPF),
( CP0 =:= CPF ->
Result = exit, !
; true
)
; Result = fail,
fail
(
yap_hacks:current_choice_point(CP0),
'$execute'(Goal),
yap_hacks:current_choice_point(CPF),
(
CP0 =:= CPF ->
Result = exit,
!
;
true
)
;
Result = fail,
fail
).
'$holds_true'.
'$clean_call'(Cleanup) :-
'$execute'(Cleanup), !.
'$clean_call'(_).