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

garbage collection fixes

Browse Source 
git-svn-id: https://yap.svn.sf.net/svnroot/yap/trunk@1139 b08c6af1-5177-4d33-ba66-4b1c6b8b522a
This commit is contained in:
vsc
2004-09-16 17:29:08 +00:00
parent 921e576877
commit 3d308525e0
7 changed files with 461 additions and 94 deletions
Download Patch File Download Diff File Expand all files Collapse all files

4
C/bignum.c
View File

@@ -186,7 +186,11 @@ Yap_MkBigIntTerm(MP_INT *big)
ret[0] = (CELL)FunctorBigInt;
memmove((void *)new, (const void *)(big->_mp_d), nlimbs*CellSize);
H = (CELL *)(new+nlimbs);
#if GC_NO_TAGS
H[0] = (H-ret)*sizeof(CELL)+EndSpecials;
#else
H[0] = ((H-ret)*sizeof(CELL)+EndSpecials)|MBIT;
#endif
H++;
pre_alloc_base = NULL;
return(AbsAppl(ret));

22
C/dbase.c
View File

@@ -585,7 +585,11 @@ 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
/* now reserve space */
return st+3;
}
@@ -598,9 +602,17 @@ copy_double(CELL *st, CELL *pt)
st[1] = pt[1];
#if SIZEOF_DOUBLE == 2*SIZEOF_LONG_INT
st[2] = pt[2];
st[3] = ((3*sizeof(CELL)+EndSpecials)|MBIT);
#if GC_NO_TAGS
st[3] = 3*sizeof(CELL)+EndSpecials;
#else
st[3] = ((3*sizeof(CELL)+EndSpecials)|MBIT);
#endif /* GC_NO_TAGS */
#else
#if GC_NO_TAGS
st[2] = ((2*sizeof(CELL)+EndSpecials)|MBIT);
#else
st[2] = 2*sizeof(CELL)+EndSpecials;
#endif /* GC_NO_TAGS */
#endif
/* now reserve space */
return st+(2+SIZEOF_DOUBLE/SIZEOF_LONG_INT);
@@ -620,7 +632,11 @@ 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
return st+1;
}
#endif /* BIG_INT */
@@ -2483,14 +2499,14 @@ GetDBTerm(DBTerm *DBSP)
return t;
}
pt = CellPtr(DBSP->Contents);
if (H+NOf > ASP-CalculateStackGap()) {
if (H+NOf > ASP-CalculateStackGap()/sizeof(CELL)) {
if (Yap_PrologMode & InErrorMode) {
if (H+NOf > ASP)
fprintf(Yap_stderr, "\n\n [ FATAL ERROR: No Stack for Error Handling ]\n");
Yap_exit( 1);
} else {
Yap_Error_Size = NOf*sizeof(CELL);
return((Term)0);
return (Term)0;
}
}
HeapPtr = cpcells(HOld, pt, NOf);

438
C/heapgc.c
View File

@@ -83,6 +83,10 @@ STATIC_PROTO(int is_gc_very_verbose, (void));
#include "heapgc.h"
#if GC_NO_TAGS
char *bp;
#endif
static int discard_trail_entries = 0;
/* support for hybrid garbage collection scheme */
@@ -449,7 +453,7 @@ count_cells_marked(void)
int found_marked = 0;
for (current = H - 1; current >= H0; current--) {
if (MARKED(*current)) {
if (MARKED_PTR(current)) {
found_marked++;
}
}
@@ -477,85 +481,333 @@ typedef struct db_entry {
struct db_entry *right;
} *dbentry;
static dbentry db_vec, db_vec0;
static ADDR db_vec, db_vec0;
typedef struct RB_red_blk_node {
CODEADDR key;
CODEADDR lim;
db_entry_type db_type;
int red; /* if red=0 then the node is black */
struct RB_red_blk_node* left;
struct RB_red_blk_node* right;
struct RB_red_blk_node* parent;
} rb_red_blk_node;
static rb_red_blk_node *db_root, *db_nil;
static rb_red_blk_node *
RBMalloc(UInt size)
{
ADDR new = db_vec;
db_vec += size;
if ((ADDR)db_vec > Yap_TrailTop-1024) {
Yap_growtrail(64 * 1024L);
#if USE_SYSTEM_MALLOC
jump;
#endif
}
return (rb_red_blk_node *)new;
}
static rb_red_blk_node *
RBTreeCreate(void) {
rb_red_blk_node* temp;
/* see the comment in the rb_red_blk_tree structure in red_black_tree.h */
/* for information on nil and root */
temp=db_nil= RBMalloc(sizeof(rb_red_blk_node));
temp->parent=temp->left=temp->right=temp;
temp->red=0;
temp->key=NULL;
temp = RBMalloc(sizeof(rb_red_blk_node));
temp->parent=temp->left=temp->right=db_nil;
temp->key=NULL;
temp->red=0;
return temp;
}
/***********************************************************************/
/* FUNCTION: LeftRotate */
/**/
/* INPUTS: This takes a tree so that it can access the appropriate */
/* root and nil pointers, and the node to rotate on. */
/**/
/* OUTPUT: None */
/**/
/* Modifies Input: tree, x */
/**/
/* EFFECTS: Rotates as described in _Introduction_To_Algorithms by */
/* Cormen, Leiserson, Rivest (Chapter 14). Basically this */
/* makes the parent of x be to the left of x, x the parent of */
/* its parent before the rotation and fixes other pointers */
/* accordingly. */
/***********************************************************************/
static void
LeftRotate(rb_red_blk_node* x) {
rb_red_blk_node* y;
rb_red_blk_node* nil=db_nil;
/* I originally wrote this function to use the sentinel for */
/* nil to avoid checking for nil. However this introduces a */
/* very subtle bug because sometimes this function modifies */
/* the parent pointer of nil. This can be a problem if a */
/* function which calls LeftRotate also uses the nil sentinel */
/* and expects the nil sentinel's parent pointer to be unchanged */
/* after calling this function. For example, when RBDeleteFixUP */
/* calls LeftRotate it expects the parent pointer of nil to be */
/* unchanged. */
y=x->right;
x->right=y->left;
if (y->left != nil) y->left->parent=x; /* used to use sentinel here */
/* and do an unconditional assignment instead of testing for nil */
y->parent=x->parent;
/* instead of checking if x->parent is the root as in the book, we */
/* count on the root sentinel to implicitly take care of this case */
if( x == x->parent->left) {
x->parent->left=y;
} else {
x->parent->right=y;
}
y->left=x;
x->parent=y;
#ifdef DEBUG_ASSERT
Assert(!db_nil->red,"nil not red in LeftRotate");
#endif
}
/***********************************************************************/
/* FUNCTION: RighttRotate */
/**/
/* INPUTS: This takes a tree so that it can access the appropriate */
/* root and nil pointers, and the node to rotate on. */
/**/
/* OUTPUT: None */
/**/
/* Modifies Input?: tree, y */
/**/
/* EFFECTS: Rotates as described in _Introduction_To_Algorithms by */
/* Cormen, Leiserson, Rivest (Chapter 14). Basically this */
/* makes the parent of x be to the left of x, x the parent of */
/* its parent before the rotation and fixes other pointers */
/* accordingly. */
/***********************************************************************/
static void
RightRotate(rb_red_blk_node* y) {
rb_red_blk_node* x;
rb_red_blk_node* nil=db_nil;
/* I originally wrote this function to use the sentinel for */
/* nil to avoid checking for nil. However this introduces a */
/* very subtle bug because sometimes this function modifies */
/* the parent pointer of nil. This can be a problem if a */
/* function which calls LeftRotate also uses the nil sentinel */
/* and expects the nil sentinel's parent pointer to be unchanged */
/* after calling this function. For example, when RBDeleteFixUP */
/* calls LeftRotate it expects the parent pointer of nil to be */
/* unchanged. */
x=y->left;
y->left=x->right;
if (nil != x->right) x->right->parent=y; /*used to use sentinel here */
/* and do an unconditional assignment instead of testing for nil */
/* instead of checking if x->parent is the root as in the book, we */
/* count on the root sentinel to implicitly take care of this case */
x->parent=y->parent;
if( y == y->parent->left) {
y->parent->left=x;
} else {
y->parent->right=x;
}
x->right=y;
y->parent=x;
#ifdef DEBUG_ASSERT
Assert(!db_nil->red,"nil not red in RightRotate");
#endif
}
/***********************************************************************/
/* FUNCTION: TreeInsertHelp */
/**/
/* INPUTS: tree is the tree to insert into and z is the node to insert */
/**/
/* OUTPUT: none */
/**/
/* Modifies Input: tree, z */
/**/
/* EFFECTS: Inserts z into the tree as if it were a regular binary tree */
/* using the algorithm described in _Introduction_To_Algorithms_ */
/* by Cormen et al. This funciton is only intended to be called */
/* by the RBTreeInsert function and not by the user */
/***********************************************************************/
static void
TreeInsertHelp(rb_red_blk_node* z) {
/* This function should only be called by InsertRBTree (see above) */
rb_red_blk_node* x;
rb_red_blk_node* y;
rb_red_blk_node* nil=db_nil;
z->left=z->right=nil;
y=db_root;
x=db_root->left;
while( x != nil) {
y=x;
if (x->key > z->key) { /* x.key > z.key */
x=x->left;
} else { /* x,key <= z.key */
x=x->right;
}
}
z->parent=y;
if ( (y == db_root) ||
(y->key > z->key)) { /* y.key > z.key */
y->left=z;
} else {
y->right=z;
}
#ifdef DEBUG_ASSERT
Assert(!db_nil->red,"nil not red in TreeInsertHelp");
#endif
}
/* Before calling Insert RBTree the node x should have its key set */
/***********************************************************************/
/* FUNCTION: RBTreeInsert */
/**/
/* INPUTS: tree is the red-black tree to insert a node which has a key */
/* pointed to by key and info pointed to by info. */
/**/
/* OUTPUT: This function returns a pointer to the newly inserted node */
/* which is guarunteed to be valid until this node is deleted. */
/* What this means is if another data structure stores this */
/* pointer then the tree does not need to be searched when this */
/* is to be deleted. */
/**/
/* Modifies Input: tree */
/**/
/* EFFECTS: Creates a node node which contains the appropriate key and */
/* info pointers and inserts it into the tree. */
/***********************************************************************/
static rb_red_blk_node *
RBTreeInsert(CODEADDR key, CODEADDR end, db_entry_type db_type) {
rb_red_blk_node * y;
rb_red_blk_node * x;
rb_red_blk_node * newNode;
x=(rb_red_blk_node*) RBMalloc(sizeof(rb_red_blk_node));
x->key=key;
x->lim=end;
x->db_type=db_type;
TreeInsertHelp(x);
newNode=x;
x->red=1;
while(x->parent->red) { /* use sentinel instead of checking for root */
if (x->parent == x->parent->parent->left) {
y=x->parent->parent->right;
if (y->red) {
x->parent->red=0;
y->red=0;
x->parent->parent->red=1;
x=x->parent->parent;
} else {
if (x == x->parent->right) {
x=x->parent;
LeftRotate(x);
}
x->parent->red=0;
x->parent->parent->red=1;
RightRotate(x->parent->parent);
}
} else { /* case for x->parent == x->parent->parent->right */
y=x->parent->parent->left;
if (y->red) {
x->parent->red=0;
y->red=0;
x->parent->parent->red=1;
x=x->parent->parent;
} else {
if (x == x->parent->left) {
x=x->parent;
RightRotate(x);
}
x->parent->red=0;
x->parent->parent->red=1;
LeftRotate(x->parent->parent);
}
}
}
db_root->left->red=0;
return newNode;
#ifdef DEBUG_ASSERT
Assert(!db_nil->red,"nil not red in RBTreeInsert");
Assert(!db_root->red,"root not red in RBTreeInsert");
#endif
}
/* init the table */
static void
store_in_dbtable(CODEADDR entry, CODEADDR end, db_entry_type db_type)
{
dbentry parent = db_vec0;
dbentry new = db_vec;
if ((ADDR)new > Yap_TrailTop-1024)
Yap_growtrail(64 * 1024L);
new->val = entry;
new->db_type = db_type;
new->lim = end;
new->left = new->right = NULL;
if (db_vec == db_vec0) {
db_vec++;
return;
}
db_vec++;
parent = db_vec0;
beg:
if (entry < parent->val) {
if (parent->right == NULL) {
parent->right = new;
} else {
parent = parent->right;
goto beg;
}
} else {
if (parent->left == NULL) {
parent->left = new;
} else {
parent = parent->left;
goto beg;
}
}
RBTreeInsert(entry, end, db_type);
}
/* find an element in the dbentries table */
static dbentry
static rb_red_blk_node *
find_ref_in_dbtable(CODEADDR entry)
{
dbentry current = db_vec0;
rb_red_blk_node *current = db_root->left;
while (current != NULL) {
if (current->val < entry && current->lim > entry) {
return(current);
while (current != db_nil) {
if (current->key < entry && current->lim > entry) {
return current;
}
if (entry < current->val)
if (entry < current->key)
current = current->right;
else
current = current->left;
}
return(NULL);
return current;
}
static void
mark_db_fixed(CELL *ptr) {
dbentry el;
rb_red_blk_node *el;
el = find_ref_in_dbtable((CODEADDR)ptr);
if (el != NULL) {
if (el != db_nil) {
switch (el->db_type) {
case db_entry:
((DBRef)(el->val))->Flags |= GcFoundMask;
((DBRef)(el->key))->Flags |= GcFoundMask;
break;
case cl_entry:
((DynamicClause *)(el->val))->ClFlags |= GcFoundMask;
((DynamicClause *)(el->key))->ClFlags |= GcFoundMask;
break;
case lcl_entry:
((LogUpdClause *)(el->val))->ClFlags |= GcFoundMask;
((LogUpdClause *)(el->key))->ClFlags |= GcFoundMask;
break;
case li_entry:
((LogUpdIndex *)(el->val))->ClFlags |= GcFoundMask;
((LogUpdIndex *)(el->key))->ClFlags |= GcFoundMask;
break;
case dcl_entry:
((DeadClause *)(el->val))->ClFlags |= GcFoundMask;
((DeadClause *)(el->key))->ClFlags |= GcFoundMask;
break;
}
}
@@ -565,7 +817,8 @@ static void
init_dbtable(tr_fr_ptr trail_ptr) {
DeadClause *cl = DeadClauses;
db_vec0 = db_vec = (dbentry)TR;
db_vec0 = db_vec = (CODEADDR)TR;
db_root = RBTreeCreate();
while (trail_ptr > (tr_fr_ptr)Yap_TrailBase) {
register CELL trail_cell;
@@ -745,7 +998,7 @@ check_global(void) {
for (current = H - 1; current >= H0; current--) {
CELL ccurr = *current;
if (MARKED(ccurr)) {
if (MARKED_PTR(current)) {
CELL ccell = UNMARK_CELL(ccurr);
if (ccell < (CELL)AtomBase && ccell > EndSpecials && IsVarTerm(ccell)) {
/* oops, we found a blob */
@@ -755,7 +1008,7 @@ check_global(void) {
ccurr = *current;
/* process the functor next */
}
if (MARKED(ccurr)) {
if (MARKED_PTR(current)) {
printf("Oops, found marked cell at %p\n", current);
break;
}
@@ -814,7 +1067,7 @@ mark_variable(CELL_PTR current)
begin:
ccur = *current;
if (MARKED(ccur)) {
if (MARKED_PTR(current)) {
POP_CONTINUATION();
}
MARK(current);
@@ -827,7 +1080,8 @@ mark_variable(CELL_PTR current)
#ifdef EASY_SHUNTING
CELL cnext;
/* do variable shunting between variables in the global */
if (!MARKED((cnext = *next))) {
cnext = *next;
if (!MARKED_PTR(next)) {
if (IsVarTerm(cnext) && (CELL)next == cnext) {
/* new global variable to new global variable */
if (current < prev_HB && current >= HB && next >= HB && next < prev_HB) {
@@ -925,7 +1179,7 @@ mark_variable(CELL_PTR current)
}
POP_CONTINUATION();
}
if ( MARKED(cnext) || !ONHEAP(next) )
if ( MARKED_PTR(next) || !ONHEAP(next) )
POP_CONTINUATION();
if (next < H0) POP_CONTINUATION();
@@ -1138,7 +1392,7 @@ mark_environments(CELL_PTR gc_ENV, OPREG size, CELL *pvbmap)
currv = 0;
}
/* we may have already been here */
if (bmap < 0 && !MARKED(*saved_var)) {
if (bmap < 0 && !MARKED_PTR(saved_var)) {
#ifdef INSTRUMENT_GC
Term ccur = *saved_var;
@@ -1176,7 +1430,7 @@ mark_environments(CELL_PTR gc_ENV, OPREG size, CELL *pvbmap)
We do it at the end because we don't want to lose any variables
that would have been trimmed at the first environment visit.
*/
if (MARKED(gc_ENV[E_CB]))
if (MARKED_PTR(gc_ENV+E_CB))
return;
MARK(gc_ENV+E_CB);
@@ -1233,7 +1487,7 @@ mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B
than its new binding is not accessible and we can reset it. Note
we must use gc_H to avoid trouble with dangling variables
in the heap */
if (((hp < gc_H && hp >= H0) || (hp > (CELL *)gc_B && hp < LCL0) ) && !MARKED(*hp)) {
if (((hp < gc_H && hp >= H0) || (hp > (CELL *)gc_B && hp < LCL0) ) && !MARKED_PTR(hp)) {
#ifdef EARLY_RESET
/* reset to be a variable */
RESET_VARIABLE(hp);
@@ -1810,7 +2064,7 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
/* first, whatever we dumped on the trail. Easier just to do
the registers separately? */
for (trail_ptr = old_TR; trail_ptr < TR; trail_ptr++) {
if (MARKED(TrailTerm(trail_ptr))) {
if (MARKED_PTR(&TrailTerm(trail_ptr))) {
UNMARK(&TrailTerm(trail_ptr));
if (HEAP_PTR(TrailTerm(trail_ptr))) {
into_relocation_chain(&TrailTerm(trail_ptr), GET_NEXT(TrailTerm(trail_ptr)));
@@ -1838,14 +2092,14 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
TrailTerm(dest) = trail_cell;
if (IsVarTerm(trail_cell)) {
/* we need to check whether this is a honest to god trail entry */
if ((CELL *)trail_cell < H && MARKED(*(CELL *)trail_cell) && (CELL *)trail_cell >= H0) {
if ((CELL *)trail_cell < H && MARKED_PTR((CELL *)trail_cell) && (CELL *)trail_cell >= H0) {
if (HEAP_PTR(trail_cell)) {
into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell));
}
#ifdef FROZEN_STACKS
/* it is complex to recover cells with frozen segments */
TrailVal(dest) = TrailVal(trail_ptr);
if (MARKED(TrailVal(dest))) {
if (MARKED_PTR(&TrailVal(dest))) {
UNMARK(&TrailVal(dest));
if (HEAP_PTR(TrailVal(dest))) {
into_relocation_chain(&TrailVal(dest), GET_NEXT(TrailVal(dest)));
@@ -1863,7 +2117,7 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
#ifdef FROZEN_STACKS
/* it is complex to recover cells with frozen segments */
TrailVal(dest) = TrailVal(trail_ptr);
if (MARKED(TrailVal(dest))) {
if (MARKED_PTR(&TrailVal(dest))) {
UNMARK(&TrailVal(dest));
if (HEAP_PTR(TrailVal(dest))) {
into_relocation_chain(&TrailVal(dest), GET_NEXT(TrailVal(dest)));
@@ -1970,14 +2224,14 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
CELL *ptr;
CELL old = TrailTerm(trail_ptr+1);
if (MARKED(trail_cell))
if (MARKED_PTR(&TrailTerm(trail_ptr+2)))
ptr = RepAppl(UNMARK_CELL(trail_cell));
else
ptr = RepAppl(trail_cell);
TrailTerm(dest+1) = old;
TrailTerm(dest+2) = TrailTerm(dest) = trail_cell;
if (MARKED(old)) {
if (MARKED_PTR(&TrailTerm(trail_ptr+1))) {
UNMARK(&TrailTerm(dest+1));
if (HEAP_PTR(old)) {
into_relocation_chain(&TrailTerm(dest+1), GET_NEXT(old));
@@ -1985,21 +2239,21 @@ sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
}
#ifdef FROZEN_STACKS
TrailVal(dest+1) = TrailVal(trail_ptr+1);
if (MARKED(TrailVal(dest+1))) {
if (MARKED_PTR(&TrailVal(dest+1))) {
UNMARK(&TrailVal(dest+1));
if (HEAP_PTR(TrailVal(dest+1))) {
into_relocation_chain(&TrailVal(dest+1), GET_NEXT(TrailTerm(dest+1)));
}
}
TrailVal(dest+2) = TrailVal(trail_ptr+2);
if (MARKED(TrailVal(dest+2))) {
if (MARKED_PTR(&TrailVal(dest+2))) {
UNMARK(&TrailVal(dest+2));
if (HEAP_PTR(TrailVal(dest+2))) {
into_relocation_chain(&TrailVal(dest+2), GET_NEXT(TrailTerm(dest+2)));
}
}
#endif
if (MARKED(trail_cell)) {
if (MARKED_PTR(&TrailTerm(trail_ptr+2))) {
UNMARK(&TrailTerm(dest));
UNMARK(&TrailTerm(dest+2));
if (HEAP_PTR(trail_cell)) {
@@ -2108,7 +2362,7 @@ sweep_environments(CELL_PTR gc_ENV, OPREG size, CELL *pvbmap)
}
if (bmap < 0) {
CELL env_cell = *saved_var;
if (MARKED(env_cell)) {
if (MARKED_PTR(saved_var)) {
UNMARK(saved_var);
if (HEAP_PTR(env_cell)) {
into_relocation_chain(saved_var, GET_NEXT(env_cell));
@@ -2122,7 +2376,7 @@ sweep_environments(CELL_PTR gc_ENV, OPREG size, CELL *pvbmap)
/* we use the B field in the environment to tell whether we have
been here before or not
*/
if (!MARKED(gc_ENV[E_CB]))
if (!MARKED_PTR(gc_ENV+E_CB))
return;
UNMARK(gc_ENV+E_CB);
@@ -2140,7 +2394,7 @@ sweep_slots(CELL *ptr)
ptr++;
while (ns > 0) {
CELL cp_cell = *ptr;
if (MARKED(cp_cell)) {
if (MARKED_PTR(ptr)) {
UNMARK(ptr);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(ptr, GET_NEXT(cp_cell));
@@ -2246,7 +2500,7 @@ sweep_choicepoints(choiceptr gc_B)
vars = *answ_fr++;
while (vars--) {
CELL cp_cell = *answ_fr;
if (MARKED(cp_cell)) {
if (MARKED_PTR(answ_fr)) {
UNMARK(answ_fr);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(answ_fr, GET_NEXT(cp_cell));
@@ -2271,7 +2525,7 @@ sweep_choicepoints(choiceptr gc_B)
nargs = *saved_reg++;
while (nargs--) {
CELL cp_cell = *saved_reg;
if (MARKED(cp_cell)) {
if (MARKED_PTR(saved_reg)) {
UNMARK(saved_reg);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(saved_reg, GET_NEXT(cp_cell));
@@ -2302,7 +2556,7 @@ sweep_choicepoints(choiceptr gc_B)
saved_reg < (CELL *)(gcp+1) + nargs;
saved_reg++) {
CELL cp_cell = *saved_reg;
if (MARKED(cp_cell)) {
if (MARKED_PTR(saved_reg)) {
UNMARK(saved_reg);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(saved_reg, GET_NEXT(cp_cell));
@@ -2313,7 +2567,7 @@ sweep_choicepoints(choiceptr gc_B)
nargs = *saved_reg++;
while (nargs--) {
CELL cp_cell = *saved_reg;
if (MARKED(cp_cell)) {
if (MARKED_PTR(saved_reg)) {
UNMARK(saved_reg);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(saved_reg, GET_NEXT(cp_cell));
@@ -2353,7 +2607,7 @@ sweep_choicepoints(choiceptr gc_B)
aux_ptr += heap_arity + subs_arity + vars_arity + 1;
for (i = 0; i < heap_arity + subs_arity + vars_arity + 1; i++) {
CELL cp_cell = *aux_ptr;
if (MARKED(cp_cell)) {
if (MARKED_PTR(aux_ptr)) {
UNMARK(aux_ptr);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(aux_ptr, GET_NEXT(cp_cell));
@@ -2366,7 +2620,7 @@ sweep_choicepoints(choiceptr gc_B)
aux_ptr += 2 + subs_arity + vars_arity;
for (i = 0; i < vars_arity; i++) {
CELL cp_cell = *aux_ptr;
if (MARKED(cp_cell)) {
if (MARKED_PTR(aux_ptr)) {
UNMARK(aux_ptr);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(aux_ptr, GET_NEXT(cp_cell));
@@ -2376,7 +2630,7 @@ sweep_choicepoints(choiceptr gc_B)
}
for (i = 1; i < subs_arity; i++) {
CELL cp_cell = *--aux_ptr;
if (MARKED(cp_cell)) {
if (MARKED_PTR(aux_ptr)) {
UNMARK(aux_ptr);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(aux_ptr, GET_NEXT(cp_cell));
@@ -2397,7 +2651,7 @@ sweep_choicepoints(choiceptr gc_B)
saved_reg < &(gc_B->cp_a1)+rtp->u.lds.s+rtp->u.lds.extra;
saved_reg++) {
CELL cp_cell = *saved_reg;
if (MARKED(cp_cell)) {
if (MARKED_PTR(saved_reg)) {
UNMARK(saved_reg);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(saved_reg, GET_NEXT(cp_cell));
@@ -2419,7 +2673,7 @@ sweep_choicepoints(choiceptr gc_B)
saved_reg < &gc_B->cp_a1 + rtp->u.ld.s;
saved_reg++) {
CELL cp_cell = *saved_reg;
if (MARKED(cp_cell)) {
if (MARKED_PTR(saved_reg)) {
UNMARK(saved_reg);
if (HEAP_PTR(cp_cell)) {
into_relocation_chain(saved_reg, GET_NEXT(cp_cell));
@@ -2545,7 +2799,7 @@ compact_heap(void)
#endif
dest = (CELL_PTR) H0 + total_marked - 1;
for (current = H - 1; current >= H0; current--) {
if (MARKED(*current)) {
if (MARKED_PTR(current)) {
CELL ccell = UNMARK_CELL(*current);
if (ccell < (CELL)AtomBase && ccell > EndSpecials && IsVarTerm(ccell)
) {
@@ -2554,7 +2808,7 @@ compact_heap(void)
CELL *ptr = current - nofcells ;
CELL func = ptr[0];
if (MARKED(func)) {
if (MARKED_PTR(ptr)) {
#ifdef DEBUG
found_marked+=nofcells;
#endif /* DEBUG */
@@ -2626,7 +2880,7 @@ compact_heap(void)
dest = (CELL_PTR) H0;
for (current = H0; current < H; current++) {
CELL ccur = *current;
if (MARKED(ccur)) {
if (MARKED_PTR(current)) {
CELL uccur = UNMARK_CELL(ccur);
if (uccur < (CELL)AtomBase && uccur > EndSpecials && IsVarTerm(uccur)) {
/* oops, we found a blob */
@@ -2928,7 +3182,7 @@ sweep_delays(CELL *max)
{
CELL *ptr = (CELL *)Yap_GlobalBase;
while (ptr < max) {
if (MARKED(*ptr)) {
if (MARKED_PTR(ptr)) {
UNMARK(ptr);
if (HEAP_PTR(*ptr)) {
into_relocation_chain(ptr, GET_NEXT(*ptr));
@@ -3074,6 +3328,19 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop)
total_smarked = 0;
#endif
discard_trail_entries = 0;
#if GC_NO_TAGS
{
UInt alloc_sz = (CELL *)Yap_TrailTop-(CELL*)Yap_GlobalBase;
bp = Yap_PreAllocCodeSpace();
if (bp+alloc_sz > (char *)AuxSp) {
/* not enough space */
bp = (char *)Yap_ExpandPreAllocCodeSpace(alloc_sz);
}
if (!bp)
return 0;
bzero((void *)bp, alloc_sz);
}
#endif /* GC_NO_TAGS */
#ifdef HYBRID_SCHEME
iptop = (CELL_PTR *)H;
#endif
@@ -3084,9 +3351,12 @@ do_gc(Int predarity, CELL *current_env, yamop *nextop)
marking_phase(old_TR, current_env, nextop, max);
m_time = Yap_cputime();
gc_time = m_time-time_start;
if (heap_cells)
effectiveness = ((heap_cells-total_marked)*100)/heap_cells;
else
if (heap_cells) {
if (heap_cells > 1000000)
effectiveness = (heap_cells-total_marked)/(heap_cells/100);
else
effectiveness = 100*(heap_cells-total_marked)/heap_cells;
} else
effectiveness = 0;
if (gc_verbose) {
fprintf(Yap_stderr, "%% Mark: Recovered %ld cells of %ld (%ld%%) in %g sec\n",

7
H/Regs.h
View File

@@ -10,7 +10,7 @@
* File: Regs.h *
* mods: *
* comments: YAP abstract machine registers *
* version: $Id: Regs.h,v 1.29 2004-06-05 03:37:00 vsc Exp $ *
* version: $Id: Regs.h,v 1.30 2004-09-16 17:29:08 vsc Exp $ *
*************************************************************************/
@@ -722,6 +722,7 @@ static inline UInt
CalculateStackGap(void)
{
UInt gmin = (LCL0-H0)>>3;
UInt min_gap = MinStackGap;
return(gmin < min_gap ? min_gap : gmin );
if (gmin < MinStackGap) gmin = MinStackGap;
return gmin;
}

62
H/heapgc.h
View File

@@ -37,7 +37,9 @@
)
#else
#ifdef TAG_LOW_BITS_32
#if INVERT_RBIT
#if GC_NO_TAGS
#define GET_NEXT(val) ((CELL *) ((val) & ~LowTagBits))
#elif INVERT_RBIT
#define GET_NEXT(val) ((CELL *) (((val) & ~(LowTagBits|MBIT))|RBIT))
#else
#define GET_NEXT(val) ((CELL *) ((val) & ~(LowTagBits|MBIT|RBIT)))
@@ -80,6 +82,55 @@
(CellPtr(B) < CellPtr(val) && CellPtr(val) <= \
LCL0 && HEAP_PTR(val))))
#if GC_NO_TAGS
extern char *bp;
#define MARK_BIT 1
#define RMARK_BIT 2
#define mcell(X) bp[X-(CELL *)Yap_GlobalBase]
static inline int
MARKED_PTR(CELL* ptr)
{
return mcell(ptr) & MARK_BIT;
}
static inline void
MARK(CELL* ptr)
{
mcell(ptr) = mcell(ptr) | MARK_BIT;
}
static inline void
UNMARK(CELL* ptr)
{
mcell(ptr) = mcell(ptr) & ~MARK_BIT;
}
#define UNMARK_CELL(X) (X)
static inline void
RMARK(CELL* ptr)
{
mcell(ptr) = mcell(ptr) | RMARK_BIT;
}
static inline void
UNRMARK(CELL* ptr)
{
mcell(ptr) = mcell(ptr) & ~RMARK_BIT;
}
static inline int
RMARKED(CELL* ptr)
{
return !GCIsPrimitiveTerm(*ptr) && (mcell(ptr) & RMARK_BIT);
}
#else
/* is the object pointed to by ptr marked? */
#ifdef TAGS_FAST_OPS
#define MARKED_VAR(val) ((val) & MBIT)
@@ -103,7 +154,10 @@
#define UNMARK_CELL(val) ((val) ^ MBIT) /* unmark the object pointed to by ptr */
#define MARKED_PTR(ptr) MARKED(*(ptr))
#ifdef TAGS_FAST_OPS
#define RMARKED(val) (!GCIsPrimitiveTerm(val) && (IsVarTerm(val) ?\
((val) & RBIT) : !((val) & RBIT)))
@@ -114,13 +168,17 @@
? \
((val) & ~MBIT) : ((val) | MBIT))
#else
#if INVERT_RBIT
#define RMARKED(val) (!GCIsPrimitiveTerm(val) && !((val) & RBIT))
#else
#define RMARKED(val) (!GCIsPrimitiveTerm(val) && ((val) & RBIT))
#endif
#endif
#endif /* GC_NO_TAGS */
#endif
/* is the object pointed to by ptr marked as in a relocation chain? */

14
m4/TermExt.h.m4
View File

@@ -10,7 +10,7 @@
* File: TermExt.h *
* mods: *
* comments: Extensions to standard terms for YAP *
* version: $Id: TermExt.h.m4,v 1.14 2004-06-05 03:37:00 vsc Exp $ *
* version: $Id: TermExt.h.m4,v 1.15 2004-09-16 17:29:08 vsc Exp $ *
*************************************************************************/
#ifdef USE_SYSTEM_MALLOC
@@ -110,7 +110,11 @@ typedef struct special_functors_struct
special_functors;
#if SIZEOF_DOUBLE == SIZEOF_LONG_INT
#if GC_NO_TAGS
Inline(MkFloatTerm, Term, Float, dbl, (H[0] = (CELL)FunctorDouble, *(Float *)(H+1) = dbl, H[2]=(2*sizeof(CELL)+EndSpecials),H+=3,AbsAppl(H-3)))
#else
Inline(MkFloatTerm, Term, Float, dbl, (H[0] = (CELL)FunctorDouble, *(Float *)(H+1) = dbl, H[2]=((2*sizeof(CELL)+EndSpecials)|MBIT),H+=3,AbsAppl(H-3)))
#endif
Destructor(Term, FloatOf, Float, t, *(Float *)(RepAppl(t)+1))
@@ -146,7 +150,11 @@ CpFloatUnaligned(CELL *ptr)
#endif
#if GC_NO_TAGS
Inline(MkFloatTerm, Term, Float, dbl, (AlignGlobalForDouble(), H[0] = (CELL)FunctorDouble, *(Float *)(H+1) = dbl, H[3]=(3*sizeof(CELL)+EndSpecials), H+=4, AbsAppl(H-4)))
#else
Inline(MkFloatTerm, Term, Float, dbl, (AlignGlobalForDouble(), H[0] = (CELL)FunctorDouble, *(Float *)(H+1) = dbl, H[3]=((3*sizeof(CELL)+EndSpecials)|MBIT), H+=4, AbsAppl(H-4)))
#endif
Destructor(Term, FloatOf, Float, t, (DOUBLE_ALIGNED(RepAppl(t)) ? *(Float *)(RepAppl(t)+1) : CpFloatUnaligned(RepAppl(t))))
/* no alignment problems for 64 bit machines */
@@ -160,7 +168,11 @@ Inline(IsFloatTerm, int, Term, t, IsApplTerm(t) && FunctorOfTerm(t) == FunctorDo
/* extern Functor FunctorLongInt; */
#if GC_NO_TAGS
Inline(MkLongIntTerm, Term, Int, i, (H[0] = (CELL)FunctorLongInt,H[1] = (CELL)(i),H[2]=(2*sizeof(CELL)+EndSpecials),H+=3,AbsAppl(H-3)))
#else
Inline(MkLongIntTerm, Term, Int, i, (H[0] = (CELL)FunctorLongInt,H[1] = (CELL)(i),H[2]=((2*sizeof(CELL)+EndSpecials)|MBIT),H+=3,AbsAppl(H-3)))
#endif
Destructor(Term, LongIntOf, Int, t, RepAppl(t)[1])
Inline(IsLongIntTerm, int, Term, t, IsApplTerm(t) && FunctorOfTerm(t) == FunctorLongInt)

8
m4/Yap.h.m4
View File

@@ -10,7 +10,7 @@
* File: Yap.h.m4 *
* mods: *
* comments: main header file for YAP *
* version: $Id: Yap.h.m4,v 1.63 2004-08-11 16:14:55 vsc Exp $ *
* version: $Id: Yap.h.m4,v 1.64 2004-09-16 17:29:08 vsc Exp $ *
*************************************************************************/
#include "config.h"
@@ -668,21 +668,27 @@ and RefOfTerm(t) : Term -> DBRef = ...
#endif /* !LONG_ADDRESSES */
#ifdef TAG_LOW_BITS_32
#if !GC_NO_TAGS
#define MBIT 0x80000000
#define RBIT 0x40000000
#if IN_SECOND_QUADRANT
#define INVERT_RBIT 1 /* RBIT is 1 by default */
#endif
#endif !GC_NO_TAGS
#else
#if !GC_NO_TAGS
#if defined(SBA) && defined(__linux__)
#define MBIT /* 0x20000000 */ MKTAG(0x1,0) /* mark bit */
#else
#define RBIT /* 0x20000000 */ MKTAG(0x1,0) /* relocation chain bit */
#define MBIT /* 0x40000000 */ MKTAG(0x2,0) /* mark bit */
#endif
#endif !GC_NO_TAGS
#endif
#define TermSize sizeof(Term)