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

global variables

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1685 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc 2006-08-22 16:12:46 +00:00
parent 0f714371e5
commit d11fd73306
31 changed files with 1712 additions and 640 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
C/agc.c
View File

@ -123,6 +123,8 @@ AtomAdjust(Atom a)
#define CodeAddrAdjust(P) (P)
#define ConsultObjAdjust(P) (P)
#define DelayAddrAdjust(P) (P)
#define DelayAdjust(P) (P)
#define GlobalAdjust(P) (P)
#define DBRefAdjust(P) (P)
#define DBRefPAdjust(P) (P)
#define DBTermAdjust(P) (P)
@ -134,6 +136,7 @@ AtomAdjust(Atom a)
#define PtoStCAdjust(P) (P)
#define PtoArrayEAdjust(P) (P)
#define PtoArraySAdjust(P) (P)
#define PtoGlobalEAdjust(P) (P)
#define PtoDelayAdjust(P) (P)
#define PtoGloAdjust(P) (P)
#define PtoLocAdjust(P) (P)
@ -282,16 +285,13 @@ mark_global(void)
* the code
*/
#if COROUTINING
CELL *ptf = (CELL *)DelayTop();
pt = (CELL *)Yap_GlobalBase;
while (pt < ptf) {
pt = mark_global_cell(pt);
}
#endif
pt = (CELL *)DelayTop();
#else
pt = H0;
#endif
while (pt < H) {
pt = mark_global_cell(pt);
pt++;
}
}

24
C/attvar.c
View File

@ -77,8 +77,9 @@ CopyAttVar(CELL *orig, CELL ***to_visit_ptr, CELL *res)
/* add a new attributed variable */
newv = DelayTop();
if (H0 - (CELL *)newv < 1024)
if ((ADDR)newv - Yap_GlobalBase < 1024*sizeof(CELL))
return FALSE;
newv--;
RESET_VARIABLE(&(newv->Value));
RESET_VARIABLE(&(newv->Done));
vt = &(attv->Atts);
@ -94,7 +95,7 @@ CopyAttVar(CELL *orig, CELL ***to_visit_ptr, CELL *res)
to_visit[3] = (CELL *)vt[-1];
*to_visit_ptr = to_visit+4;
*res = (CELL)&(newv->Done);
SetDelayTop(newv+1);
SetDelayTop(newv);
return TRUE;
}
@ -110,13 +111,13 @@ static attvar_record *
BuildNewAttVar(void)
{
attvar_record *attv = DelayTop();
if (H0 - (CELL *)(attv+1) < 1024) {
return NULL;
}
if ((ADDR)attv - Yap_GlobalBase < 1024*sizeof(CELL))
return FALSE;
attv--;
RESET_VARIABLE(&(attv->Done));
RESET_VARIABLE(&(attv->Value));
RESET_VARIABLE(&(attv->Atts));
SetDelayTop(attv+1);
SetDelayTop(attv);
return attv;
}
@ -415,18 +416,16 @@ AllAttVars(attvar_record *attv) {
CELL *h0 = H;
attvar_record *max = DelayTop();
while (attv != max) {
while (--attv >= max) {
if (ASP - H < 1024) {
H = h0;
Yap_Error_Size = (ASP-H)*sizeof(CELL);
return 0L;
}
if (IsVarTerm(attv->Done) && IsUnboundVar(&attv->Done)) {
if (IsIntegerTerm(attv->Atts)) {
if (IsVarTerm(attv->Atts) && VarOfTerm(attv->Atts) < (CELL *)attv) {
/* skip call residue(s) */
UInt n = IntegerOfTerm(attv->Atts)-1;
attv += n;
attv = (attvar_record *)(attv->Atts);
} else {
if (H != h0) {
H[-1] = AbsPair(H);
@ -435,7 +434,6 @@ AllAttVars(attvar_record *attv) {
H += 2;
}
}
attv++;
}
if (H != h0) {
H[-1] = TermNil;
@ -882,7 +880,7 @@ p_all_attvars(void)
Term out;
attvar_record *base;
base = (attvar_record *)Yap_GlobalBase+IntegerOfTerm(Yap_ReadTimedVar(AttsMutableList));
base = (attvar_record *)Yap_ReadTimedVar(AttsMutableList);
if (!(out = AllAttVars(base))) {
if (!Yap_gcl(Yap_Error_Size, 1, ENV, P)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);

10
C/bignum.c
View File

@ -51,15 +51,7 @@ Yap_MkBigIntTerm(MP_INT *big)
dst->_mp_alloc = big->_mp_alloc;
memmove((void *)(dst+1), (const void *)(big->_mp_d), nlimbs*CellSize);
H = (CELL *)(dst+1)+nlimbs;
if ((char *)H-(char *)ret > MAX_SPECIALS_TAG-EndSpecials) {
/* too large */
return TermNil;
}
#if GC_NO_TAGS
H[0] = (H-ret)*sizeof(CELL)+EndSpecials;
#else
H[0] = ((H-ret)*sizeof(CELL)+EndSpecials)|MBIT;
#endif
H[0] = EndSpecials;
H++;
return AbsAppl(ret);
}

22
C/corout.c
View File

@ -49,31 +49,25 @@ p_set_svar_list(void)
Term newl = Deref(ARG1);
attvar_record *max = DelayTop();
if (IsVarTerm(newl)) {
if (IsVarTerm(newl) && VarOfTerm(newl) > H0) {
/* set to current top */
UInt diff;
Term tdiff;
max--;
RESET_VARIABLE(&max->Done);
RESET_VARIABLE(&max->Value);
max->Atts = MkIntTerm(1);
max++;
RESET_VARIABLE(&(max->Atts));
SetDelayTop(max);
diff = max-(attvar_record *)Yap_GlobalBase;
tdiff = MkIntegerTerm(diff);
Yap_UpdateTimedVar(AttsMutableList,tdiff);
return Yap_unify(ARG1,tdiff);
Yap_UpdateTimedVar(AttsMutableList,(CELL)max);
return Yap_unify(ARG1,(CELL)max);
} else {
UInt old = IntegerOfTerm(Yap_UpdateTimedVar(AttsMutableList,newl));
attvar_record *aold = (attvar_record *)Yap_GlobalBase + (old-1);
attvar_record *aold = (attvar_record *)Yap_UpdateTimedVar(AttsMutableList,newl);
if (max > aold+1) {
if (max < aold) {
/* we are moving forward */
/* these items are protected by call-residue, should not
be visible to AllAtts
*/
MaBind(&(aold->Atts),MkIntegerTerm(max-aold));
MaBind(&(aold->Atts),(CELL)max);
}
}
#endif

24
C/dbase.c
View File

@ -630,11 +630,7 @@ copy_long_int(CELL *st, CELL *pt)
/* first thing, store a link to the list before we move on */
st[0] = (CELL)FunctorLongInt;
st[1] = pt[1];
#if GC_NO_TAGS
st[2] = 2*sizeof(CELL)+EndSpecials;
#else
st[2] = ((2*sizeof(CELL)+EndSpecials)|MBIT);
#endif
st[2] = EndSpecials;
/* now reserve space */
return st+3;
}
@ -647,17 +643,9 @@ copy_double(CELL *st, CELL *pt)
st[1] = pt[1];
#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
st[2] = pt[2];
#if GC_NO_TAGS
st[3] = 3*sizeof(CELL)+EndSpecials;
st[3] = EndSpecials;
#else
st[3] = ((3*sizeof(CELL)+EndSpecials)|MBIT);
#endif /* GC_NO_TAGS */
#else
#if GC_NO_TAGS
st[2] = 2*sizeof(CELL)+EndSpecials;
#else
st[2] = ((2*sizeof(CELL)+EndSpecials)|MBIT);
#endif /* GC_NO_TAGS */
st[2] = EndSpecials;
#endif
/* now reserve space */
return st+(2+SIZEOF_DOUBLE/SIZEOF_LONG_INT);
@ -677,11 +665,7 @@ copy_big_int(CELL *st, CELL *pt)
memcpy((void *)(st+1), (void *)(pt+1), sz);
st = st+1+sz/CellSize;
/* then the tail for gc */
#if GC_NO_TAGS
st[0] = sz+CellSize+EndSpecials;
#else
st[0] = (sz+CellSize+EndSpecials)|MBIT;
#endif
st[0] = EndSpecials;
return st+1;
}
#endif /* BIG_INT */

7
C/exec.c
View File

@ -1779,6 +1779,7 @@ p_generate_pred_info(void) {
void
Yap_InitYaamRegs(void)
{
Term h0var;
#if PUSH_REGS
/* Guarantee that after a longjmp we go back to the original abstract
@ -1824,10 +1825,10 @@ Yap_InitYaamRegs(void)
/* for slots to work */
Yap_StartSlots();
#if COROUTINING
RESET_VARIABLE((CELL *)Yap_GlobalBase);
DelayedVars = Yap_NewTimedVar(MkIntTerm(0));
h0var = MkVarTerm();
DelayedVars = Yap_NewTimedVar(h0var);
WokenGoals = Yap_NewTimedVar(TermNil);
AttsMutableList = Yap_NewTimedVar(MkIntTerm(0));
AttsMutableList = Yap_NewTimedVar(h0var);
#endif
GcGeneration = Yap_NewTimedVar(MkIntTerm(0));
GcCurrentPhase = 0L;

1162
C/globals.c Normal file
View File

File diff suppressed because it is too large Load Diff

10
C/gprof.c
View File

@ -11,8 +11,12 @@
* File: gprof.c *
* comments: Interrupt Driven Profiler *
* *
* Last rev: $Date: 2006-08-07 18:51:44 $,$Author: vsc $ *
* Last rev: $Date: 2006-08-22 16:12:45 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.6 2006/08/07 18:51:44 vsc
* fix garbage collector not to try to garbage collect when we ask for large
* chunks of stack in a single go.
*
* Revision 1.5 2006/04/27 20:58:59 rslopes
* fix do profiler offline.
*
@ -843,7 +847,7 @@ showprofres(UInt type) {
if (calls && myp->FunctorOfPred->KindOfPE==47872) {
count+=calls;
printf("%p",myp);
if (myp->ModuleOfPred!=NULL) printf(" %s",RepAtom(AtomOfTerm(myp->ModuleOfPred))->StrOfAE);
if (myp->ModuleOfPred) printf(" %s",RepAtom(AtomOfTerm(myp->ModuleOfPred))->StrOfAE);
printf(":%s",RepAtom(NameOfFunctor(myp->FunctorOfPred))->StrOfAE);
if (myp->ArityOfPE) printf("/%d",myp->ArityOfPE);
printf(" -> %lu (%3.1f%c)\n",(unsigned long int)calls,(float) calls*100/ProfCalls,'%');
@ -868,7 +872,7 @@ showprofres(UInt type) {
}
count+=calls;
// printf("%p %p",t->pp, t->beg);
if (t->pp->ModuleOfPred!=NULL) printf(" %s",RepAtom(AtomOfTerm(t->pp->ModuleOfPred))->StrOfAE);
if (t->pp->ModuleOfPred) printf(" %s",RepAtom(AtomOfTerm(t->pp->ModuleOfPred))->StrOfAE);
printf(":%s",RepAtom(NameOfFunctor(t->pp->FunctorOfPred))->StrOfAE);
if (t->pp->ArityOfPE) printf("/%d",t->pp->ArityOfPE);
printf(" -> %lu (%3.1f%c)\n",(unsigned long int)calls,(float) calls*100/ProfCalls,'%');

238
C/grow.c
View File

@ -35,7 +35,7 @@
#endif
#if !COROUTINING
#define DelayTop() Yap_GlobalBase
#define DelayTop() H0
#endif
static int heap_overflows = 0;
@ -66,7 +66,6 @@ STATIC_PROTO(int growstack, (long));
STATIC_PROTO(void MoveGlobal, (void));
STATIC_PROTO(void MoveLocalAndTrail, (void));
STATIC_PROTO(void SetHeapRegs, (void));
STATIC_PROTO(void SetStackRegs, (void));
STATIC_PROTO(void AdjustTrail, (int));
STATIC_PROTO(void AdjustLocal, (void));
STATIC_PROTO(void AdjustGlobal, (void));
@ -86,7 +85,7 @@ cpcellsd(register CELL *Dest, register CELL *Org, CELL NOf)
#else
register Int n_of = NOf;
for (; n_of >= 0; n_of--)
*--Dest = *--Org;
*Dest++ = *Org++;
#endif
}
@ -156,60 +155,10 @@ SetHeapRegs(void)
S = PtoGloAdjust(S);
else if (IsOldLocalPtr(S))
S = PtoLocAdjust(S);
#ifdef COROUTINING
if (DelayedVars)
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
if (AttsMutableList)
AttsMutableList = AbsAppl(PtoGloAdjust(RepAppl(AttsMutableList)));
if (WokenGoals)
WokenGoals = AbsAppl(PtoGloAdjust(RepAppl(WokenGoals)));
#endif
GcGeneration = AbsAppl(PtoGloAdjust(RepAppl(GcGeneration)));
GcPhase = AbsAppl(PtoGloAdjust(RepAppl(GcPhase)));
}
static void
SetStackRegs(void)
{
/* The old local stack pointers */
OldLCL0 = LCL0;
OldASP = ASP;
OldH = H;
OldH0 = H0;
OldGlobalBase = (CELL *)Yap_GlobalBase;
OldTrailTop = Yap_TrailTop;
OldTrailBase = Yap_TrailBase;
OldTR = TR;
OldHeapBase = Yap_HeapBase;
OldHeapTop = HeapTop;
/* The local and aux stack addresses */
Yap_TrailBase = TrailAddrAdjust(Yap_TrailBase);
Yap_TrailTop = TrailAddrAdjust(Yap_TrailTop);
Yap_LocalBase = LocalAddrAdjust(Yap_LocalBase);
TR = PtoTRAdjust(TR);
/* The registers pointing to the local stack */
if (ENV)
ENV = PtoLocAdjust(ENV);
if (ASP)
ASP = PtoLocAdjust(ASP);
if (LCL0)
LCL0 = PtoLocAdjust(LCL0);
if (B)
B = ChoicePtrAdjust(B);
#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);
#endif
#ifdef TABLING
if (B_FZ)
B_FZ = ChoicePtrAdjust(B_FZ);
if (BB)
BB = ChoicePtrAdjust(BB);
if (TR_FZ)
TR_FZ = PtoTRAdjust(TR_FZ);
#endif /* TABLING */
if (YENV)
YENV = PtoLocAdjust(YENV);
if (GlobalArena)
GlobalArena = AbsAppl(PtoGloAdjust(RepAppl(GlobalArena)));
if (GlobalDelayArena)
GlobalDelayArena = GlobalAdjust(GlobalDelayArena);
#ifdef COROUTINING
if (DelayedVars)
DelayedVars = AbsAppl(PtoGloAdjust(RepAppl(DelayedVars)));
@ -227,17 +176,9 @@ MoveLocalAndTrail(void)
{
/* cpcellsd(To,From,NOfCells) - copy the cells downwards */
#if USE_SYSTEM_MALLOC
#if HAVE_MEMMOVE
cpcellsd(ASP, (CELL *)((char *)OldASP+DelayDiff), (CELL *)OldTR - OldASP);
#else
cpcellsd((CELL *)TR, (CELL *)((char *)OldTR+Delaydiff), (CELL *)OldTR - OldASP);
#endif
#else
#if HAVE_MEMMOVE
cpcellsd(ASP, OldASP, (CELL *)OldTR - OldASP);
#else
cpcellsd((CELL *)TR, (CELL *)OldTR, (CELL *)OldTR - OldASP);
#endif
#endif
}
@ -248,44 +189,40 @@ MoveGlobal(void)
* cpcellsd(To,From,NOfCells) - copy the cells downwards - in
* absmi.asm
*/
#if HAVE_MEMMOVE
cpcellsd((CELL *)Yap_GlobalBase, (CELL *)OldGlobalBase, OldH - (CELL *)OldGlobalBase);
#else
cpcellsd(H, OldH, OldH - (CELL *)OldGlobalBase);
#endif
}
static void
MoveGlobalOnly(void)
MoveExpandedGlobal(void)
{
/*
* cpcellsd(To,From,NOfCells) - copy the cells downwards - in
* absmi.asm
*/
cpcellsd((CELL *)(Yap_GlobalBase+GDiff), (CELL *)OldGlobalBase, OldH - (CELL *)OldGlobalBase);
}
static void
MoveGlobalWithHole(void)
{
/*
* cpcellsd(To,From,NOfCells) - copy the cells downwards - in
* absmi.asm
*/
cpcellsd((CELL *)((char *)OldGlobalBase+GDiff0), (CELL *)OldGlobalBase, OldH - (CELL *)OldGlobalBase);
}
static void
MoveHalfGlobal(CELL *OldPt)
{
/*
* cpcellsd(To,From,NOfCells) - copy the cells downwards - in
* absmi.asm
*/
#if USE_SYSTEM_MALLOC
#if HAVE_MEMMOVE
cpcellsd(H0, (CELL *)((char *)OldH0+DelayDiff), OldH - OldH0);
#else
cpcellsd(H, (CELL *)((char *)OldH+DelayDiff), OldH - OldH0);
#endif
#else
#if HAVE_MEMMOVE
cpcellsd(H0, OldH0, OldH - OldH0);
#else
cpcellsd(H, OldH, OldH - OldH0);
#endif
#endif
}
static void
MoveDelays(void)
{
UInt sz = (ADDR)OldH0-(ADDR)OldGlobalBase;
#if HAVE_MEMMOVE
cpcellsd((CELL *)Yap_GlobalBase, OldGlobalBase, sz);
#else
cpcellsd(H0, OldH0, sz);
#endif
UInt diff = OldH-OldPt;
CELL *NewPt = (CELL *)((char*)OldPt+GDiff);
CELL *IntPt = (CELL *)((char*)OldPt+GDiff0);
cpcellsd(NewPt, IntPt, diff);
}
static inline CELL
@ -295,8 +232,6 @@ AdjustAppl(register CELL t0)
if (IsOldGlobalPtr(t))
return (AbsAppl(PtoGloAdjust(t)));
else if (IsOldDelayPtr(t))
return (AbsAppl(PtoDelayAdjust(t)));
else if (IsOldTrailPtr(t))
return (AbsAppl(CellPtoTRAdjust(t)));
else if (IsHeapP(t))
@ -317,8 +252,6 @@ AdjustPair(register CELL t0)
if (IsOldGlobalPtr(t))
return (AbsPair(PtoGloAdjust(t)));
if (IsOldDelayPtr(t))
return (AbsPair(PtoDelayAdjust(t)));
if (IsOldTrailPtr(t))
return (AbsPair(CellPtoTRAdjust(t)));
else if (IsHeapP(t))
@ -348,8 +281,6 @@ AdjustTrail(int adjusting_heap)
TrailTerm(ptt) = LocalAdjust(reg);
else if (IsOldGlobal(reg))
TrailTerm(ptt) = GlobalAdjust(reg);
else if (IsOldDelay(reg))
TrailTerm(ptt) = DelayAdjust(reg);
else if (IsOldTrail(reg))
TrailTerm(ptt) = TrailAdjust(reg);
} else if (IsPairTerm(reg)) {
@ -367,8 +298,6 @@ AdjustTrail(int adjusting_heap)
TrailVal(ptt) = LocalAdjust(reg2);
else if (IsOldGlobal(reg2))
TrailVal(ptt) = GlobalAdjust(reg2);
else if (IsOldDelay(reg2))
TrailVal(ptt) = DelayAdjust(reg2);
else if (IsOldTrail(reg2))
TrailVal(ptt) = TrailAdjust(reg2);
} else if (IsApplTerm(reg2)) {
@ -395,8 +324,6 @@ AdjustLocal(void)
*pt = LocalAdjust(reg);
else if (IsOldGlobal(reg))
*pt = GlobalAdjust(reg);
else if (IsOldDelay(reg))
*pt = DelayAdjust(reg);
else if (IsOldTrail(reg))
*pt = TrailAdjust(reg);
else if (IsOldCode(reg))
@ -416,8 +343,6 @@ AdjustGlobTerm(Term reg)
if (IsVarTerm(reg)) {
if (IsOldGlobal(reg))
return GlobalAdjust(reg);
else if (IsOldDelay(reg))
return DelayAdjust(reg);
else if (IsOldLocal(reg))
return LocalAdjust(reg);
#ifdef MULTI_ASSIGNMENT_VARIABLES
@ -437,11 +362,19 @@ AdjustGlobal(void)
CELL *pt;
ArrayEntry *al = DynamicArrays;
StaticArrayEntry *sal = StaticArrays;
GlobalEntry *gl = GlobalVariables;
while (al) {
al->ValueOfVE = AdjustGlobTerm(al->ValueOfVE);
al = al->NextAE;
}
while (gl) {
if (IsVarTerm(gl->global) ||
!IsAtomOrIntTerm(gl->global)) {
gl->global = AdjustGlobTerm(gl->global);
}
gl = gl->NextGE;
}
while (sal) {
if (sal->ArrayType == array_of_nb_terms) {
UInt arity = -sal->ArrayEArity, i;
@ -465,11 +398,9 @@ AdjustGlobal(void)
register CELL reg;
reg = *pt;
if (IsVarTerm(reg)) {
if (IsVarTerm(reg)) {
if (IsOldGlobal(reg))
*pt = GlobalAdjust(reg);
else if (IsOldDelay(reg))
*pt = DelayAdjust(reg);
else if (IsOldLocal(reg))
*pt = LocalAdjust(reg);
else if (IsOldCode(reg)) {
@ -559,8 +490,6 @@ AdjustRegs(int n)
reg = LocalAdjust(reg);
else if (IsOldGlobal(reg))
reg = GlobalAdjust(reg);
else if (IsOldDelay(reg))
reg = DelayAdjust(reg);
else if (IsOldTrail(reg))
reg = TrailAdjust(reg);
else if (IsOldCode(reg))
@ -618,7 +547,8 @@ static_growheap(long size, int fix_code, struct intermediates *cip)
ASP -= 256;
YAPEnterCriticalSection();
TrDiff = LDiff = GDiff = DelayDiff = size;
XDiff = HDiff = 0;
XDiff = HDiff = GDiff0 = 0;
GSplit = NULL;
SetHeapRegs();
MoveLocalAndTrail();
if (fix_code) {
@ -644,21 +574,31 @@ static_growheap(long size, int fix_code, struct intermediates *cip)
return(TRUE);
}
/* Used by do_goal() when we're short of heap space */
/* Used when we're short of heap, usually because of an overflow in
the attributed stack, but also because we allocated a zone */
static int
static_growglobal(long size, CELL **ptr)
static_growglobal(long size, CELL **ptr, CELL *hsplit)
{
UInt start_growth_time, growth_time;
int gc_verbose;
char *omax = (ADDR)DelayTop();
ADDR old_GlobalBase = Yap_GlobalBase;
UInt minimal_request = 0L;
long size0;
long size0, sz = size;
char vb_msg1, *vb_msg2;
if (hsplit) {
/* just a little bit of sanity checking */
if (hsplit < (CELL*)omax ||
hsplit > H)
return FALSE;
else if (hsplit == (CELL *)omax)
hsplit = NULL;
}
/* adjust to a multiple of 256) */
Yap_PrologMode |= GrowStackMode;
if (size < (omax-Yap_GlobalBase)/8)
size = (omax-Yap_GlobalBase)/8;
if (size < ((char *)H0-omax)/8)
size = ((char *)H0-omax)/8;
size0 = size = AdjustPageSize(size);
Yap_ErrorMessage = NULL;
if (!Yap_ExtendWorkSpace(size)) {
@ -676,8 +616,20 @@ static_growglobal(long size, CELL **ptr)
gc_verbose = Yap_is_gc_verbose();
delay_overflows++;
if (gc_verbose) {
fprintf(Yap_stderr, "%% DO Delay overflow %d\n", delay_overflows);
fprintf(Yap_stderr, "%% DO growing the stacks %ld bytes\n", size);
if (hsplit) {
if (hsplit > H0) {
vb_msg1 = 'H';
vb_msg2 = "Global Variable Space";
} else {
vb_msg1 = 'D';
vb_msg2 = "Global Variable Delay Space";
}
} else {
vb_msg1 = 'D';
vb_msg2 = "Delay";
}
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;
YAPEnterCriticalSection();
@ -695,18 +647,30 @@ static_growglobal(long size, CELL **ptr)
DelayDiff = 0;
}
#endif
if (hsplit) {
GDiff0 = GDiff-sz;
GSplit = hsplit;
} else {
GDiff0 = DelayDiff;
GSplit = NULL;
}
XDiff = HDiff = 0;
Yap_GlobalBase = old_GlobalBase;
SetHeapRegs();
MoveLocalAndTrail();
MoveGlobalOnly();
if (minimal_request) {
MoveDelays();
if (hsplit) {
MoveGlobalWithHole();
} else {
MoveExpandedGlobal();
}
AdjustStacksAndTrail();
AdjustRegs(MaxTemps);
if (ptr)
if (ptr) {
*ptr = PtoLocAdjust(*ptr);
}
if (hsplit) {
MoveHalfGlobal(hsplit);
}
YAPLeaveCriticalSection();
ASP += 256;
if (minimal_request) {
@ -715,14 +679,13 @@ static_growglobal(long size, CELL **ptr)
growth_time = Yap_cputime()-start_growth_time;
total_delay_overflow_time += growth_time;
if (gc_verbose) {
fprintf(Yap_stderr, "%% DO took %g sec\n", (double)growth_time/1000);
fprintf(Yap_stderr, "%% DO Total of %g sec expanding stacks \n", (double)total_delay_overflow_time/1000);
fprintf(Yap_stderr, "%% %cO took %g sec\n", vb_msg1, (double)growth_time/1000);
fprintf(Yap_stderr, "%% %cO Total of %g sec expanding stacks \n", vb_msg1, (double)total_delay_overflow_time/1000);
}
Yap_PrologMode &= ~GrowStackMode;
return(TRUE);
}
static void
fix_compiler_instructions(PInstr *pcpc)
{
@ -1072,7 +1035,7 @@ Yap_growglobal(CELL **ptr)
return(FALSE);
}
#endif
if (!static_growglobal(sz, ptr))
if (!static_growglobal(sz, ptr, NULL))
return(FALSE);
#ifdef TABLING
fix_tabling_info();
@ -1081,6 +1044,18 @@ Yap_growglobal(CELL **ptr)
}
int
Yap_InsertInGlobal(CELL *where, UInt howmuch)
{
if (!static_growglobal(howmuch, NULL, where))
return FALSE;
#ifdef TABLING
fix_tabling_info();
#endif /* TABLING */
return TRUE;
}
int
Yap_growstack(long size)
{
@ -1202,6 +1177,7 @@ execute_growstack(long size0, int from_trail, int in_parser, tr_fr_ptr *old_trp,
}
}
XDiff = HDiff = 0;
GDiff0=0;
#if USE_SYSTEM_MALLOC
if (from_trail) {
TrDiff = LDiff = GDiff;
@ -1216,11 +1192,7 @@ execute_growstack(long size0, int from_trail, int in_parser, tr_fr_ptr *old_trp,
}
#endif
ASP -= 256;
if (GDiff) {
SetHeapRegs();
} else {
SetStackRegs();
}
SetHeapRegs();
if (from_trail) {
Yap_TrailTop += size0;
}
@ -1382,7 +1354,7 @@ static int do_growtrail(long size, int contiguous_only, int in_parser, tr_fr_ptr
} else {
YAPEnterCriticalSection();
if (in_parser) {
TrDiff = LDiff = GDiff = DelayDiff = XDiff = HDiff = 0;
TrDiff = LDiff = GDiff = DelayDiff = XDiff = HDiff = GDiff0 = 0;
AdjustScannerStacks(tksp, vep);
}
Yap_TrailTop += size;

402
C/heapgc.c
View File

@ -99,12 +99,6 @@ typedef struct RB_red_blk_node {
/* in a single gc */
static unsigned long int total_marked, total_oldies; /* number of heap objects marked */
#if DEBUG
#ifdef COROUTINING
static unsigned long int total_smarked;
#endif
#endif
#ifdef EASY_SHUNTING
static choiceptr current_B;
@ -399,10 +393,17 @@ push_registers(Int num_regs, yamop *nextop)
/* push array entries first */
ArrayEntry *al = DynamicArrays;
GlobalEntry *gl = GlobalVariables;
TrailTerm(TR++) = GlobalArena;
TrailTerm(TR++) = GlobalDelayArena;
while (al) {
TrailTerm(TR++) = al->ValueOfVE;
al = al->NextAE;
}
while (gl) {
TrailTerm(TR++) = gl->global;
gl = gl->NextGE;
}
while (sal) {
if (sal->ArrayType == array_of_nb_terms) {
UInt arity = -sal->ArrayEArity, i;
@ -463,10 +464,18 @@ pop_registers(Int num_regs, yamop *nextop)
/* pop array entries first */
ArrayEntry *al = DynamicArrays;
GlobalEntry *gl = GlobalVariables;
GlobalArena = TrailTerm(ptr++);
GlobalDelayArena = TrailTerm(ptr++);
while (al) {
al->ValueOfVE = TrailTerm(ptr++);
al = al->NextAE;
}
while (gl) {
gl->global = TrailTerm(ptr++);
gl = gl->NextGE;
}
sal = StaticArrays;
while (sal) {
if (sal->ArrayType == array_of_nb_terms) {
@ -1034,20 +1043,17 @@ check_global(void) {
if (MARKED_PTR(current)) {
CELL ccell = UNMARK_CELL(ccurr);
if (
ccell < MAX_SPECIALS_TAG && /* two first pages */
ccell > EndSpecials && IsVarTerm(ccell)) {
if (ccell == EndSpecials) {
/* oops, we found a blob */
int nofcells = (UNMARK_CELL(*current)-EndSpecials) / sizeof(CELL);
CELL *ptr = current - nofcells ;
CELL *ptr = current-1;
UInt nofcells;
while (!MARKED_PTR(ptr)) ptr--;
nofcells = current-ptr;
current = ptr;
ccurr = *current;
/* process the functor next */
}
if (MARKED_PTR(current)) {
printf("Oops, found marked cell at %p\n", current);
break;
}
}
#if INSTRUMENT_GC
if (IsVarTerm(ccurr)) {
@ -1279,51 +1285,35 @@ mark_variable(CELL_PTR current)
}
total_marked += 3;
PUSH_POINTER(next);
PUSH_POINTER(next+1);
PUSH_POINTER(next+2);
POP_CONTINUATION();
case (CELL)FunctorDouble:
MARK(next);
if (next < HGEN) {
total_oldies+=2+SIZEOF_DOUBLE/SIZEOF_LONG_INT;
}
total_marked += 2+SIZEOF_DOUBLE/SIZEOF_LONG_INT;
PUSH_POINTER(next);
PUSH_POINTER(next+1);
PUSH_POINTER(next+2);
#if SIZEOF_DOUBLE==2*SIZEOF_LONG_INT
PUSH_POINTER(next+3);
#if GC_NO_TAGS
MARK(next+3);
#endif
#elif GC_NO_TAGS
MARK(next+2);
#endif
{
UInt sz = 1+SIZEOF_DOUBLE/SIZEOF_LONG_INT;
if (next < HGEN) {
total_oldies+= 1+sz;
}
total_marked += 1+sz;
PUSH_POINTER(next+sz);
MARK(next+sz);
}
POP_CONTINUATION();
#ifdef USE_GMP
case (CELL)FunctorBigInt:
MARK(next);
/* size is given by functor + friends */
if (next < HGEN) {
total_oldies+=2+
(sizeof(MP_INT)+
(((MP_INT *)(next+1))->_mp_alloc*sizeof(mp_limb_t)))/CellSize;
}
total_marked += 2+
(sizeof(MP_INT)+
(((MP_INT *)(next+1))->_mp_alloc*sizeof(mp_limb_t)))/CellSize;
{
int i;
UInt sz = (sizeof(MP_INT)+
(((MP_INT *)(next+1))->_mp_alloc*sizeof(mp_limb_t)))/CellSize;
MARK(next);
/* size is given by functor + friends */
if (next < HGEN)
total_oldies += 2+sz;
total_marked += 2+sz;
PUSH_POINTER(next);
for (i = 1; i <= (sizeof(MP_INT)+
(((MP_INT *)(next+1))->_mp_alloc*sizeof(mp_limb_t)))/CellSize;
i++) {
PUSH_POINTER(next+i);
}
#if GC_NO_TAGS
MARK(next+i);
#endif
PUSH_POINTER(next+i);
sz++;
MARK(next+sz);
PUSH_POINTER(next+sz);
}
POP_CONTINUATION();
#endif
@ -1430,9 +1420,8 @@ mark_regs(tr_fr_ptr old_TR)
static void
mark_delays(CELL *max)
{
CELL *ptr = (CELL *)Yap_GlobalBase;
for (; ptr < max; ptr++) {
mark_external_reference2(ptr);
for (; max < H0; max++) {
mark_external_reference2(max);
}
}
#endif
@ -3035,68 +3024,43 @@ compact_heap(void)
for (current = H - 1; current >= start_from; current--) {
if (MARKED_PTR(current)) {
CELL ccell = UNMARK_CELL(*current);
if (
IN_BETWEEN(EndSpecials, ccell, MAX_SPECIALS_TAG) /* two first pages */
&& IsVarTerm(ccell)
) {
/* oops, we found a blob */
int nofcells = (UNMARK_CELL(*current)-EndSpecials) / sizeof(CELL);
CELL *ptr;
if (!nofcells) {
/* Arrays */
nofcells = current[-1];
}
ptr = current - nofcells;
if (MARKED_PTR(ptr)) {
#ifdef DEBUG
found_marked+=nofcells;
#endif /* DEBUG */
if (current <= next_hb) {
gc_B = update_B_H(gc_B, current, dest, dest+1
#ifdef TABLING
, &depfr
#endif
);
next_hb = set_next_hb(gc_B);
}
/* this one's being used */
/* first swap the tag so that it will be seen by the next step */
{
CELL tmp = current[0];
current[0] = ptr[1];
#if GC_NO_TAGS
MARK(ptr+1);
#endif
ptr[1] = tmp;
}
if (in_garbage > 0) {
current[1] = in_garbage;
in_garbage = 0;
}
dest -= nofcells;
current = ptr;
/* process the functor next */
} else {
/* skip the term */
in_garbage += nofcells+1;
current = ptr;
continue;
}
} else {
if (current <= next_hb) {
gc_B = update_B_H(gc_B, current, dest, dest+1
#ifdef TABLING
, &depfr
#endif
);
next_hb = set_next_hb(gc_B);
}
}
if (in_garbage > 0) {
current[1] = in_garbage;
in_garbage = 0;
}
if (current <= next_hb) {
gc_B = update_B_H(gc_B, current, dest, dest+1
#ifdef TABLING
, &depfr
#endif
);
next_hb = set_next_hb(gc_B);
}
if (ccell == EndSpecials) {
/* oops, we found a blob */
CELL *ptr = current-1;
UInt nofcells;
while (!MARKED_PTR(ptr)) ptr--;
nofcells = current-ptr;
ptr++;
#if GC_NO_TAGS
MARK(ptr);
#else
XXX BROKEN CODE
#endif
found_marked+=nofcells;
/* first swap the tag so that it will be seen by the next step */
current[0] = ptr[0];
ptr[0] = EndSpecials;
dest -= nofcells;
current = ptr;
continue;
/* process the functor on a separate cycle */
}
#ifdef DEBUG
found_marked++;
#endif /* DEBUG */
@ -3125,6 +3089,11 @@ compact_heap(void)
start_from[0] = in_garbage;
#ifdef DEBUG
if (dest != start_from-1)
fprintf(Yap_stderr,"%% Bad Dest (%d): %p should be %p\n",
GcCalls,
dest,
start_from);
if (total_marked != found_marked)
fprintf(Yap_stderr,"%% Upward (%d): %ld total against %ld found\n",
GcCalls,
@ -3145,22 +3114,19 @@ compact_heap(void)
CELL ccur = *current;
if (MARKED_PTR(current)) {
CELL uccur = UNMARK_CELL(ccur);
if (
uccur < MAX_SPECIALS_TAG && /* two first pages */
uccur > EndSpecials && IsVarTerm(uccur)) {
/* oops, we found a blob */
int nofcells = (uccur-EndSpecials) / sizeof(CELL) , i;
if (uccur == EndSpecials) {
CELL *old_dest = dest;
//FIX THIS
*dest++ = current[nofcells-1];
current ++;
for (i = 0; i < nofcells-2; i++) {
CELL *current0=current-1;
dest++;
current++;
while (!MARKED_PTR(current)) {
*dest++ = *current++;
}
*dest++ = ccur;
*old_dest = *current;
*dest++ = EndSpecials;
#ifdef DEBUG
found_marked += nofcells;
found_marked += (dest-old_dest);
#endif
continue;
}
@ -3207,69 +3173,6 @@ compact_heap(void)
}
#ifdef HYBRID_SCHEME
static void
adjust_cp_hbs(void)
{
#ifdef TABLING
dep_fr_ptr depfr = LOCAL_top_dep_fr;
#endif /* TABLING */
choiceptr gc_B = B;
CELL_PTR *top = iptop-1, *base = (CELL_PTR *)H;
#ifdef TABLING
if (depfr != NULL && gc_B >= DepFr_cons_cp(depfr)) {
gc_B = DepFr_cons_cp(depfr);
depfr = DepFr_next(depfr);
}
#endif
while (gc_B != NULL) {
CELL *gc_H = gc_B->cp_h;
CELL_PTR *nbase = base;
#ifdef TABLING
if (depfr && gc_B >= DepFr_cons_cp(depfr)) {
gc_B = DepFr_cons_cp(depfr);
depfr = DepFr_next(depfr);
continue;
}
#endif /* TABLING */
if (top[0] <= gc_H) {
if (top[0] == gc_H) {
gc_B->cp_h = H0+(top-base);
} else {
gc_B->cp_h = H0+((top+1)-base);
}
} else while (TRUE) {
CELL_PTR *nxt = nbase+(top-nbase)/2;
if (nxt[0] > gc_H) {
if (nbase == top) {
if (nbase == base) {
gc_B->cp_h = H0;
break;
} else {
Yap_Error(SYSTEM_ERROR,TermNil,"Bug in Garbage collector");
return;
}
}
top = nxt;
} else if (nxt[0] < gc_H && nxt[1] < gc_H) {
nbase = nxt+1;
} else if (nxt[0] == gc_H) {
gc_B->cp_h = H0+(nxt-base);
top = nxt;
break;
} else {
gc_B->cp_h = H0+((nxt-base)+1);
top = nxt+1;
break;
}
}
gc_B = gc_B->cp_b;
}
}
/*
* move marked objects on the heap upwards over unmarked objects, and reset
* all pointers to point to new locations
@ -3278,9 +3181,15 @@ static void
icompact_heap(void)
{
CELL_PTR *iptr, *ibase = (CELL_PTR *)H;
CELL_PTR dest;
CELL *next_hb;
#ifdef DEBUG
Int found_marked = 0;
#endif /* DEBUG */
#ifdef TABLING
dep_fr_ptr depfr = LOCAL_top_dep_fr;
#endif /* TABLING */
choiceptr gc_B = B;
/*
* upward phase - scan heap from high to low, setting marked upward
@ -3288,39 +3197,51 @@ icompact_heap(void)
* objects pointed to
*/
#ifdef TABLING
if (depfr != NULL && gc_B >= DepFr_cons_cp(depfr)) {
gc_B = DepFr_cons_cp(depfr);
depfr = DepFr_next(depfr);
}
#endif
next_hb = set_next_hb(gc_B);
dest = (CELL_PTR) H0 + total_marked - 1;
for (iptr = iptop - 1; iptr >= ibase; iptr--) {
CELL ccell;
CELL_PTR current;
current = *iptr;
ccell = UNMARK_CELL(*current);
if (ccell < MAX_SPECIALS_TAG && /* two first pages */
ccell > EndSpecials && IsVarTerm(ccell)
) {
/* oops, we found a blob */
int nofcells = (UNMARK_CELL(*current)-EndSpecials) / sizeof(CELL);
CELL *ptr = current - nofcells ;
iptr -= nofcells;
#ifdef DEBUG
found_marked+=nofcells;
#endif /* DEBUG */
/* this one's being used */
/* first swap the tag so that it will be seen by the next step */
{
CELL tmp = current[0];
current[0] = ptr[1];
#if GC_NO_TAGS
MARK(ptr+1);
if (current <= next_hb) {
gc_B = update_B_H(gc_B, current, dest, dest+1
#ifdef TABLING
, &depfr
#endif
ptr[1] = tmp;
}
current = ptr;
);
next_hb = set_next_hb(gc_B);
}
if (ccell == EndSpecials) {
/* oops, we found a blob */
CELL_PTR ptr;
UInt nofcells;
/* use the first cell after the functor for all our dirty tricks */
ptr = iptr[-1]+1;
nofcells = current-ptr;
#ifdef DEBUG
found_marked+=(nofcells+1);
#endif /* DEBUG */
dest -= nofcells+1;
/* this one's being used */
/* make the second step see the EndSpecial tag */
current[0] = ptr[0];
ptr[0] = EndSpecials;
iptr[0] = ptr;
continue;
}
#ifdef DEBUG
found_marked++;
#endif /* DEBUG */
update_relocation_chain(current, H0+(iptr-ibase));
update_relocation_chain(current, dest);
if (HEAP_PTR(*current)) {
CELL_PTR next;
next = GET_NEXT(*current);
@ -3330,15 +3251,22 @@ icompact_heap(void)
else if (current == next) { /* cell pointing to
* itself */
#if GC_NO_TAGS
*current = (CELL) (H0+(iptr-ibase)); /* no tag */
UNRMARK(current);
*current = (CELL) dest; /* no tag */
#else
*current = (*current & MBIT) | (CELL) (H0+(iptr-ibase)); /* no tag */
*current = (*current & MBIT) | (CELL) dest; /* no tag */
#endif
}
}
dest--;
}
#ifdef DEBUG
if (dest != H0-1)
fprintf(Yap_stderr,"%% Bad Dest (%d): %p should be %p\n",
GcCalls,
dest,
H0-1);
if (total_marked != found_marked)
fprintf(Yap_stderr,"%% Upward (%d): %ld total against %ld found\n",
GcCalls,
@ -3354,25 +3282,27 @@ icompact_heap(void)
* locations
*/
dest = H0;
for (iptr = ibase; iptr < iptop; iptr++) {
CELL_PTR next;
CELL *current = *iptr;
CELL ccur = *current;
CELL_PTR dest = H0+(iptr-ibase);
CELL uccur = UNMARK_CELL(ccur);
if (uccur < MAX_SPECIALS_TAG && uccur > EndSpecials && IsVarTerm(uccur)) {
/* oops, we found a blob */
int nofcells = (uccur-EndSpecials) / sizeof(CELL) , i;
*dest++ = current[nofcells-1];
current ++;
for (i = 0; i < nofcells-2; i++) {
if (uccur == EndSpecials) {
CELL *old_dest = dest;
/* leave a hole */
dest++;
current++;
while (!MARKED_PTR(current)) {
*dest++ = *current++;
}
*dest = ccur;
iptr += nofcells-1;
/* fill in hole */
*old_dest = *current;
*dest++ = EndSpecials;
#ifdef DEBUG
found_marked += nofcells;
found_marked += dest-old_dest;
#endif
continue;
}
@ -3388,12 +3318,18 @@ icompact_heap(void)
*dest = ccur;
into_relocation_chain(dest, next);
UNMARK(dest);
dest++;
} else {
/* just move current cell */
*dest = ccur = UNMARK_CELL(ccur);
*dest++ = ccur = UNMARK_CELL(ccur);
}
}
#ifdef DEBUG
if (H0+total_marked != dest)
fprintf(Yap_stderr,"%% Downward (%d): %p total against %p found\n",
GcCalls,
H0+total_marked,
dest);
if (total_marked != found_marked)
fprintf(Yap_stderr,"%% Downward (%d): %ld total against %ld found\n",
GcCalls,
@ -3401,7 +3337,7 @@ icompact_heap(void)
(unsigned long int)found_marked);
#endif
H = H0+(iptop-ibase); /* reset H */
H = dest; /* reset H */
HB = B->cp_h;
#ifdef TABLING
if (B_FZ == (choiceptr)LCL0)
@ -3482,17 +3418,16 @@ sweep_oldgen(CELL *max, CELL *base)
#ifdef COROUTINING
static void
sweep_delays(CELL *max)
sweep_delays(CELL *max, CELL *myH0)
{
CELL *ptr = (CELL *)Yap_GlobalBase;
while (ptr < max) {
if (MARKED_PTR(ptr)) {
UNMARK(ptr);
if (HEAP_PTR(*ptr)) {
into_relocation_chain(ptr, GET_NEXT(*ptr));
while (max < myH0) {
if (MARKED_PTR(max)) {
UNMARK(max);
if (HEAP_PTR(*max)) {
into_relocation_chain(max, GET_NEXT(*max));
}
}
ptr++;
max++;
}
}
#endif
@ -3506,7 +3441,7 @@ sweep_delays(CELL *max)
static void
compaction_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp, CELL *max)
{
CELL *CurrentH0 = NULL;
CELL *CurrentH0 = NULL, *myH0 = H0;
int icompact = (iptop < (CELL_PTR *)ASP && 10*total_marked < H-H0);
@ -3524,7 +3459,7 @@ compaction_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp, CELL *max)
}
}
#ifdef COROUTINING
sweep_delays(max);
sweep_delays(max, myH0);
#endif
sweep_environments(current_env, EnvSize(curp), EnvBMap((CELL *)curp));
sweep_choicepoints(B);
@ -3532,12 +3467,14 @@ compaction_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp, CELL *max)
#ifdef HYBRID_SCHEME
if (icompact) {
#ifdef DEBUG
/*
if (total_marked
#ifdef COROUTINING
-total_smarked
#endif
!= iptop-(CELL_PTR *)H && iptop < (CELL_PTR *)ASP -1024)
fprintf(Yap_stderr,"%% Oops on iptop-H (%ld) vs %ld\n", (unsigned long int)(iptop-(CELL_PTR *)H), total_marked);
*/
#endif
#if DEBUGX
int effectiveness = (((H-H0)-total_marked)*100)/(H-H0);
@ -3550,7 +3487,6 @@ compaction_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp, CELL *max)
CurrentH0 = NULL;
}
quicksort((CELL_PTR *)H, 0, (iptop-(CELL_PTR *)H)-1);
adjust_cp_hbs();
icompact_heap();
} else
#endif /* HYBRID_SCHEME */
@ -3589,7 +3525,7 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop)
gc_trace = FALSE;
#if COROUTINING
max = (CELL *)DelayTop();
while (H0 - max < 1024+(2*NUM_OF_ATTS)) {
while (max - (CELL*)Yap_GlobalBase < 1024+(2*NUM_OF_ATTS)) {
if (!Yap_growglobal(&current_env)) {
Yap_Error(OUT_OF_STACK_ERROR, TermNil, Yap_ErrorMessage);
return -1;

7
C/init.c
View File

@ -971,6 +971,9 @@ InitCodes(void)
Yap_heap_regs->wl[i].scratchpad.msz = SCRATCH_START_SIZE;
Yap_heap_regs->wl[i].dynamic_arrays = NULL;
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_delay_arena = 0L;
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");
@ -984,6 +987,9 @@ InitCodes(void)
#else
Yap_heap_regs->wl.dynamic_arrays = NULL;
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_delay_arena = 0L;
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");
@ -1171,6 +1177,7 @@ InitCodes(void)
Yap_heap_regs->functor_mutable = Yap_MkFunctor(Yap_FullLookupAtom("$mutable_variable"),
sizeof(timed_var)/sizeof(CELL));
#endif
Yap_heap_regs->functor_nb_queue = Yap_MkFunctor(Yap_LookupAtom("queue"), 5);
Yap_heap_regs->functor_not = Yap_MkFunctor(AtomNot, 1);
Yap_heap_regs->functor_or = Yap_MkFunctor(AtomSemic, 2);
Yap_heap_regs->functor_portray = Yap_MkFunctor(AtomPortray, 1);

1
C/save.c
View File

@ -881,6 +881,7 @@ get_regs(int flag)
OldH = H;
OldTR = TR;
GDiff = Unsigned(NewGlobalBase) - Unsigned(Yap_GlobalBase);
GDiff0 = 0;
LDiff = Unsigned(NewLCL0) - Unsigned(LCL0);
TrDiff = LDiff;
Yap_GlobalBase = (ADDR)NewGlobalBase;

27
C/stdpreds.c
View File

@ -11,8 +11,12 @@
* File: stdpreds.c *
* comments: General-purpose C implemented system predicates *
* *
* Last rev: $Date: 2006-08-07 18:51:44 $,$Author: vsc $ *
* Last rev: $Date: 2006-08-22 16:12:46 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.106 2006/08/07 18:51:44 vsc
* fix garbage collector not to try to garbage collect when we ask for large
* chunks of stack in a single go.
*
* Revision 1.105 2006/06/05 19:36:00 vsc
* hacks
*
@ -3000,21 +3004,22 @@ Yap_InitCPreds(void)
Yap_InitCPred("dump_active_goals", 0, p_dump_active_goals, SafePredFlag|SyncPredFlag);
#endif
Yap_InitUnify();
Yap_InitInlines();
Yap_InitCdMgr();
Yap_InitExecFs();
Yap_InitIOPreds();
Yap_InitCmpPreds();
Yap_InitDBPreds();
Yap_InitArrayPreds();
Yap_InitBBPreds();
Yap_InitBigNums();
Yap_InitSysPreds();
Yap_InitSavePreds();
Yap_InitCdMgr();
Yap_InitCmpPreds();
Yap_InitCoroutPreds();
Yap_InitArrayPreds();
Yap_InitDBPreds();
Yap_InitExecFs();
Yap_InitGlobals();
Yap_InitInlines();
Yap_InitIOPreds();
Yap_InitLoadForeign();
Yap_InitModulesC();
Yap_InitSavePreds();
Yap_InitSysPreds();
Yap_InitUnify();
#if defined CUT_C && defined MYDDAS_MYSQL
Yap_InitMYDDAS_MySQLPreds();
#endif

2
C/tracer.c
View File

@ -359,7 +359,7 @@ volatile int vsc_wait;
static Int p_vsc_wait(void)
{
fprintf(stderr,"attach %d\n",getpid());
fprintf(stderr,"attach %d\n",(int)getpid());
while (!vsc_wait);
vsc_wait=1;
return(TRUE);

2
C/utilpreds.c
View File

@ -209,7 +209,7 @@ copy_complex_term(register CELL *pt0, register CELL *pt0_end, CELL *ptf, CELL *H
if (dvars == NULL) {
dvars = (CELL *)DelayTop();
}
if (ptd0 >= dvars) {
if (ptd0 < dvars) {
*ptf++ = (CELL) ptd0;
} else {
tr_fr_ptr CurTR;

2
C/write.c
View File

@ -342,7 +342,7 @@ write_var(CELL *t, struct write_globs *wglb)
#endif
#endif
wrputc('D', wglb->writech);
wrputn(((Int) (t- CellPtr(Yap_GlobalBase))),wglb->writech);
wrputn((Int) ((attvar_record *)H0-(attvar_record *)t),wglb->writech);
} else {
wrputn(((Int) (t- H0)),wglb->writech);
}

14
H/Heap.h
View File

@ -10,7 +10,7 @@
* File: Heap.h *
* mods: *
* comments: Heap Init Structure *
* version: $Id: Heap.h,v 1.102 2006-08-02 18:18:30 vsc Exp $ *
* version: $Id: Heap.h,v 1.103 2006-08-22 16:12:46 vsc Exp $ *
*************************************************************************/
/* information that can be stored in Code Space */
@ -74,12 +74,14 @@ typedef struct scratch_block_struct {
typedef struct restore_info {
Int cl_diff,
g_diff,
g_diff0,
h_diff,
l_diff,
tr_diff,
x_diff,
delay_diff;
CELL *old_ASP, *old_LCL0;
CELL *g_split;
tr_fr_ptr old_TR;
CELL *old_GlobalBase, *old_H, *old_H0;
ADDR old_TrailBase, old_TrailTop;
@ -160,6 +162,9 @@ typedef struct worker_local_struct {
jmp_buf gc_restore; /* where to jump if garbage collection crashes */
struct array_entry *dynamic_arrays;
struct static_array_entry *static_arrays;
struct global_entry *global_variables;
Term global_arena;
Term global_delay_arena;
yamop trust_lu_code[3];
} worker_local;
@ -450,6 +455,7 @@ typedef struct various_codes {
#ifdef MULTI_ASSIGNMENT_VARIABLES
functor_mutable,
#endif
functor_nb_queue,
functor_not,
functor_or,
functor_portray,
@ -733,6 +739,7 @@ struct various_codes *Yap_heap_regs;
#ifdef MULTI_ASSIGNMENT_VARIABLES
#define FunctorMutable Yap_heap_regs->functor_mutable
#endif
#define FunctorNBQueue Yap_heap_regs->functor_nb_queue
#define FunctorNot Yap_heap_regs->functor_not
#define FunctorOr Yap_heap_regs->functor_or
#define FunctorPortray Yap_heap_regs->functor_portray
@ -842,6 +849,8 @@ struct various_codes *Yap_heap_regs;
#define OldHeapTop RINFO.old_HeapTop
#define ClDiff RINFO.cl_diff
#define GDiff RINFO.g_diff
#define GDiff0 RINFO.g_diff0
#define GSplit RINFO.g_split
#define HDiff RINFO.h_diff
#define LDiff RINFO.l_diff
#define TrDiff RINFO.tr_diff
@ -880,6 +889,9 @@ struct various_codes *Yap_heap_regs;
#define TrustLUCode Yap_heap_regs->WL.trust_lu_code
#define DynamicArrays Yap_heap_regs->WL.dynamic_arrays
#define StaticArrays Yap_heap_regs->WL.static_arrays
#define GlobalVariables Yap_heap_regs->WL.global_variables
#define GlobalArena Yap_heap_regs->WL.global_arena
#define GlobalDelayArena Yap_heap_regs->WL.global_delay_arena
#define profiling Yap_heap_regs->compiler_profiling
#define call_counting Yap_heap_regs->compiler_call_counting
#define compile_arrays Yap_heap_regs->compiler_compile_arrays

72
H/TermExt.h
View File

@ -10,7 +10,7 @@
* File: TermExt.h *
* mods: *
* comments: Extensions to standard terms for YAP *
* version: $Id: TermExt.h,v 1.9 2006-05-19 14:31:32 vsc Exp $ *
* version: $Id: TermExt.h,v 1.10 2006-08-22 16:12:46 vsc Exp $ *
*************************************************************************/
#ifdef USE_SYSTEM_MALLOC
@ -43,35 +43,18 @@
typedef enum
{
#if defined(IN_SECOND_QUADRANT) && !GC_NO_TAGS
db_ref_e = sizeof (Functor *) | RBIT,
long_int_e = 2 * sizeof (Functor *) | RBIT,
#ifdef USE_GMP
big_int_e = 3 * sizeof (Functor *) | RBIT,
double_e = 4 * sizeof (Functor *) | RBIT
#else
double_e = 3 * sizeof (Functor *) | RBIT
#endif
#else
db_ref_e = sizeof (Functor *),
long_int_e = 2 * sizeof (Functor *),
#ifdef USE_GMP
big_int_e = 3 * sizeof (Functor *),
double_e = 4 * sizeof (Functor *)
#else
double_e = 3 * sizeof (Functor *)
#endif
#endif
}
blob_type;
#define FunctorDBRef ((Functor)(db_ref_e))
#define FunctorLongInt ((Functor)(long_int_e))
#ifdef USE_GMP
#define FunctorBigInt ((Functor)(big_int_e))
#endif
#define FunctorDouble ((Functor)(double_e))
#define EndSpecials (double_e)
#define EndSpecials (double_e+sizeof(Functor *))
inline EXTERN blob_type BlobOfFunctor (Functor f);
@ -141,14 +124,7 @@ typedef struct special_functors_struct
special_functors;
#endif
#if USE_SYSTEM_MALLOC
#define MAX_SPECIALS_TAG (4*4096)
#else
#define MAX_SPECIALS_TAG ((CELL)AtomBase)
#endif
#if SIZEOF_DOUBLE == SIZEOF_LONG_INT
#if GC_NO_TAGS
inline EXTERN Term MkFloatTerm (Float);
@ -156,27 +132,11 @@ inline EXTERN Term
MkFloatTerm (Float dbl)
{
return (Term) ((H[0] = (CELL) FunctorDouble, *(Float *) (H + 1) =
dbl, H[2] = (2 * sizeof (CELL) + EndSpecials), H +=
dbl, H[2] = EndSpecials, H +=
3, AbsAppl (H - 3)));
}
#else
inline EXTERN Term MkFloatTerm (Float);
inline EXTERN Term
MkFloatTerm (Float dbl)
{
return (Term) ((H[0] = (CELL) FunctorDouble, *(Float *) (H + 1) =
dbl, H[2] = ((2 * sizeof (CELL) + EndSpecials) | MBIT), H +=
3, AbsAppl (H - 3)));
}
#endif
inline EXTERN Float FloatOfTerm (Term t);
inline EXTERN Float
@ -223,8 +183,6 @@ CpFloatUnaligned (CELL * ptr)
#endif
#if GC_NO_TAGS
inline EXTERN Term MkFloatTerm (Float);
inline EXTERN Term
@ -232,27 +190,11 @@ MkFloatTerm (Float dbl)
{
return (Term) ((AlignGlobalForDouble (), H[0] =
(CELL) FunctorDouble, *(Float *) (H + 1) = dbl, H[3] =
(3 * sizeof (CELL) + EndSpecials), H +=
EndSpecials, H +=
4, AbsAppl (H - 4)));
}
#else
inline EXTERN Term MkFloatTerm (Float);
inline EXTERN Term
MkFloatTerm (Float dbl)
{
return (Term) ((AlignGlobalForDouble (), H[0] =
(CELL) FunctorDouble, *(Float *) (H + 1) = dbl, H[3] =
((3 * sizeof (CELL) + EndSpecials) | MBIT), H +=
4, AbsAppl (H - 4)));
}
#endif
inline EXTERN Float FloatOfTerm (Term t);
@ -292,11 +234,7 @@ MkLongIntTerm (Int i)
{
H[0] = (CELL) FunctorLongInt;
H[1] = (CELL) (i);
#if GC_NO_TAGS
H[2] = 2 * sizeof (CELL) + EndSpecials;
#else
H[2] = ((2 * sizeof (CELL) + EndSpecials) | MBIT);
#endif
H[2] = EndSpecials;
H += 3;
return AbsAppl(H - 3);
}

7
H/Yapproto.h
View File

@ -10,7 +10,7 @@
* File: Yap.proto *
* mods: *
* comments: Function declarations for YAP *
* version: $Id: Yapproto.h,v 1.75 2006-08-02 18:18:30 vsc Exp $ *
* version: $Id: Yapproto.h,v 1.76 2006-08-22 16:12:46 vsc Exp $ *
*************************************************************************/
/* prototype file for Yap */
@ -165,9 +165,14 @@ void STD_PROTO(Yap_inform_profiler_of_clause,(struct yami *,struct yami *,struct
#define Yap_inform_profiler_of_clause(A,B,C,D)
#endif
/* globals.c */
Term STD_PROTO(Yap_NewArena,(UInt,CELL *));
void STD_PROTO(Yap_InitGlobals,(void));
/* grow.c */
Int STD_PROTO(Yap_total_stack_shift_time,(void));
void STD_PROTO(Yap_InitGrowPreds, (void));
int STD_PROTO(Yap_InsertInGlobal, (CELL *, UInt));
int STD_PROTO(Yap_growheap, (int, UInt, void *));
int STD_PROTO(Yap_growstack, (long));
int STD_PROTO(Yap_growtrail, (long, int));

72
H/Yatom.h
View File

@ -192,9 +192,81 @@ IsFunctorProperty (int flags)
ff fa module property
ff fb blackboard property
ff fc value property
ff fd global property
ff ff op property
*/
/* Global Variable property */
typedef struct global_entry
{
Prop NextOfPE; /* used to chain properties */
PropFlags KindOfPE; /* kind of property */
#if defined(YAPOR) || defined(THREADS)
rwlock_t GRWLock; /* a simple lock to protect this entry */
#if THREADS
unsigned int owner_id; /* owner thread */
#endif
#endif
struct AtomEntryStruct *AtomOfGE; /* parent atom for deletion */
struct global_entry *NextGE; /* linked list of global entries */
Term global; /* index in module table */
} GlobalEntry;
#if USE_OFFSETS_IN_PROPS
inline EXTERN GlobalEntry *RepGlobalProp (Prop p);
inline EXTERN GlobalEntry *
RepGlobalProp (Prop p)
{
return (GlobalEntry *) (AtomBase + Unsigned (p));
}
inline EXTERN Prop AbsGlobalProp (GlobalEntry * p);
inline EXTERN Prop
AbsGlobalProp (GlobalEntry * p)
{
return (Prop) (Addr (p) - AtomBase);
}
#else
inline EXTERN GlobalEntry *RepGlobalProp (Prop p);
inline EXTERN GlobalEntry *
RepGlobalProp (Prop p)
{
return (GlobalEntry *) (p);
}
inline EXTERN Prop AbsGlobalProp (GlobalEntry * p);
inline EXTERN Prop
AbsGlobalProp (GlobalEntry * p)
{
return (Prop) (p);
}
#endif
#define GlobalProperty ((PropFlags)0xfffd)
inline EXTERN PropFlags IsGlobalProperty (int);
inline EXTERN PropFlags
IsGlobalProperty (int flags)
{
return (PropFlags) ((flags == GlobalProperty));
}
/* Module property */
typedef struct
{

1
H/amiops.h
View File

@ -314,6 +314,7 @@ Binding Macros for Multiple Assignment Variables.
#define Bind(A,D) TRAIL(A,D); *(A) = (D)
#define Bind_Global(A,D) TRAIL_GLOBAL(A,D); *(A) = (D)
#define Bind_and_Trail(A,D) DO_TRAIL(A,D); *(A) = (D)
#define BIND(A,D,L) *(A) = (D); Trail(A,D,L)
#define BIND_GLOBAL(A,D,L) *(A) = (D); Trail_Global(A,D,L)

4
H/attvar.h
View File

@ -54,12 +54,12 @@ typedef struct attvar_struct {
static inline attvar_record *
DelayTop(void) {
return (attvar_record *)((attvar_record *)Yap_GlobalBase+IntegerOfTerm(Yap_ReadTimedVar(DelayedVars)));
return (attvar_record *)Yap_ReadTimedVar(DelayedVars);
}
static inline void
SetDelayTop(attvar_record *new_top) {
Yap_UpdateTimedVar(DelayedVars, MkIntegerTerm((CELL)(new_top-(attvar_record *)Yap_GlobalBase)));
Yap_UpdateTimedVar(DelayedVars, (CELL)new_top);
}
#endif

27
H/rheap.h
View File

@ -11,8 +11,11 @@
* File: rheap.h *
* comments: walk through heap code *
* *
* Last rev: $Date: 2006-08-02 18:18:30 $,$Author: vsc $ *
* Last rev: $Date: 2006-08-22 16:12:46 $,$Author: vsc $ *
* $Log: not supported by cvs2svn $
* Revision 1.68 2006/08/02 18:18:30 vsc
* preliminary support for readutil library (SWI compatible).
*
* Revision 1.67 2006/05/17 18:38:11 vsc
* make system library use true file name
*
@ -643,6 +646,7 @@ restore_codes(void)
#ifdef MULTI_ASSIGNMENT_VARIABLES
Yap_heap_regs->functor_mutable = FuncAdjust(Yap_heap_regs->functor_mutable);
#endif
Yap_heap_regs->functor_nb_queue = FuncAdjust(Yap_heap_regs->functor_nb_queue);
Yap_heap_regs->functor_not = FuncAdjust(Yap_heap_regs->functor_not);
Yap_heap_regs->functor_or = FuncAdjust(Yap_heap_regs->functor_or);
Yap_heap_regs->functor_portray = FuncAdjust(Yap_heap_regs->functor_portray);
@ -738,6 +742,23 @@ restore_codes(void)
Yap_heap_regs->wl.static_arrays =
PtoArraySAdjust(Yap_heap_regs->wl.static_arrays);
}
if (Yap_heap_regs->wl.global_variables) {
Yap_heap_regs->wl.global_variables =
PtoGlobalEAdjust(Yap_heap_regs->wl.global_variables);
}
if (Yap_heap_regs->wl.global_arena) {
if (IsAtomTerm(Yap_heap_regs->wl.global_arena)) {
Yap_heap_regs->wl.global_arena =
AtomTermAdjust(Yap_heap_regs->wl.global_arena);
} else {
Yap_heap_regs->wl.global_arena =
AbsAppl(PtoGloAdjust(RepAppl(Yap_heap_regs->wl.global_arena)));
}
}
if (Yap_heap_regs->wl.global_delay_arena) {
Yap_heap_regs->wl.global_delay_arena =
GlobalAdjust(Yap_heap_regs->wl.global_delay_arena);
}
#endif
#endif
if (Yap_heap_regs->last_wtime != NULL)
@ -896,8 +917,6 @@ restore_static_array(StaticArrayEntry *ae)
*base++ = (AtomEntry *)LocalAddrAdjust((ADDR)reg);
} else if (IsOldGlobal((CELL)reg)) {
*base++ = (AtomEntry *)GlobalAddrAdjust((ADDR)reg);
} else if (IsOldDelay((CELL)reg)) {
*base++ = (AtomEntry *)DelayAddrAdjust((ADDR)reg);
} else if (IsOldTrail((CELL)reg)) {
*base++ = (AtomEntry *)TrailAddrAdjust((ADDR)reg);
} else {
@ -1155,8 +1174,6 @@ RestoreEntries(PropEntry *pp)
ae->ValueOfVE = AbsAppl(PtoHeapCellAdjust(ptr));
} else if (IsOldLocalInTRPtr(ptr)) {
ae->ValueOfVE = AbsAppl(PtoLocAdjust(ptr));
} else if (IsOldDelayPtr(ptr)) {
ae->ValueOfVE = AbsAppl(PtoDelayAdjust(ptr));
} else if (IsOldTrailPtr(ptr)) {
ae->ValueOfVE = AbsAppl(CellPtoTRAdjust(ptr));
}

51
H/sshift.h
View File

@ -43,7 +43,11 @@ inline EXTERN CELL *PtoGloAdjust (CELL *);
inline EXTERN CELL *
PtoGloAdjust (CELL * ptr)
{
return (CELL *) (((CELL *) (CharP (ptr) + GDiff)));
if (ptr < GSplit) {
return (CELL *) (((CELL *) (CharP (ptr) + GDiff0)));
} else {
return (CELL *) (((CELL *) (CharP (ptr) + GDiff)));
}
}
@ -126,7 +130,11 @@ inline EXTERN CELL GlobalAdjust (CELL);
inline EXTERN CELL
GlobalAdjust (CELL val)
{
return (CELL) ((val + GDiff));
if ((CELL *)val < GSplit) {
return (CELL) ((val + GDiff0));
} else {
return (CELL) ((val + GDiff));
}
}
@ -146,7 +154,11 @@ inline EXTERN ADDR GlobalAddrAdjust (ADDR);
inline EXTERN ADDR
GlobalAddrAdjust (ADDR ptr)
{
return (ADDR) ((ptr + GDiff));
if ((CELL *)ptr < GSplit) {
return (ADDR) ((ptr + GDiff0));
} else {
return (ADDR) ((ptr + GDiff));
}
}
@ -481,6 +493,15 @@ PtoArrayEAdjust (ArrayEntry * ptr)
}
inline EXTERN GlobalEntry *PtoGlobalEAdjust (GlobalEntry *);
inline EXTERN GlobalEntry *
PtoGlobalEAdjust (GlobalEntry * ptr)
{
return (GlobalEntry *) (((GlobalEntry *) (CharP (ptr) + HDiff)));
}
inline EXTERN StaticArrayEntry *PtoArraySAdjust (StaticArrayEntry *);
inline EXTERN StaticArrayEntry *
@ -608,7 +629,7 @@ inline EXTERN int IsOldGlobal (CELL);
inline EXTERN int
IsOldGlobal (CELL reg)
{
return (int) (IN_BETWEEN (OldH0, reg, OldH));
return (int) (IN_BETWEEN (OldGlobalBase, reg, OldH));
}
@ -618,27 +639,7 @@ inline EXTERN int IsOldGlobalPtr (CELL *);
inline EXTERN int
IsOldGlobalPtr (CELL * ptr)
{
return (int) (IN_BETWEEN (OldH0, ptr, OldH));
}
inline EXTERN int IsOldDelay (CELL);
inline EXTERN int
IsOldDelay (CELL reg)
{
return (int) (IN_BETWEEN (OldGlobalBase, reg, OldH0));
}
inline EXTERN int IsOldDelayPtr (CELL *);
inline EXTERN int
IsOldDelayPtr (CELL * ptr)
{
return (int) (IN_BETWEEN (OldGlobalBase, ptr, OldH0));
return (int) (IN_BETWEEN (OldGlobalBase, ptr, OldH));
}

11
Makefile.in
View File

@ -142,7 +142,7 @@ C_SOURCES= \
$(srcdir)/C/corout.c $(srcdir)/C/dbase.c $(srcdir)/C/dlmalloc.c \
$(srcdir)/C/errors.c \
$(srcdir)/C/eval.c $(srcdir)/C/exec.c \
$(srcdir)/C/gprof.c $(srcdir)/C/grow.c \
$(srcdir)/C/globals.c $(srcdir)/C/gprof.c $(srcdir)/C/grow.c \
$(srcdir)/C/heapgc.c $(srcdir)/C/index.c \
$(srcdir)/C/init.c $(srcdir)/C/inlines.c \
$(srcdir)/C/iopreds.c $(srcdir)/C/depth_bound.c \
@ -210,7 +210,7 @@ ENGINE_OBJECTS = \
bignum.o bb.o \
cdmgr.o cmppreds.o compiler.o computils.o \
corout.o cut_c.o dbase.o dlmalloc.o errors.o eval.o \
exec.o gprof.o grow.o \
exec.o globals.o gprof.o grow.o \
heapgc.o index.o init.o inlines.o \
iopreds.o depth_bound.o mavar.o \
myddas_mysql.o myddas_odbc.o myddas_shared.o myddas_initialization.o \
@ -322,12 +322,15 @@ eval.o: $(srcdir)/C/eval.c
exec.o: $(srcdir)/C/exec.c
$(CC) -c $(CFLAGS) $(srcdir)/C/exec.c -o $@
grow.o: $(srcdir)/C/grow.c
$(CC) -c $(CFLAGS) $(srcdir)/C/grow.c -o $@
globals.o: $(srcdir)/C/globals.c
$(CC) -c $(CFLAGS) $(srcdir)/C/globals.c -o $@
gprof.o: $(srcdir)/C/gprof.c
$(CC) -c $(CFLAGS) $(srcdir)/C/gprof.c -o $@
grow.o: $(srcdir)/C/grow.c
$(CC) -c $(CFLAGS) $(srcdir)/C/grow.c -o $@
heapgc.o: $(srcdir)/C/heapgc.c
$(CC) -c $(CFLAGS) $(srcdir)/C/heapgc.c -o $@

2
changes-5.1.html
View File

@ -16,6 +16,8 @@
<h2>Yap-5.1.2:</h2>
<ul>
<li> NEW: global variables a la hProlog, includes major changes in
stack shifter, garbage collector, and setof.</li>
<li> FIXED: do not call garbage collector if the space we need is more
than what is available (obs from Nicos Angelopoulos).</li>
<li> FIXED: recordaifnot(a,_,_) was broken (obs from Jesse Davis).</li>

1
configure.in
View File

@ -718,6 +718,7 @@ dnl Linux has both elf and a.out, in this case we found elf
LIBS="$LIBS -ldl"
fi
fi
LIBS="$LIBS -framework JavaVM"
SHLIB_CFLAGS="-fno-common"
SHLIB_SUFFIX=".dylib"
DO_SECOND_LD=""

68
library/dbqueues.yap
View File

@ -1,48 +1,52 @@
% A library to implement queues of DB Terms
% A library to implement queues of NB Terms
:- module(dbqueue, [
db_enqueue/2,
db_dequeue/2,
db_clean_queue/1
:- module(nbqueue, [
nb_enqueue/2,
nb_dequeue/2,
nb_clean_queue/1
nb_size/2
]).
:- unhide('$init_db_queue').
:- unhide('$db_enqueue').
:- unhide('$db_dequeue').
:- unhide('$init_nb_queue').
:- unhide('$nb_enqueue').
:- unhide('$nb_dequeue').
db_enqueue(Name,El) :- var(Name),
throw(error(instantiation_error(Name),db_enqueue(Name,El))).
db_enqueue(Name,El) :- \+ atom(Name), !,
throw(error(type_error_atom(Name),db_enqueue(Name,El))).
db_enqueue(Name,El) :-
recorded('$db_queue',[Name|Ref],_), !,
prolog:'$db_enqueue'(Ref, El).
db_enqueue(Name,El) :-
prolog:'$init_db_queue'(Ref),
recorda('$db_queue',[Name|Ref],_),
prolog:'$db_enqueue'(Ref,El).
nb_enqueue(Name,El) :- var(Name),
throw(error(instantiation_error(Name),nb_enqueue(Name,El))).
nb_enqueue(Name,El) :- \+ atom(Name), !,
throw(error(type_error_atom(Name),nb_enqueue(Name,El))).
nb_enqueue(Name,El) :-
recorded('$nb_queue',[Name|Ref],_), !,
prolog:'$nb_enqueue'(Ref, El).
nb_enqueue(Name,El) :-
prolog:'$init_nb_queue'(Ref),
recorda('$nb_queue',[Name|Ref],_),
prolog:'$nb_enqueue'(Ref,El).
db_dequeue(Name,El) :- var(Name),
throw(error(instantiation_error(Name),db_dequeue(Name,El))).
db_dequeue(Name,El) :- \+ atom(Name), !,
throw(error(type_error_atom(Name),db_dequeue(Name,El))).
db_dequeue(Name,El) :-
recorded('$db_queue',[Name|Ref],R),
( prolog:'$db_dequeue'(Ref, El) ->
nb_dequeue(Name,El) :- var(Name),
throw(error(instantiation_error(Name),nb_dequeue(Name,El))).
nb_dequeue(Name,El) :- \+ atom(Name), !,
throw(error(type_error_atom(Name),nb_dequeue(Name,El))).
nb_dequeue(Name,El) :-
recorded('$nb_queue',[Name|Ref],R),
( prolog:'$nb_dequeue'(Ref, El) ->
true
;
erase(R),
fail
).
db_clean_queue(Name) :-
recorded('$db_queue',[Name|Ref],R), !,
nb_clean_queue(Name) :-
recorded('$nb_queue',[Name|Ref],R), !,
erase(R),
db_dequeue_all(Ref).
db_clean_queue(_).
nb_dequeue_all(Ref).
nb_clean_queue(_).
db_dequeue_all(Ref) :-
( prolog:'$db_dequeue'(Ref, _) -> db_dequeue_all(Ref) ; true ).
nb_dequeue_all(Ref) :-
( prolog:'$nb_dequeue'(Ref, _) -> nb_dequeue_all(Ref) ; true ).
nb_dequeue_size(Ref, Size) :-
prolog:'$nb_size'(Ref, Size).

17
library/swi.yap
View File

@ -116,23 +116,6 @@ prolog:between(I0,I,J) :- I0 < I,
I1 is I0+1,
prolog:between(I1,I,J).
prolog:b_getval(GlobalVariable,Value) :-
array_element(GlobalVariable,0,Value).
prolog:b_setval(GlobalVariable,Value) :-
array(GlobalVariable,1),
dynamic_update_array(GlobalVariable,0,Value).
prolog:nb_getval(GlobalVariable,Value) :-
array_element(GlobalVariable,0,Value).
prolog:nb_setval(GlobalVariable,Value) :-
static_array(GlobalVariable,1,nb_term),
update_array(GlobalVariable,0,Value).
prolog:nb_delete(GlobalVariable) :-
close_static_array(GlobalVariable).
prolog:nb_current(GlobalVariable,Val) :-
static_array_properties(GlobalVariable,1,nb_term),
array_element(GlobalVariable,0,Val).

1
pl/boot.yap
View File

@ -46,6 +46,7 @@ true :- true.
true
),
'$set_yap_flags'(10,0),
'$allocate_default_arena'(1024, 64),
set_value(fileerrors,1),
set_value('$gc',on),
set_value('$lf_verbose',informational),

50
pl/setof.yap
View File

@ -33,67 +33,43 @@ _^Goal :-
findall(Template, Generator, Answers) :-
'$check_list_for_bags'(Answers, findall(Template, Generator, Answers)),
'$init_db_queue'(Ref),
nb_queue(Ref),
'$findall'(Template, Generator, Ref, [], Answers).
% If some answers have already been found
findall(Template, Generator, Answers, SoFar) :-
'$init_db_queue'(Ref),
nb_queue(Ref),
'$findall'(Template, Generator, Ref, SoFar, Answers).
% starts by calling the generator,
% and recording the answers
'$findall'(Template, Generator, Ref, _, _) :-
'$catch'(Error,'$clean_findall'(Ref,Error),_),
'$execute'(Generator),
'$db_enqueue'(Ref, Template),
nb_queue_enqueue(Ref, Template),
fail.
% now wraps it all
'$findall'(_, _, Ref, SoFar, Answers) :-
'$catch'(Error,'$clean_findall'(Ref,Error),_),
'$collect_for_findall'(Ref, SoFar, Answers), !.
nb_queue_close(Ref, Answers, SoFar).
% error handling: be careful to recover all the space we used up
% in implementing findall.
%
'$clean_findall'(Ref,Ball) :-
'$db_dequeue'(Ref,_), !,
'$clean_findall'(Ref,Ball).
'$clean_findall'(_,Ball) :-
% get this off the unwound computation.
copy_term(Ball,NewBall),
% get current jump point
'$jump_env_and_store_ball'(NewBall).
% by getting all answers
'$collect_for_findall'(Ref, SoFar, Out) :-
'$db_dequeue'(Ref, Term), !,
Out = [Term|Answers],
'$collect_for_findall'(Ref, SoFar, Answers).
'$collect_for_findall'(_, SoFar, SoFar).
% findall_with_key is very similar to findall, but uses the SICStus
% algorithm to guarantee that variables will have the same names.
%
'$findall_with_common_vars'(Template, Generator, Ref, _) :-
'$execute'(Generator),
'$db_enqueue'(Ref, Template),
nb_queue_enqueue(Ref, Template),
fail.
% now wraps it all
'$findall_with_common_vars'(_, _, Ref, Answers) :-
'$collect_with_common_vars'(Ref, _, [], Answers).
nb_queue_close(Ref, Answers, []),
'$collect_with_common_vars'(Answers, _).
% by getting all answers
'$collect_with_common_vars'(Ref, VarList, SoFar, Solution) :-
'$db_dequeue'(Ref, BDEntry), !,
BDEntry = Key-_,
Solution = [BDEntry|Answers],
'$collect_with_common_vars'([], _).
'$collect_with_common_vars'([Key-_|Answers], VarList) :-
'$variables_in_term'(Key, _, VarList),
'$collect_with_common_vars'(Ref, VarList, SoFar, Answers).
'$collect_with_common_vars'(_, _, Solution, Solution).
'$collect_with_common_vars'(Answers, VarList).
% This is the setof predicate
setof(Template, Generator, Set) :-
@ -117,12 +93,12 @@ bagof(Template, Generator, Bag) :-
( FreeVars \== [] ->
'$variables_in_term'(FreeVars, [], LFreeVars),
Key =.. ['$'|LFreeVars],
'$init_db_queue'(Ref),
nb_queue(Ref),
'$findall_with_common_vars'(Key-Template, StrippedGenerator, Ref, Bags0),
'$keysort'(Bags0, Bags),
'$pick'(Bags, Key, Bag)
;
'$init_db_queue'(Ref),
nb_queue(Ref),
'$findall'(Template, StrippedGenerator, Ref, [], Bag0),
Bag0 \== [],
Bag = Bag0