4082 lines
99 KiB
C
Executable File
4082 lines
99 KiB
C
Executable File
/*************************************************************************
|
|
* *
|
|
* YAP Prolog *
|
|
* *
|
|
* Yap Prolog was developed at NCCUP - Universidade do Porto *
|
|
* *
|
|
* Copyright L.Damas, V.S.Costa and Universidade do Porto 1985-1997 *
|
|
* *
|
|
**************************************************************************
|
|
* *
|
|
* File: heapgc.c *
|
|
* Last rev: *
|
|
* mods: *
|
|
* comments: Global Stack garbage collector *
|
|
* *
|
|
*************************************************************************/
|
|
#ifdef SCCS
|
|
static char SccsId[] = "%W% %G%";
|
|
#endif /* SCCS */
|
|
|
|
#include "absmi.h"
|
|
#include "yapio.h"
|
|
#include "alloc.h"
|
|
#include "attvar.h"
|
|
|
|
#if !defined(TABLING)
|
|
#define EASY_SHUNTING 1
|
|
#endif /* !TABLING */
|
|
#define HYBRID_SCHEME 1
|
|
|
|
|
|
/* global variables for garbage collection */
|
|
|
|
STATIC_PROTO(Int p_inform_gc, (void));
|
|
STATIC_PROTO(Int p_gc, (void));
|
|
STATIC_PROTO(void push_registers, (Int, yamop *));
|
|
STATIC_PROTO(void marking_phase, (tr_fr_ptr, CELL *, yamop *));
|
|
STATIC_PROTO(void compaction_phase, (tr_fr_ptr, CELL *, yamop *));
|
|
STATIC_PROTO(void pop_registers, (Int, yamop *));
|
|
STATIC_PROTO(void init_dbtable, (tr_fr_ptr));
|
|
STATIC_PROTO(void mark_db_fixed, (CELL *));
|
|
STATIC_PROTO(void mark_regs, (tr_fr_ptr));
|
|
STATIC_PROTO(void mark_trail, (tr_fr_ptr, tr_fr_ptr, CELL *, choiceptr));
|
|
STATIC_PROTO(void mark_environments, (CELL *, OPREG, CELL *));
|
|
STATIC_PROTO(void mark_choicepoints, (choiceptr, tr_fr_ptr, int));
|
|
STATIC_PROTO(void into_relocation_chain, (CELL *, CELL *));
|
|
STATIC_PROTO(void sweep_trail, (choiceptr, tr_fr_ptr));
|
|
STATIC_PROTO(void sweep_environments, (CELL *, OPREG, CELL *));
|
|
STATIC_PROTO(void sweep_choicepoints, (choiceptr));
|
|
STATIC_PROTO(void compact_heap, (void));
|
|
STATIC_PROTO(void update_relocation_chain, (CELL *, CELL *));
|
|
STATIC_PROTO(int is_gc_verbose, (void));
|
|
STATIC_PROTO(int is_gc_very_verbose, (void));
|
|
STATIC_PROTO(void LeaveGCMode, (void));
|
|
#ifdef EASY_SHUNTING
|
|
STATIC_PROTO(void set_conditionals, (tr_fr_ptr));
|
|
#endif /* EASY_SHUNTING */
|
|
|
|
#include "heapgc.h"
|
|
|
|
typedef struct gc_mark_continuation {
|
|
CELL *v;
|
|
int nof;
|
|
} cont;
|
|
|
|
/* straightforward binary tree scheme that, given a key, finds a
|
|
matching dbref */
|
|
|
|
typedef enum {
|
|
db_entry,
|
|
cl_entry,
|
|
lcl_entry,
|
|
li_entry,
|
|
dcl_entry
|
|
} db_entry_type;
|
|
|
|
typedef struct db_entry {
|
|
CODEADDR val;
|
|
db_entry_type db_type;
|
|
int in_use;
|
|
struct db_entry *left;
|
|
CODEADDR lim;
|
|
struct db_entry *right;
|
|
} *dbentry;
|
|
|
|
typedef struct RB_red_blk_node {
|
|
CODEADDR key;
|
|
CODEADDR lim;
|
|
db_entry_type db_type;
|
|
int in_use;
|
|
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;
|
|
|
|
#ifdef EASY_SHUNTING
|
|
#undef cont_top0
|
|
#define cont_top0 (cont *)sTR
|
|
#endif
|
|
|
|
#if !defined(YAPOR) && !defined(THREADS)
|
|
/* in a single gc */
|
|
static unsigned long int total_marked, total_oldies; /* number of heap objects marked */
|
|
|
|
#ifdef EASY_SHUNTING
|
|
static choiceptr current_B;
|
|
|
|
static tr_fr_ptr sTR, sTR0;
|
|
|
|
static CELL *prev_HB;
|
|
#endif
|
|
|
|
static tr_fr_ptr new_TR;
|
|
|
|
static CELL *HGEN;
|
|
|
|
char *Yap_bp;
|
|
|
|
static int discard_trail_entries = 0;
|
|
|
|
#ifdef HYBRID_SCHEME
|
|
static CELL_PTR *iptop;
|
|
#endif
|
|
|
|
#ifndef EASY_SHUNTING
|
|
static cont *cont_top0;
|
|
#endif
|
|
static cont *cont_top;
|
|
|
|
static gc_ma_hash_entry gc_ma_hash_table[GC_MAVARS_HASH_SIZE];
|
|
|
|
static gc_ma_hash_entry *gc_ma_h_top, *gc_ma_h_list;
|
|
|
|
static UInt gc_timestamp; /* an unsigned int */
|
|
|
|
static ADDR db_vec, db_vec0;
|
|
|
|
static rb_red_blk_node *db_root, *db_nil;
|
|
|
|
#endif /* !defined(YAPOR) && !defined(THREADS) */
|
|
|
|
/* support for hybrid garbage collection scheme */
|
|
|
|
static void
|
|
gc_growtrail(int committed, tr_fr_ptr begsTR, cont *old_cont_top0)
|
|
{
|
|
UInt sz = Yap_TrailTop-(ADDR)OldTR;
|
|
/* ask for double the size */
|
|
sz = 2*sz;
|
|
|
|
if (!Yap_growtrail(sz, TRUE)) {
|
|
#ifdef EASY_SHUNTING
|
|
if (begsTR) {
|
|
sTR = (tr_fr_ptr)old_cont_top0;
|
|
while (begsTR != NULL) {
|
|
tr_fr_ptr newsTR = (tr_fr_ptr)TrailTerm(begsTR);
|
|
TrailTerm(sTR) = TrailTerm(begsTR+1);
|
|
TrailTerm(sTR+1) = TrailTerm(begsTR+2);
|
|
begsTR = newsTR;
|
|
sTR += 2;
|
|
}
|
|
}
|
|
set_conditionals(sTR);
|
|
#endif
|
|
/* could not find more trail */
|
|
save_machine_regs();
|
|
_longjmp(Yap_gc_restore, 2);
|
|
}
|
|
}
|
|
|
|
inline static void
|
|
PUSH_CONTINUATION(CELL *v, int nof) {
|
|
cont *x;
|
|
x = cont_top;
|
|
x++;
|
|
if ((ADDR)x > Yap_TrailTop-1024) {
|
|
gc_growtrail(TRUE, NULL, NULL);
|
|
}
|
|
x->v = v;
|
|
x->nof = nof;
|
|
cont_top = x;
|
|
}
|
|
|
|
#define POP_CONTINUATION() { \
|
|
if (cont_top == cont_top0) \
|
|
return; \
|
|
else { \
|
|
int nof = cont_top->nof; \
|
|
cont *x = cont_top; \
|
|
\
|
|
current = x->v; \
|
|
if (nof == 1) \
|
|
cont_top = --x; \
|
|
else { \
|
|
x->nof = nof-1; \
|
|
x->v = current+1; \
|
|
} \
|
|
} \
|
|
goto begin; }
|
|
|
|
#ifdef HYBRID_SCHEME
|
|
|
|
inline static void
|
|
PUSH_POINTER(CELL *v) {
|
|
if (iptop >= (CELL_PTR *)ASP) return;
|
|
*iptop++ = v;
|
|
}
|
|
|
|
inline static void
|
|
POP_POINTER(void) {
|
|
if (iptop >= (CELL_PTR *)ASP) return;
|
|
--iptop;
|
|
}
|
|
|
|
inline static void
|
|
POPSWAP_POINTER(CELL_PTR *vp, CELL_PTR v) {
|
|
if (iptop >= (CELL_PTR *)ASP || iptop == vp) return;
|
|
if (*vp != v)
|
|
return;
|
|
--iptop;
|
|
if (vp != iptop)
|
|
*vp = *iptop;
|
|
}
|
|
|
|
/*
|
|
original code from In Hyuk Choi,
|
|
found at http://userpages.umbc.edu/~ichoi1/project/cs441.htm
|
|
*/
|
|
|
|
static inline void
|
|
exchange(CELL_PTR * b, Int i, Int j)
|
|
{
|
|
CELL *t = b[j];
|
|
|
|
b[j] = b[i];
|
|
b[i] = t;
|
|
}
|
|
|
|
static UInt
|
|
partition(CELL *a[], Int p, Int r)
|
|
{
|
|
CELL *x;
|
|
UInt i, j;
|
|
|
|
x = a[p];
|
|
i = p+1;
|
|
j = r;
|
|
|
|
while (a[j] > x && i < j) {
|
|
j--;
|
|
}
|
|
while (a[i] < x && i < j) {
|
|
i++;
|
|
}
|
|
while(i < j) {
|
|
exchange(a, i, j);
|
|
i++;
|
|
j--;
|
|
while (a[j] > x && i < j) {
|
|
j--;
|
|
}
|
|
while (a[i] < x && i < j) {
|
|
i++;
|
|
}
|
|
}
|
|
if (a[i] > x)
|
|
i--;
|
|
exchange(a, p, i);
|
|
return(i);
|
|
}
|
|
|
|
static void
|
|
insort(CELL *a[], Int p, Int q)
|
|
{
|
|
Int j;
|
|
|
|
for (j = p+1; j <= q; j ++) {
|
|
CELL *key;
|
|
Int i;
|
|
|
|
key = a[j];
|
|
i = j;
|
|
|
|
while (i > p && a[i-1] > key) {
|
|
a[i] = a[i-1];
|
|
i --;
|
|
}
|
|
a[i] = key;
|
|
}
|
|
}
|
|
|
|
|
|
static void
|
|
quicksort(CELL *a[], Int p, Int r)
|
|
{
|
|
Int q;
|
|
if (p < r) {
|
|
if (r - p < 100) {
|
|
insort(a, p, r);
|
|
return;
|
|
}
|
|
exchange(a, p, (p+r)/2);
|
|
q = partition (a, p, r);
|
|
quicksort(a, p, q-1);
|
|
quicksort(a, q + 1, r);
|
|
}
|
|
}
|
|
|
|
#else
|
|
|
|
#define PUSH_POINTER(P)
|
|
#define POP_POINTER()
|
|
#define POPSWAP_POINTER(P)
|
|
|
|
#endif /* HYBRID_SCHEME */
|
|
|
|
|
|
#ifdef MULTI_ASSIGNMENT_VARIABLES
|
|
/*
|
|
Based in opt.mavar.h. This is a set of routines to find out if a
|
|
ma trail entry has appeared before in the same trail segment. All ma
|
|
entries for the same cell are then linked. At the end of mark_trail() only
|
|
one will remain.
|
|
*/
|
|
|
|
static inline unsigned int
|
|
GC_MAVAR_HASH(CELL *addr) {
|
|
#if SIZEOF_INT_P==8
|
|
return((((unsigned int)((CELL)(addr)))>>3)%GC_MAVARS_HASH_SIZE);
|
|
#else
|
|
return((((unsigned int)((CELL)(addr)))>>2)%GC_MAVARS_HASH_SIZE);
|
|
#endif
|
|
}
|
|
|
|
static inline gc_ma_hash_entry *
|
|
GC_ALLOC_NEW_MASPACE(void)
|
|
{
|
|
gc_ma_hash_entry *new = gc_ma_h_top;
|
|
if ((char *)gc_ma_h_top > Yap_TrailTop-1024)
|
|
gc_growtrail(FALSE, NULL, NULL);
|
|
gc_ma_h_top++;
|
|
cont_top = (cont *)gc_ma_h_top;
|
|
#ifdef EASY_SHUNTING
|
|
sTR = sTR0 = (tr_fr_ptr)cont_top;
|
|
#else
|
|
cont_top0 = cont_top;
|
|
#endif
|
|
return new;
|
|
}
|
|
|
|
static inline gc_ma_hash_entry*
|
|
gc_lookup_ma_var(CELL *addr, tr_fr_ptr trp) {
|
|
unsigned int i = GC_MAVAR_HASH(addr);
|
|
gc_ma_hash_entry *nptr, *optr = NULL;
|
|
|
|
if (gc_ma_hash_table[i].timestmp != gc_timestamp) {
|
|
gc_ma_hash_table[i].timestmp = gc_timestamp;
|
|
gc_ma_hash_table[i].addr = addr;
|
|
#if TABLING
|
|
gc_ma_hash_table[i].loc = trp;
|
|
gc_ma_hash_table[i].more = gc_ma_h_list;
|
|
gc_ma_h_list = gc_ma_hash_table+i;
|
|
#endif /* TABLING */
|
|
gc_ma_hash_table[i].next = NULL;
|
|
return NULL;
|
|
}
|
|
nptr = gc_ma_hash_table+i;
|
|
while (nptr) {
|
|
optr = nptr;
|
|
if (nptr->addr == addr) {
|
|
#if TABLING
|
|
/*
|
|
we're moving from oldest to more recent, so only a new entry
|
|
has the correct new value
|
|
*/
|
|
TrailVal(nptr->loc+1) = TrailVal(trp+1);
|
|
#endif /* TABLING */
|
|
return nptr;
|
|
}
|
|
nptr = nptr->next;
|
|
}
|
|
nptr = GC_ALLOC_NEW_MASPACE();
|
|
optr->next = nptr;
|
|
nptr->addr = addr;
|
|
#if TABLING
|
|
nptr->loc = trp;
|
|
nptr->more = gc_ma_h_list;
|
|
#endif /* TABLING */
|
|
nptr->next = NULL;
|
|
gc_ma_h_list = nptr;
|
|
return NULL;
|
|
}
|
|
|
|
static inline void
|
|
GC_NEW_MAHASH(gc_ma_hash_entry *top) {
|
|
UInt time = ++gc_timestamp;
|
|
|
|
gc_ma_h_list = NULL;
|
|
if (time == 0) {
|
|
unsigned int i;
|
|
|
|
/* damn, we overflowed */
|
|
for (i = 0; i < GC_MAVARS_HASH_SIZE; i++)
|
|
gc_ma_hash_table[i].timestmp = 0L;
|
|
time = ++gc_timestamp;
|
|
}
|
|
gc_ma_h_top = top;
|
|
cont_top = (cont *)gc_ma_h_top;
|
|
#ifdef EASY_SHUNTING
|
|
sTR = (tr_fr_ptr)cont_top;
|
|
#else
|
|
cont_top0 = cont_top;
|
|
#endif
|
|
}
|
|
|
|
#endif
|
|
|
|
/* find all accessible objects on the heap and squeeze out all the rest */
|
|
|
|
static void
|
|
check_pr_trail(tr_fr_ptr trp)
|
|
{
|
|
if ((tr_fr_ptr)Yap_TrailTop-TR < 1024) {
|
|
if (!Yap_growtrail(0, TRUE) || TRUE) {
|
|
/* could not find more trail */
|
|
save_machine_regs();
|
|
_longjmp(Yap_gc_restore, 2);
|
|
}
|
|
}
|
|
}
|
|
|
|
/* push the active registers onto the trail for inclusion during gc */
|
|
|
|
static void
|
|
push_registers(Int num_regs, yamop *nextop)
|
|
{
|
|
int i;
|
|
StaticArrayEntry *sal = StaticArrays;
|
|
|
|
/* push array entries first */
|
|
ArrayEntry *al = DynamicArrays;
|
|
GlobalEntry *gl = GlobalVariables;
|
|
TrailTerm(TR++) = GlobalArena;
|
|
while (al) {
|
|
check_pr_trail(TR);
|
|
TrailTerm(TR++) = al->ValueOfVE;
|
|
al = al->NextAE;
|
|
}
|
|
while (gl) {
|
|
check_pr_trail(TR);
|
|
TrailTerm(TR++) = gl->global;
|
|
gl = gl->NextGE;
|
|
}
|
|
while (sal) {
|
|
if (sal->ArrayType == array_of_nb_terms) {
|
|
UInt arity = -sal->ArrayEArity, i;
|
|
for (i=0; i < arity; i++) {
|
|
Term tlive = sal->ValueOfVE.lterms[i].tlive;
|
|
if (!IsVarTerm(tlive) || !IsUnboundVar(&sal->ValueOfVE.lterms[i].tlive)) {
|
|
check_pr_trail(TR);
|
|
TrailTerm(TR++) = tlive;
|
|
}
|
|
}
|
|
}
|
|
sal = sal->NextAE;
|
|
}
|
|
check_pr_trail(TR);
|
|
TrailTerm(TR) = GcGeneration;
|
|
TR++;
|
|
TrailTerm(TR) = GcPhase;
|
|
TR++;
|
|
#ifdef COROUTINING
|
|
TrailTerm(TR) = WokenGoals;
|
|
TrailTerm(TR+1) = AttsMutableList;
|
|
TR += 2;
|
|
#endif
|
|
for (i = 1; i <= num_regs; i++) {
|
|
check_pr_trail(TR);
|
|
TrailTerm(TR++) = (CELL) XREGS[i];
|
|
}
|
|
/* push any live registers we might have hanging around */
|
|
if (nextop->opc == Yap_opcode(_move_back) ||
|
|
nextop->opc == Yap_opcode(_skip)) {
|
|
CELL *lab = (CELL *)(nextop->u.l.l);
|
|
CELL max = lab[0];
|
|
Int curr = lab[1];
|
|
lab += 2;
|
|
if (max) {
|
|
CELL i;
|
|
for (i=0L; i <= max; i++) {
|
|
if (i == 8*CellSize) {
|
|
curr = lab[0];
|
|
lab++;
|
|
}
|
|
if (curr & 1) {
|
|
check_pr_trail(TR);
|
|
TrailTerm(TR++) = XREGS[i];
|
|
}
|
|
curr >>= 1;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
|
|
/* pop the corrected register values from the trail and update the registers */
|
|
|
|
static void
|
|
pop_registers(Int num_regs, yamop *nextop)
|
|
{
|
|
int i;
|
|
tr_fr_ptr ptr = TR;
|
|
StaticArrayEntry *sal = StaticArrays;
|
|
|
|
/* pop array entries first */
|
|
ArrayEntry *al = DynamicArrays;
|
|
GlobalEntry *gl = GlobalVariables;
|
|
|
|
GlobalArena = 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) {
|
|
UInt arity = -sal->ArrayEArity;
|
|
for (i=0; i < arity; i++) {
|
|
Term tlive = sal->ValueOfVE.lterms[i].tlive;
|
|
if (!IsVarTerm(tlive) || !IsUnboundVar(&sal->ValueOfVE.lterms[i].tlive)) {
|
|
sal->ValueOfVE.lterms[i].tlive = TrailTerm(ptr++);
|
|
}
|
|
}
|
|
}
|
|
sal = sal->NextAE;
|
|
}
|
|
GcGeneration = TrailTerm(ptr++);
|
|
GcPhase = TrailTerm(ptr++);
|
|
#ifdef COROUTINING
|
|
#ifdef MULTI_ASSIGNMENT_VARIABLES
|
|
WokenGoals = TrailTerm(ptr++);
|
|
AttsMutableList = TrailTerm(ptr++);
|
|
#endif
|
|
#endif
|
|
for (i = 1; i <= num_regs; i++)
|
|
XREGS[i] = TrailTerm(ptr++);
|
|
/* pop any live registers we might have hanging around */
|
|
if (nextop->opc == Yap_opcode(_move_back) ||
|
|
nextop->opc == Yap_opcode(_skip)) {
|
|
CELL *lab = (CELL *)(nextop->u.l.l);
|
|
CELL max = lab[0];
|
|
Int curr = lab[1];
|
|
lab += 2;
|
|
if (max) {
|
|
CELL i;
|
|
for (i=0L; i <= max; i++) {
|
|
if (i == 8*CellSize) {
|
|
curr = lab[0];
|
|
lab++;
|
|
}
|
|
if (curr & 1) {
|
|
XREGS[i] = TrailTerm(ptr++);
|
|
}
|
|
curr >>= 1;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
#if DEBUG && COUNT_CELLS_MARKED
|
|
static int
|
|
count_cells_marked(void)
|
|
{
|
|
CELL *current;
|
|
int found_marked = 0;
|
|
|
|
for (current = H - 1; current >= H0; current--) {
|
|
if (MARKED_PTR(current)) {
|
|
found_marked++;
|
|
}
|
|
}
|
|
return(found_marked);
|
|
}
|
|
#endif
|
|
|
|
|
|
static rb_red_blk_node *
|
|
RBMalloc(UInt size)
|
|
{
|
|
ADDR new = db_vec;
|
|
|
|
db_vec += size;
|
|
if ((ADDR)db_vec > Yap_TrailTop-1024) {
|
|
gc_growtrail(FALSE, NULL, NULL);
|
|
}
|
|
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;
|
|
}
|
|
|
|
/* This is code originally written by Emin Martinian */
|
|
|
|
/***********************************************************************/
|
|
/* 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;
|
|
x->in_use = FALSE;
|
|
|
|
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)
|
|
{
|
|
RBTreeInsert(entry, end, db_type);
|
|
}
|
|
|
|
/* find an element in the dbentries table */
|
|
static rb_red_blk_node *
|
|
find_ref_in_dbtable(CODEADDR entry)
|
|
{
|
|
rb_red_blk_node *current = db_root->left;
|
|
|
|
while (current != db_nil) {
|
|
if (current->key <= entry && current->lim > entry) {
|
|
return current;
|
|
}
|
|
if (entry < current->key)
|
|
current = current->right;
|
|
else
|
|
current = current->left;
|
|
}
|
|
return current;
|
|
}
|
|
|
|
/* find an element in the dbentries table */
|
|
static void
|
|
mark_ref_in_use(DBRef ref)
|
|
{
|
|
rb_red_blk_node *el = find_ref_in_dbtable((CODEADDR)ref);
|
|
el->in_use = TRUE;
|
|
}
|
|
|
|
static int
|
|
ref_in_use(DBRef ref)
|
|
{
|
|
rb_red_blk_node *el = find_ref_in_dbtable((CODEADDR)ref);
|
|
return el->in_use;
|
|
}
|
|
|
|
static void
|
|
mark_db_fixed(CELL *ptr) {
|
|
rb_red_blk_node *el;
|
|
|
|
el = find_ref_in_dbtable((CODEADDR)ptr);
|
|
if (el != db_nil) {
|
|
el->in_use = TRUE;
|
|
}
|
|
}
|
|
|
|
static void
|
|
init_dbtable(tr_fr_ptr trail_ptr) {
|
|
StaticClause *sc = DeadStaticClauses;
|
|
MegaClause *mc = DeadMegaClauses;
|
|
StaticIndex *si = DeadStaticIndices;
|
|
|
|
db_vec0 = db_vec = (ADDR)TR;
|
|
db_root = RBTreeCreate();
|
|
while (trail_ptr > (tr_fr_ptr)Yap_TrailBase) {
|
|
register CELL trail_cell;
|
|
|
|
trail_ptr--;
|
|
|
|
trail_cell = TrailTerm(trail_ptr);
|
|
|
|
if (!IsVarTerm(trail_cell) && IsPairTerm(trail_cell)) {
|
|
CELL *pt0 = RepPair(trail_cell);
|
|
/* DB pointer */
|
|
CELL flags;
|
|
|
|
#ifdef FROZEN_STACKS /* TRAIL */
|
|
/* avoid frozen segments */
|
|
if (
|
|
#ifdef SBA
|
|
(ADDR) pt0 >= HeapTop
|
|
#else
|
|
(ADDR) pt0 >= Yap_TrailBase && (ADDR) pt0 < Yap_TrailTop
|
|
#endif
|
|
) {
|
|
continue;
|
|
}
|
|
#endif /* FROZEN_STACKS */
|
|
|
|
flags = *pt0;
|
|
/* for the moment, if all references to the term in the stacks
|
|
are only pointers, reset the flag */
|
|
if (FlagOn(DBClMask, flags)) {
|
|
DBRef dbr = DBStructFlagsToDBStruct(pt0);
|
|
store_in_dbtable((CODEADDR)dbr,
|
|
(CODEADDR)dbr+sizeof(DBStruct)+sizeof(CELL)*dbr->DBT.NOfCells,
|
|
db_entry);
|
|
} else if (flags & LogUpdMask) {
|
|
if (flags & IndexMask) {
|
|
LogUpdIndex *li = ClauseFlagsToLogUpdIndex(pt0);
|
|
store_in_dbtable((CODEADDR)li, (CODEADDR)li+li->ClSize, li_entry);
|
|
} else {
|
|
LogUpdClause *cli = ClauseFlagsToLogUpdClause(pt0);
|
|
store_in_dbtable((CODEADDR)cli, (CODEADDR)cli+cli->ClSize, lcl_entry);
|
|
}
|
|
} else {
|
|
DynamicClause *dcl = ClauseFlagsToDynamicClause(pt0);
|
|
store_in_dbtable((CODEADDR)dcl, (CODEADDR)dcl+dcl->ClSize, dcl_entry);
|
|
}
|
|
}
|
|
}
|
|
while (sc) {
|
|
store_in_dbtable((CODEADDR)sc, (CODEADDR)sc+sc->ClSize, dcl_entry);
|
|
sc = sc->ClNext;
|
|
}
|
|
while (si) {
|
|
store_in_dbtable((CODEADDR)si, (CODEADDR)si+si->ClSize, dcl_entry);
|
|
si = si->SiblingIndex;
|
|
}
|
|
while (mc) {
|
|
store_in_dbtable((CODEADDR)mc, (CODEADDR)mc+mc->ClSize, dcl_entry);
|
|
mc = mc->ClNext;
|
|
}
|
|
if (db_vec == db_vec0) {
|
|
/* could not find any entries: probably using LOG UPD semantics */
|
|
db_vec0 = NULL;
|
|
}
|
|
}
|
|
|
|
#ifdef DEBUG
|
|
|
|
/* #define INSTRUMENT_GC 1 */
|
|
|
|
#ifdef INSTRUMENT_GC
|
|
typedef enum {
|
|
gc_var,
|
|
gc_ref,
|
|
gc_atom,
|
|
gc_int,
|
|
gc_num,
|
|
gc_list,
|
|
gc_appl,
|
|
gc_func,
|
|
gc_susp
|
|
} gc_types;
|
|
unsigned long chain[16];
|
|
unsigned long env_vars;
|
|
unsigned long vars[gc_susp+1];
|
|
|
|
unsigned long num_bs;
|
|
unsigned long old_vars, new_vars;
|
|
|
|
static CELL *TrueHB;
|
|
|
|
static void
|
|
inc_vars_of_type(CELL *curr,gc_types val) {
|
|
if (curr >= H0 && curr < TrueHB) {
|
|
old_vars++;
|
|
} else if (curr >= TrueHB && curr < H) {
|
|
new_vars++;
|
|
} else {
|
|
return;
|
|
}
|
|
vars[val]++;
|
|
}
|
|
|
|
static void
|
|
put_type_info(unsigned long total)
|
|
{
|
|
fprintf(Yap_stderr,"%% type info for %lu cells\n", total);
|
|
fprintf(Yap_stderr,"%% %lu vars\n", vars[gc_var]);
|
|
fprintf(Yap_stderr,"%% %lu refs\n", vars[gc_ref]);
|
|
fprintf(Yap_stderr,"%% %lu references from env\n", env_vars);
|
|
fprintf(Yap_stderr,"%% %lu atoms\n", vars[gc_atom]);
|
|
fprintf(Yap_stderr,"%% %lu small ints\n", vars[gc_int]);
|
|
fprintf(Yap_stderr,"%% %lu other numbers\n", vars[gc_num]);
|
|
fprintf(Yap_stderr,"%% %lu lists\n", vars[gc_list]);
|
|
fprintf(Yap_stderr,"%% %lu compound terms\n", vars[gc_appl]);
|
|
fprintf(Yap_stderr,"%% %lu functors\n", vars[gc_func]);
|
|
fprintf(Yap_stderr,"%% %lu suspensions\n", vars[gc_susp]);
|
|
}
|
|
|
|
static void
|
|
inc_var(CELL *current, CELL *next)
|
|
{
|
|
int len = 1;
|
|
CELL *mynext=next;
|
|
|
|
if (ONHEAP(current)) {
|
|
if (next == current) {
|
|
inc_vars_of_type(current,gc_var);
|
|
chain[0]++;
|
|
} else {
|
|
inc_vars_of_type(current,gc_ref);
|
|
while(ONHEAP(mynext) && IsVarTerm(*mynext)) {
|
|
CELL *prox = GET_NEXT(*mynext);
|
|
if (prox == mynext) {
|
|
chain[0]++;
|
|
break;
|
|
}
|
|
len++;
|
|
mynext = prox;
|
|
}
|
|
if (len>=15)
|
|
(chain[15])++;
|
|
else
|
|
(chain[len])++;
|
|
}
|
|
}
|
|
}
|
|
#endif /* INSTRUMENT_GC */
|
|
|
|
int STD_PROTO(vsc_stop,(void));
|
|
|
|
int
|
|
vsc_stop(void) {
|
|
return(1);
|
|
}
|
|
|
|
#endif
|
|
|
|
#ifdef CHECK_GLOBAL
|
|
static void
|
|
check_global(void) {
|
|
CELL *current;
|
|
|
|
#ifdef INSTRUMENT_GC
|
|
vars[gc_var] = 0;
|
|
vars[gc_ref] = 0;
|
|
vars[gc_atom] = 0;
|
|
vars[gc_int] = 0;
|
|
vars[gc_num] = 0;
|
|
vars[gc_list] = 0;
|
|
vars[gc_appl] = 0;
|
|
vars[gc_func] = 0;
|
|
vars[gc_susp] = 0;
|
|
#endif
|
|
for (current = H - 1; current >= H0; current--) {
|
|
CELL ccurr = *current;
|
|
|
|
if (MARKED_PTR(current)) {
|
|
CELL ccell = UNMARK_CELL(ccurr);
|
|
if (ccell == EndSpecials) {
|
|
/* oops, we found a blob */
|
|
CELL *ptr = current-1;
|
|
UInt nofcells;
|
|
|
|
while (!MARKED_PTR(ptr)) ptr--;
|
|
nofcells = current-ptr;
|
|
current = ptr;
|
|
ccurr = *current;
|
|
/* process the functor next */
|
|
}
|
|
}
|
|
#if INSTRUMENT_GC
|
|
if (IsVarTerm(ccurr)) {
|
|
if (IsBlobFunctor((Functor)ccurr)) vars[gc_num]++;
|
|
else if (ccurr != 0 && (ccurr < (CELL)Yap_GlobalBase || ccurr > (CELL)Yap_TrailTop)) {
|
|
/* printf("%p: %s/%d\n", current,
|
|
RepAtom(NameOfFunctor((Functor)ccurr))->StrOfAE,
|
|
ArityOfFunctor((Functor)ccurr));*/
|
|
vars[gc_func]++;
|
|
}
|
|
else if (IsUnboundVar(current)) vars[gc_var]++;
|
|
else vars[gc_ref]++;
|
|
} else if (IsApplTerm(ccurr)) {
|
|
/* printf("%p: f->%p\n",current,RepAppl(ccurr)); */
|
|
vars[gc_appl]++;
|
|
} else if (IsPairTerm(ccurr)) {
|
|
/* printf("%p: l->%p\n",current,RepPair(ccurr)); */
|
|
vars[gc_list]++;
|
|
} else if (IsAtomTerm(ccurr)) {
|
|
/* printf("%p: %s\n",current,RepAtom(AtomOfTerm(ccurr))->StrOfAE); */
|
|
vars[gc_atom]++;
|
|
} else if (IsIntTerm(ccurr)) {
|
|
/* printf("%p: %d\n",current,IntOfTerm(ccurr)); */
|
|
vars[gc_int]++;
|
|
}
|
|
#endif
|
|
}
|
|
#if INSTRUMENT_GC
|
|
put_type_info(H-H0);
|
|
vars[gc_var] = 0;
|
|
vars[gc_ref] = 0;
|
|
vars[gc_atom] = 0;
|
|
vars[gc_int] = 0;
|
|
vars[gc_num] = 0;
|
|
vars[gc_list] = 0;
|
|
vars[gc_appl] = 0;
|
|
vars[gc_func] = 0;
|
|
vars[gc_susp] = 0;
|
|
#endif
|
|
}
|
|
#else
|
|
#define check_global()
|
|
#endif /* CHECK_GLOBAL */
|
|
|
|
/* mark a heap object and all heap objects accessible from it */
|
|
|
|
static void
|
|
mark_variable(CELL_PTR current)
|
|
{
|
|
CELL_PTR next;
|
|
register CELL ccur;
|
|
unsigned int arity;
|
|
char *local_bp = Yap_bp;
|
|
|
|
begin:
|
|
if (UNMARKED_MARK(current,local_bp)) {
|
|
POP_CONTINUATION();
|
|
}
|
|
if (current >= H0 && current < H) {
|
|
total_marked++;
|
|
if (current < HGEN) {
|
|
total_oldies++;
|
|
}
|
|
}
|
|
PUSH_POINTER(current);
|
|
ccur = *current;
|
|
next = GET_NEXT(ccur);
|
|
|
|
if (IsVarTerm(ccur)) {
|
|
if (IN_BETWEEN(Yap_GlobalBase,current,H) && IsAttVar(current) && current==next) {
|
|
if (next < H0) POP_CONTINUATION();
|
|
if (!UNMARKED_MARK(next-1,local_bp)) {
|
|
total_marked++;
|
|
if (next-1 < HGEN) {
|
|
total_oldies++;
|
|
}
|
|
PUSH_POINTER(next-1);
|
|
}
|
|
PUSH_CONTINUATION(next+1,2);
|
|
current = next;
|
|
goto begin;
|
|
} else if (ONHEAP(next)) {
|
|
#ifdef EASY_SHUNTING
|
|
CELL cnext;
|
|
/* do variable shunting between variables in the global */
|
|
cnext = *next;
|
|
|
|
if (!MARKED_PTR(next)) {
|
|
if (IsVarTerm(cnext) && (CELL)next == cnext) {
|
|
/* new global variable to new global variable */
|
|
if (next > current && current < prev_HB && current >= HB && next >= HB && next < prev_HB) {
|
|
#ifdef INSTRUMENT_GC
|
|
inc_var(current, current);
|
|
#endif
|
|
*next = (CELL)current;
|
|
UNMARK(next);
|
|
MARK(current);
|
|
*current = (CELL)current;
|
|
POP_CONTINUATION();
|
|
} else {
|
|
/* can't help here */
|
|
#ifdef INSTRUMENT_GC
|
|
inc_var(current, next);
|
|
#endif
|
|
current = next;
|
|
}
|
|
} else {
|
|
/* binding to a determinate reference */
|
|
if (next >= HB && current < LCL0 && cnext != TermFoundVar) {
|
|
UNMARK(current);
|
|
*current = cnext;
|
|
if (current >= H0 && current < H) {
|
|
total_marked--;
|
|
if (current < HGEN) {
|
|
total_oldies--;
|
|
}
|
|
}
|
|
POP_POINTER();
|
|
} else {
|
|
#ifdef INSTRUMENT_GC
|
|
inc_var(current, next);
|
|
#endif
|
|
current = next;
|
|
}
|
|
}
|
|
/* try to shorten chains if they go through the current CP */
|
|
} else if (next > HB &&
|
|
IsVarTerm(cnext) &&
|
|
UNMARK_CELL(cnext) != (CELL)next &&
|
|
current < LCL0) {
|
|
/* This step is possible because we clean up the trail */
|
|
*current = UNMARK_CELL(cnext);
|
|
UNMARK(current);
|
|
if (current >= H0 && current < H ) {
|
|
total_marked--;
|
|
if (current < HGEN) {
|
|
total_oldies--;
|
|
}
|
|
}
|
|
POP_POINTER();
|
|
} else
|
|
#endif
|
|
/* what I'd do without variable shunting */
|
|
{
|
|
#ifdef INSTRUMENT_GC
|
|
inc_var(current, next);
|
|
#endif
|
|
current = next;
|
|
}
|
|
goto begin;
|
|
#ifdef DEBUG
|
|
} else if (next < (CELL *)Yap_GlobalBase || next > (CELL *)Yap_TrailTop) {
|
|
fprintf(Yap_stderr, "OOPS in GC: marking, current=%p, *current=" UInt_FORMAT " next=%p\n", current, ccur, next);
|
|
#endif
|
|
} else {
|
|
#ifdef COROUTING
|
|
total_smarked++;
|
|
#endif
|
|
#ifdef INSTRUMENT_GC
|
|
inc_var(current, next);
|
|
#endif
|
|
}
|
|
POP_CONTINUATION();
|
|
} else if (IsAtomOrIntTerm(ccur)) {
|
|
#ifdef INSTRUMENT_GC
|
|
if (IsAtomTerm(ccur))
|
|
inc_vars_of_type(current,gc_atom);
|
|
else
|
|
inc_vars_of_type(current, gc_int);
|
|
#endif
|
|
POP_CONTINUATION();
|
|
} else if (IsPairTerm(ccur)) {
|
|
#ifdef INSTRUMENT_GC
|
|
inc_vars_of_type(current,gc_list);
|
|
#endif
|
|
if (ONHEAP(next)) {
|
|
/* speedup for strings */
|
|
if (IsAtomOrIntTerm(*next)) {
|
|
if (!UNMARKED_MARK(next,local_bp)) {
|
|
total_marked++;
|
|
if (next < HGEN) {
|
|
total_oldies++;
|
|
}
|
|
PUSH_POINTER(next);
|
|
}
|
|
current = next+1;
|
|
goto begin;
|
|
} else {
|
|
PUSH_CONTINUATION(next+1,1);
|
|
current = next;
|
|
goto begin;
|
|
}
|
|
} else if (ONCODE(next)) {
|
|
mark_db_fixed(RepPair(ccur));
|
|
}
|
|
POP_CONTINUATION();
|
|
} else if (IsApplTerm(ccur)) {
|
|
register CELL cnext = *next;
|
|
|
|
#ifdef INSTRUMENT_GC
|
|
if (!IsExtensionFunctor((Functor)cnext))
|
|
inc_vars_of_type(current,gc_appl);
|
|
else
|
|
inc_vars_of_type(current,gc_num);
|
|
#endif
|
|
if (ONCODE(next)) {
|
|
if ((Functor)cnext == FunctorDBRef) {
|
|
DBRef tref = DBRefOfTerm(ccur);
|
|
|
|
/* make sure the reference is marked as in use */
|
|
if ((tref->Flags & (ErasedMask|LogUpdMask)) == (ErasedMask|LogUpdMask)) {
|
|
*current = MkDBRefTerm((DBRef)LogDBErasedMarker);
|
|
MARK(current);
|
|
} else {
|
|
mark_ref_in_use(tref);
|
|
}
|
|
} else {
|
|
mark_db_fixed(next);
|
|
}
|
|
POP_CONTINUATION();
|
|
}
|
|
if ( MARKED_PTR(next) || !ONHEAP(next) )
|
|
POP_CONTINUATION();
|
|
|
|
if (next < H0) POP_CONTINUATION();
|
|
if (IsExtensionFunctor((Functor)cnext)) {
|
|
switch (cnext) {
|
|
case (CELL)FunctorLongInt:
|
|
MARK(next);
|
|
MARK(next+2);
|
|
if (next < HGEN) {
|
|
total_oldies+=3;
|
|
}
|
|
total_marked += 3;
|
|
PUSH_POINTER(next);
|
|
PUSH_POINTER(next+2);
|
|
POP_CONTINUATION();
|
|
case (CELL)FunctorDouble:
|
|
MARK(next);
|
|
PUSH_POINTER(next);
|
|
{
|
|
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();
|
|
case (CELL)FunctorBigInt:
|
|
{
|
|
UInt sz = (sizeof(MP_INT)+CellSize+
|
|
((MP_INT *)(next+2))->_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);
|
|
sz++;
|
|
MARK(next+sz);
|
|
PUSH_POINTER(next+sz);
|
|
}
|
|
default:
|
|
POP_CONTINUATION();
|
|
}
|
|
}
|
|
if (next < H0) POP_CONTINUATION();
|
|
#ifdef INSTRUMENT_GC
|
|
inc_vars_of_type(next,gc_func);
|
|
#endif
|
|
arity = ArityOfFunctor((Functor)(cnext));
|
|
MARK(next);
|
|
++total_marked;
|
|
if (next < HGEN) {
|
|
++total_oldies;
|
|
}
|
|
PUSH_POINTER(next);
|
|
next++;
|
|
/* speedup for leaves */
|
|
while (arity && IsAtomOrIntTerm(*next)) {
|
|
if (!UNMARKED_MARK(next,local_bp)) {
|
|
total_marked++;
|
|
if (next < HGEN) {
|
|
total_oldies++;
|
|
}
|
|
PUSH_POINTER(next);
|
|
}
|
|
next++;
|
|
arity--;
|
|
}
|
|
if (!arity) POP_CONTINUATION();
|
|
current = next;
|
|
if (arity == 1) goto begin;
|
|
PUSH_CONTINUATION(current+1,arity-1);
|
|
goto begin;
|
|
}
|
|
}
|
|
|
|
void
|
|
Yap_mark_variable(CELL_PTR current)
|
|
{
|
|
mark_variable(current);
|
|
}
|
|
|
|
static void
|
|
mark_code(CELL_PTR ptr, CELL *next)
|
|
{
|
|
if (ONCODE(next)) {
|
|
CELL reg = *ptr;
|
|
if (IsApplTerm(reg) && (Functor)(*next) == FunctorDBRef) {
|
|
DBRef tref = DBRefOfTerm(reg);
|
|
/* make sure the reference is marked as in use */
|
|
if ((tref->Flags & (LogUpdMask|ErasedMask)) == (LogUpdMask|ErasedMask)) {
|
|
*ptr = MkDBRefTerm((DBRef)LogDBErasedMarker);
|
|
} else {
|
|
mark_ref_in_use(tref);
|
|
}
|
|
} else {
|
|
mark_db_fixed(next);
|
|
}
|
|
}
|
|
}
|
|
|
|
static void
|
|
mark_external_reference(CELL *ptr) {
|
|
CELL *next = GET_NEXT(*ptr);
|
|
|
|
if (ONHEAP(next)) {
|
|
#ifdef HYBRID_SCHEME
|
|
CELL_PTR *old = iptop;
|
|
#endif
|
|
mark_variable(ptr);
|
|
POPSWAP_POINTER(old, ptr);
|
|
} else {
|
|
MARK(ptr);
|
|
mark_code(ptr, next);
|
|
}
|
|
}
|
|
|
|
static void inline
|
|
mark_external_reference2(CELL *ptr) {
|
|
CELL *next = GET_NEXT(*ptr);
|
|
|
|
if (ONHEAP(next)) {
|
|
#ifdef HYBRID_SCHEME
|
|
CELL_PTR *old = iptop;
|
|
#endif
|
|
mark_variable(ptr);
|
|
POPSWAP_POINTER(old, ptr);
|
|
} else {
|
|
mark_code(ptr,next);
|
|
}
|
|
}
|
|
|
|
/*
|
|
* mark all heap objects accessible from the trail (which includes the active
|
|
* general purpose registers)
|
|
*/
|
|
|
|
void
|
|
Yap_mark_external_reference(CELL *ptr) {
|
|
mark_external_reference(ptr);
|
|
}
|
|
|
|
static void
|
|
mark_regs(tr_fr_ptr old_TR)
|
|
{
|
|
tr_fr_ptr trail_ptr;
|
|
|
|
|
|
/* first, whatever we dumped on the trail. Easier just to do
|
|
the registers separately? */
|
|
for (trail_ptr = old_TR; trail_ptr < TR; trail_ptr++) {
|
|
mark_external_reference(&TrailTerm(trail_ptr));
|
|
}
|
|
}
|
|
|
|
/* mark all heap objects accessible from a chain of environments */
|
|
|
|
static void
|
|
mark_environments(CELL_PTR gc_ENV, OPREG size, CELL *pvbmap)
|
|
{
|
|
CELL_PTR saved_var;
|
|
while (gc_ENV != NULL) { /* no more environments */
|
|
Int bmap = 0;
|
|
int currv = 0;
|
|
|
|
#ifdef DEBUG
|
|
if (size < 0 || size > 512)
|
|
fprintf(Yap_stderr,"OOPS in GC: env size for %p is " UInt_FORMAT "\n", gc_ENV, (CELL)size);
|
|
#endif
|
|
mark_db_fixed((CELL *)gc_ENV[E_CP]);
|
|
/* for each saved variable */
|
|
if (size > EnvSizeInCells) {
|
|
int tsize = size - EnvSizeInCells;
|
|
|
|
currv = sizeof(CELL)*8-tsize%(sizeof(CELL)*8);
|
|
if (pvbmap != NULL) {
|
|
pvbmap += tsize/(sizeof(CELL)*8);
|
|
bmap = *pvbmap;
|
|
} else {
|
|
bmap = ((CELL)-1);
|
|
}
|
|
bmap = (Int)(((CELL)bmap) << currv);
|
|
}
|
|
|
|
for (saved_var = gc_ENV - size; saved_var < gc_ENV - EnvSizeInCells; saved_var++) {
|
|
if (currv == sizeof(CELL)*8) {
|
|
if (pvbmap) {
|
|
pvbmap--;
|
|
bmap = *pvbmap;
|
|
} else {
|
|
bmap = ((CELL)-1);
|
|
}
|
|
currv = 0;
|
|
}
|
|
/* we may have already been here */
|
|
if (bmap < 0 && !MARKED_PTR(saved_var)) {
|
|
#ifdef INSTRUMENT_GC
|
|
Term ccur = *saved_var;
|
|
|
|
if (IsVarTerm(ccur)) {
|
|
int len = 1;
|
|
CELL *mynext= GET_NEXT(ccur);
|
|
|
|
if (ONHEAP(mynext)) {
|
|
env_vars++;
|
|
while(ONHEAP(mynext) && IsVarTerm(*mynext)) {
|
|
CELL *prox = GET_NEXT(*mynext);
|
|
if (prox == mynext) {
|
|
chain[0]++;
|
|
break;
|
|
}
|
|
len++;
|
|
mynext = prox;
|
|
}
|
|
if (len>=15) {
|
|
(chain[15])++;
|
|
} else {
|
|
(chain[len])++;
|
|
}
|
|
}
|
|
}
|
|
#endif
|
|
mark_external_reference(saved_var);
|
|
}
|
|
bmap <<= 1;
|
|
currv++;
|
|
}
|
|
/* have we met this environment before?? */
|
|
/* we use the B field in the environment to tell whether we have
|
|
been here before or not.
|
|
|
|
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_PTR(gc_ENV+E_CB))
|
|
return;
|
|
MARK(gc_ENV+E_CB);
|
|
|
|
size = EnvSize((yamop *) (gc_ENV[E_CP])); /* size = EnvSize(CP) */
|
|
pvbmap = EnvBMap((yamop *) (gc_ENV[E_CP]));
|
|
#if 0
|
|
if (size < 0) {
|
|
PredEntry *pe = EnvPreg(gc_ENV[E_CP]);
|
|
op_numbers op = Yap_op_from_opcode(ENV_ToOp(gc_ENV[E_CP]));
|
|
#if defined(ANALYST) || defined(DEBUG)
|
|
fprintf(Yap_stderr,"ENV %p-%p(%d) %s\n", gc_ENV, pvbmap, size-EnvSizeInCells, Yap_op_names[op]);
|
|
#else
|
|
fprintf(Yap_stderr,"ENV %p-%p(%d) %d\n", gc_ENV, pvbmap, size-EnvSizeInCells, (int)op);
|
|
#endif
|
|
if (pe->ArityOfPE)
|
|
fprintf(Yap_stderr," %s/%d\n", RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE);
|
|
else
|
|
fprintf(Yap_stderr," %s\n", RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE);
|
|
}
|
|
#endif
|
|
gc_ENV = (CELL_PTR) gc_ENV[E_E]; /* link to prev
|
|
* environment */
|
|
}
|
|
}
|
|
|
|
/*
|
|
Cleaning the trail should be quick and simple, right? Well, not
|
|
really :-(. The problem is that the trail includes a dumping ground
|
|
of the WAM registers and of extra choice-point fields, which need
|
|
to be cleaned from somewhere.
|
|
|
|
And cleaning the trail itself is not easy. The problem is that we
|
|
may not have cleaned the trail after cuts. If we naively followed
|
|
these pointers, we could have direct references to the global
|
|
stack! A solution is to verify whether we are poiting at a
|
|
legitimate trail entry. Unfortunately this requires some extra work
|
|
following choice-points.
|
|
|
|
*/
|
|
|
|
|
|
static void
|
|
mark_trail(tr_fr_ptr trail_ptr, tr_fr_ptr trail_base, CELL *gc_H, choiceptr gc_B)
|
|
{
|
|
#ifdef EASY_SHUNTING
|
|
tr_fr_ptr begsTR = NULL, endsTR = NULL;
|
|
tr_fr_ptr OldsTR0 = sTR0;
|
|
#endif
|
|
#ifdef COROUTINING
|
|
CELL *detatt = NULL;
|
|
#endif
|
|
cont *old_cont_top0 = cont_top0;
|
|
|
|
|
|
GC_NEW_MAHASH((gc_ma_hash_entry *)cont_top0);
|
|
while (trail_base < trail_ptr) {
|
|
register CELL trail_cell;
|
|
|
|
trail_cell = TrailTerm(trail_base);
|
|
if (IsVarTerm(trail_cell)) {
|
|
CELL *hp = (CELL *)trail_cell;
|
|
/* if a variable older than the current CP has not been marked yet,
|
|
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_PTR(hp)) {
|
|
/* perform early reset */
|
|
/* reset term to be a variable */
|
|
RESET_VARIABLE(hp);
|
|
discard_trail_entries++;
|
|
RESET_VARIABLE(&TrailTerm(trail_base));
|
|
#ifdef FROZEN_STACKS
|
|
RESET_VARIABLE(&TrailVal(trail_base));
|
|
#endif
|
|
} else if (hp < (CELL *)Yap_GlobalBase || hp > (CELL *)Yap_TrailTop) {
|
|
/* pointers from the Heap back into the trail are process in mark_regs. */
|
|
/* do nothing !!! */
|
|
} else if ((hp < (CELL *)gc_B && hp >= gc_H) || hp > (CELL *)Yap_TrailBase) {
|
|
/* clean the trail, avoid dangling pointers! */
|
|
RESET_VARIABLE(&TrailTerm(trail_base));
|
|
#ifdef FROZEN_STACKS
|
|
RESET_VARIABLE(&TrailVal(trail_base));
|
|
#endif
|
|
discard_trail_entries++;
|
|
} else {
|
|
if (trail_cell == (CELL)trail_base)
|
|
discard_trail_entries++;
|
|
else {
|
|
/* This is a bit of a mess: when I find an attributed variable that was bound
|
|
nondeterministically, I know that after backtracking it will be back to be an unbound variable.
|
|
The ideal solution would be to unbind all variables. The current solution is to
|
|
remark it as an attributed variable */
|
|
if (IN_BETWEEN(Yap_GlobalBase,hp,H) && IsAttVar(hp) && !UNMARKED_MARK(hp-1,Yap_bp)) {
|
|
total_marked++;
|
|
PUSH_POINTER(hp-1);
|
|
if (hp-1 < HGEN) {
|
|
total_oldies++;
|
|
}
|
|
mark_variable(hp+1);
|
|
mark_variable(hp+2);
|
|
}
|
|
#ifdef FROZEN_STACKS
|
|
mark_external_reference(&TrailVal(trail_base));
|
|
#endif
|
|
}
|
|
#ifdef EASY_SHUNTING
|
|
if (hp < gc_H && hp >= H0 && !MARKED_PTR(hp)) {
|
|
tr_fr_ptr nsTR = (tr_fr_ptr)cont_top0;
|
|
CELL *cptr = (CELL *)trail_cell;
|
|
|
|
if ((ADDR)nsTR > Yap_TrailTop-1024) {
|
|
gc_growtrail(TRUE, begsTR, old_cont_top0);
|
|
}
|
|
TrailTerm(nsTR) = (CELL)NULL;
|
|
TrailTerm(nsTR+1) = *hp;
|
|
TrailTerm(nsTR+2) = trail_cell;
|
|
if (begsTR == NULL)
|
|
begsTR = nsTR;
|
|
else
|
|
TrailTerm(endsTR) = (CELL)nsTR;
|
|
endsTR = nsTR;
|
|
cont_top = (cont *)(nsTR+3);
|
|
sTR = (tr_fr_ptr)cont_top;
|
|
gc_ma_h_top = (gc_ma_hash_entry *)(nsTR+3);
|
|
RESET_VARIABLE(cptr);
|
|
MARK(cptr);
|
|
}
|
|
#endif
|
|
}
|
|
} else if (IsPairTerm(trail_cell)) {
|
|
/* can safely ignore this */
|
|
CELL *cptr = RepPair(trail_cell);
|
|
if (IN_BETWEEN(Yap_GlobalBase,cptr,H) &&
|
|
IsAttVar(cptr)) {
|
|
TrailTerm(trail_base) = (CELL)cptr;
|
|
mark_external_reference(&TrailTerm(trail_base));
|
|
TrailTerm(trail_base) = trail_cell;
|
|
}
|
|
}
|
|
#if MULTI_ASSIGNMENT_VARIABLES
|
|
else {
|
|
CELL *cptr = RepAppl(trail_cell);
|
|
/* This is a bit complex. The idea is that we may have several
|
|
trailings for the same mavar in the same trail segment. Essentially,
|
|
the problem arises because of !. What we want is to ignore all but
|
|
the last entry, or in this case, all but the first entry with the last
|
|
value.
|
|
|
|
*/
|
|
if (cptr < (CELL *)gc_B && cptr >= gc_H) {
|
|
goto remove_trash_entry;
|
|
} else if (IsAttVar(cptr)) {
|
|
/* MABINDING that should be recovered */
|
|
if (detatt && cptr < detatt) {
|
|
goto remove_trash_entry;
|
|
} else {
|
|
/* This attributed variable is still in play */
|
|
mark_variable(cptr);
|
|
}
|
|
}
|
|
if (!gc_lookup_ma_var(cptr, trail_base)) {
|
|
/* check whether this is the first time we see it*/
|
|
Term t0 = TrailTerm(trail_base+1);
|
|
|
|
if (!IsAtomicTerm(t0)) {
|
|
CELL *next = GET_NEXT(t0);
|
|
/* check if we have a garbage entry, where we are setting a
|
|
pointer to ourselves. */
|
|
if (next < (CELL *)gc_B && next >= gc_H) {
|
|
goto remove_trash_entry;
|
|
}
|
|
}
|
|
if (HEAP_PTR(trail_cell)) {
|
|
/* fool the gc into thinking this is a variable */
|
|
TrailTerm(trail_base) = (CELL)cptr;
|
|
mark_external_reference(&(TrailTerm(trail_base)));
|
|
/* reset the gc to believe the original tag */
|
|
TrailTerm(trail_base) = AbsAppl((CELL *)TrailTerm(trail_base));
|
|
}
|
|
#ifdef FROZEN_STACKS
|
|
mark_external_reference(&(TrailVal(trail_base)));
|
|
trail_base++;
|
|
if (HEAP_PTR(trail_cell)) {
|
|
TrailTerm(trail_base) = (CELL)cptr;
|
|
mark_external_reference(&(TrailTerm(trail_base)));
|
|
/* reset the gc to believe the original tag */
|
|
TrailTerm(trail_base) = AbsAppl((CELL *)TrailTerm(trail_base));
|
|
}
|
|
/* don't need to mark the next TrailVal, this is done at the end
|
|
of segment */
|
|
#else
|
|
trail_base++;
|
|
mark_external_reference(&(TrailTerm(trail_base)));
|
|
trail_base ++;
|
|
if (HEAP_PTR(trail_cell)) {
|
|
/* fool the gc into thinking this is a variable */
|
|
TrailTerm(trail_base) = (CELL)cptr;
|
|
mark_external_reference(&(TrailTerm(trail_base)));
|
|
/* reset the gc to believe the original tag */
|
|
TrailTerm(trail_base) = AbsAppl((CELL *)TrailTerm(trail_base));
|
|
}
|
|
#endif /* TABLING */
|
|
} else {
|
|
remove_trash_entry:
|
|
/* we can safely ignore this little monster */
|
|
#ifdef FROZEN_STACKS
|
|
discard_trail_entries += 2;
|
|
RESET_VARIABLE(&TrailTerm(trail_base));
|
|
RESET_VARIABLE(&TrailVal(trail_base));
|
|
#else
|
|
discard_trail_entries += 3;
|
|
RESET_VARIABLE(&TrailTerm(trail_base));
|
|
trail_base++;
|
|
RESET_VARIABLE(&TrailTerm(trail_base));
|
|
#endif
|
|
trail_base++;
|
|
RESET_VARIABLE(&TrailTerm(trail_base));
|
|
#ifdef FROZEN_STACKS
|
|
RESET_VARIABLE(&TrailVal(trail_base));
|
|
#endif
|
|
}
|
|
}
|
|
#endif
|
|
trail_base++;
|
|
}
|
|
#if TABLING
|
|
/*
|
|
Ugly, but needed: we're not really sure about what were the new
|
|
values until the very end
|
|
*/
|
|
{
|
|
gc_ma_hash_entry *gl = gc_ma_h_list;
|
|
while (gl) {
|
|
mark_external_reference(&(TrailVal(gl->loc+1)));
|
|
gl = gl->more;
|
|
}
|
|
}
|
|
#endif /* TABLING */
|
|
#ifdef EASY_SHUNTING
|
|
/* set back old variables */
|
|
sTR = (tr_fr_ptr)old_cont_top0;
|
|
while (begsTR != NULL) {
|
|
tr_fr_ptr newsTR = (tr_fr_ptr)TrailTerm(begsTR);
|
|
TrailTerm(sTR) = TrailTerm(begsTR+1);
|
|
TrailTerm(sTR+1) = TrailTerm(begsTR+2);
|
|
begsTR = newsTR;
|
|
sTR += 2;
|
|
}
|
|
sTR0 = OldsTR0;
|
|
#else
|
|
cont_top0 = old_cont_top0;
|
|
#endif
|
|
cont_top = cont_top0;
|
|
}
|
|
|
|
/*
|
|
* mark all heap objects accessible from each choicepoint & its chain of
|
|
* environments
|
|
*/
|
|
|
|
#ifdef TABLING
|
|
#define init_substitution_pointer(GCB, SUBS_PTR, DEP_FR) \
|
|
if (DepFr_leader_cp(DEP_FR) == GCB) { \
|
|
/* GCB is a generator-consumer node */ \
|
|
/* never here if batched scheduling */ \
|
|
SUBS_PTR = (CELL *) (GEN_CP(GCB) + 1); \
|
|
SUBS_PTR += SgFr_arity(GEN_CP(GCB)->cp_sg_fr); \
|
|
} else { \
|
|
SUBS_PTR = (CELL *) (CONS_CP(GCB) + 1); \
|
|
}
|
|
#endif /* TABLING */
|
|
|
|
|
|
static void
|
|
mark_slots(void)
|
|
{
|
|
Int curslot = CurSlot;
|
|
while (curslot) {
|
|
CELL *ptr = LCL0-curslot;
|
|
Int ns = IntegerOfTerm(*ptr);
|
|
|
|
ptr++;
|
|
while (ns > 0) {
|
|
// Yap_DebugPlWrite(ptr);
|
|
//fprintf(stderr,"\n");
|
|
mark_external_reference(ptr);
|
|
ptr++;
|
|
ns--;
|
|
}
|
|
curslot = IntegerOfTerm(*ptr);
|
|
}
|
|
}
|
|
|
|
|
|
#ifdef TABLING
|
|
static choiceptr
|
|
youngest_cp(choiceptr gc_B, dep_fr_ptr *depfrp)
|
|
{
|
|
dep_fr_ptr depfr = *depfrp;
|
|
choiceptr min = gc_B;
|
|
|
|
if (!gc_B) {
|
|
return gc_B;
|
|
}
|
|
if (depfr && min > DepFr_cons_cp(depfr)) {
|
|
min = DepFr_cons_cp(depfr);
|
|
}
|
|
if (depfr && min == DepFr_cons_cp(depfr)) {
|
|
*depfrp = DepFr_next(depfr);
|
|
}
|
|
return min;
|
|
}
|
|
#endif /* TABLING */
|
|
|
|
|
|
static void
|
|
mark_choicepoints(register choiceptr gc_B, tr_fr_ptr saved_TR, int very_verbose)
|
|
{
|
|
OPCODE
|
|
trust_lu = Yap_opcode(_trust_logical),
|
|
count_trust_lu = Yap_opcode(_count_trust_logical),
|
|
profiled_trust_lu = Yap_opcode(_profiled_trust_logical);
|
|
|
|
yamop *lu_cl0 = NEXTOP(PredLogUpdClause0->CodeOfPred,Otapl),
|
|
*lu_cl = NEXTOP(PredLogUpdClause->CodeOfPred,Otapl),
|
|
*lu_cle = NEXTOP(PredLogUpdClauseErase->CodeOfPred,Otapl),
|
|
*su_cl = NEXTOP(PredStaticClause->CodeOfPred,Otapl);
|
|
#ifdef TABLING
|
|
dep_fr_ptr depfr = LOCAL_top_dep_fr;
|
|
sg_fr_ptr aux_sg_fr = LOCAL_top_sg_fr;
|
|
#endif /* TABLING */
|
|
|
|
#ifdef TABLING
|
|
gc_B = youngest_cp(gc_B, &depfr);
|
|
#endif /* TABLING */
|
|
while (gc_B != NULL) {
|
|
op_numbers opnum;
|
|
register OPCODE op;
|
|
yamop *rtp = gc_B->cp_ap;
|
|
|
|
mark_db_fixed((CELL *)rtp);
|
|
#ifdef DETERMINISTIC_TABLING
|
|
if (!IS_DET_GEN_CP(gc_B))
|
|
#endif /* DETERMINISTIC_TABLING */
|
|
mark_db_fixed((CELL *)(gc_B->cp_cp));
|
|
#ifdef EASY_SHUNTING
|
|
current_B = gc_B;
|
|
prev_HB = HB;
|
|
#endif
|
|
HB = gc_B->cp_h;
|
|
#ifdef INSTRUMENT_GC
|
|
num_bs++;
|
|
#endif
|
|
#ifdef TABLING
|
|
if (rtp == NULL) {
|
|
if (aux_sg_fr && gc_B == SgFr_gen_cp(aux_sg_fr)) {
|
|
/* found generator */
|
|
opnum = _table_completion;
|
|
} else {
|
|
/* found sld node is done */
|
|
opnum = _trust_fail;
|
|
}
|
|
} else {
|
|
#endif /* TABLING */
|
|
op = rtp->opc;
|
|
opnum = Yap_op_from_opcode(op);
|
|
#ifdef TABLING
|
|
}
|
|
if (aux_sg_fr && gc_B == SgFr_gen_cp(aux_sg_fr)) {
|
|
aux_sg_fr = SgFr_next(aux_sg_fr);
|
|
}
|
|
#endif /* TABLING */
|
|
if (very_verbose) {
|
|
PredEntry *pe = Yap_PredForChoicePt(gc_B);
|
|
#if defined(ANALYST) || defined(DEBUG)
|
|
if (pe == NULL) {
|
|
fprintf(Yap_stderr,"%% marked %ld (%s)\n", total_marked, Yap_op_names[opnum]);
|
|
} else if (pe->ArityOfPE) {
|
|
fprintf(Yap_stderr,"%% %s/%d marked %ld (%s)\n", RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, total_marked, Yap_op_names[opnum]);
|
|
} else {
|
|
fprintf(Yap_stderr,"%% %s marked %ld (%s)\n", RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, total_marked, Yap_op_names[opnum]);
|
|
}
|
|
#else
|
|
if (pe == NULL) {
|
|
fprintf(Yap_stderr,"%% marked %ld (%u)\n", total_marked, (unsigned int)opnum);
|
|
} else if (pe->ArityOfPE) {
|
|
fprintf(Yap_stderr,"%% %s/%d marked %ld (%u)\n", RepAtom(NameOfFunctor(pe->FunctorOfPred))->StrOfAE, pe->ArityOfPE, total_marked, (unsigned int)opnum);
|
|
} else {
|
|
fprintf(Yap_stderr,"%% %s marked %ld (%u)\n", RepAtom((Atom)(pe->FunctorOfPred))->StrOfAE, total_marked, (unsigned int)opnum);
|
|
}
|
|
#endif
|
|
}
|
|
{
|
|
/* find out how many cells are still alive in the trail */
|
|
mark_trail(saved_TR, gc_B->cp_tr, gc_B->cp_h, gc_B);
|
|
saved_TR = gc_B->cp_tr;
|
|
}
|
|
if (opnum == _or_else || opnum == _or_last) {
|
|
/* ; choice point */
|
|
mark_environments((CELL_PTR) (gc_B->cp_a1),
|
|
-gc_B->cp_cp->u.Osblp.s / ((OPREG)sizeof(CELL)),
|
|
gc_B->cp_cp->u.Osblp.bmap
|
|
);
|
|
} else {
|
|
/* choicepoint with arguments */
|
|
register CELL_PTR saved_reg;
|
|
OPREG nargs;
|
|
|
|
if (opnum == _Nstop)
|
|
mark_environments((CELL_PTR) gc_B->cp_env,
|
|
EnvSizeInCells,
|
|
NULL);
|
|
else if (opnum != _trust_fail)
|
|
#ifdef DETERMINISTIC_TABLING
|
|
if (!IS_DET_GEN_CP(gc_B))
|
|
#endif /* DETERMINISTIC_TABLING */
|
|
mark_environments((CELL_PTR) gc_B->cp_env,
|
|
EnvSize((yamop *) (gc_B->cp_cp)),
|
|
EnvBMap((yamop *) (gc_B->cp_cp)));
|
|
/* extended choice point */
|
|
restart_cp:
|
|
switch (opnum) {
|
|
case _Nstop:
|
|
if (gc_B->cp_b != NULL) {
|
|
nargs = 0;
|
|
break;
|
|
} else {
|
|
/* this is the last choice point, the work is done ;-) */
|
|
return;
|
|
}
|
|
case _retry_c:
|
|
case _retry_userc:
|
|
if (gc_B->cp_ap == RETRY_C_RECORDED_K_CODE
|
|
|| gc_B->cp_ap == RETRY_C_RECORDEDP_CODE) {
|
|
/* we have a reference from the choice-point stack to a term */
|
|
choiceptr old_b = B;
|
|
DBRef ref;
|
|
B = gc_B;
|
|
ref = (DBRef)EXTRA_CBACK_ARG(3,1);
|
|
if (IsVarTerm((CELL)ref)) {
|
|
mark_ref_in_use(ref);
|
|
} else {
|
|
if (ONCODE((CELL)ref)) {
|
|
mark_db_fixed(RepAppl((CELL)ref));
|
|
}
|
|
}
|
|
B = old_b;
|
|
}
|
|
nargs = rtp->u.OtapFs.s+rtp->u.OtapFs.extra;
|
|
break;
|
|
case _jump:
|
|
rtp = rtp->u.l.l;
|
|
op = rtp->opc;
|
|
opnum = Yap_op_from_opcode(op);
|
|
goto restart_cp;
|
|
case _retry_profiled:
|
|
case _count_retry:
|
|
rtp = NEXTOP(rtp,l);
|
|
op = rtp->opc;
|
|
opnum = Yap_op_from_opcode(op);
|
|
goto restart_cp;
|
|
case _trust_fail:
|
|
nargs = 0;
|
|
break;
|
|
#ifdef TABLING
|
|
case _table_load_answer:
|
|
{
|
|
CELL *vars_ptr, vars;
|
|
vars_ptr = (CELL *) (LOAD_CP(gc_B) + 1);
|
|
vars = *vars_ptr++;
|
|
while (vars--) {
|
|
mark_external_reference(vars_ptr);
|
|
vars_ptr++;
|
|
}
|
|
}
|
|
nargs = 0;
|
|
break;
|
|
case _table_try_answer:
|
|
case _table_retry_me:
|
|
case _table_trust_me:
|
|
case _table_retry:
|
|
case _table_trust:
|
|
{
|
|
CELL *vars_ptr, vars;
|
|
vars_ptr = (CELL *)(GEN_CP(gc_B) + 1);
|
|
nargs = rtp->u.Otapl.s;
|
|
while (nargs--) {
|
|
mark_external_reference(vars_ptr);
|
|
vars_ptr++;
|
|
}
|
|
vars = *vars_ptr++;
|
|
while (vars--) {
|
|
mark_external_reference(vars_ptr);
|
|
vars_ptr++;
|
|
}
|
|
}
|
|
nargs = 0;
|
|
break;
|
|
case _table_completion:
|
|
{
|
|
CELL *vars_ptr, vars;
|
|
#ifdef DETERMINISTIC_TABLING
|
|
if (IS_DET_GEN_CP(gc_B))
|
|
vars_ptr = (CELL *)(DET_GEN_CP(gc_B) + 1);
|
|
else
|
|
#endif /* DETERMINISTIC_TABLING */
|
|
{
|
|
vars_ptr = (CELL *)(GEN_CP(gc_B) + 1);
|
|
nargs = SgFr_arity(GEN_CP(gc_B)->cp_sg_fr);
|
|
while (nargs--) {
|
|
mark_external_reference(vars_ptr);
|
|
vars_ptr++;
|
|
}
|
|
}
|
|
vars = *vars_ptr++;
|
|
while (vars--) {
|
|
mark_external_reference(vars_ptr);
|
|
vars_ptr++;
|
|
}
|
|
}
|
|
nargs = 0;
|
|
break;
|
|
case _table_answer_resolution:
|
|
{
|
|
CELL *vars_ptr, vars;
|
|
init_substitution_pointer(gc_B, vars_ptr, CONS_CP(gc_B)->cp_dep_fr);
|
|
vars = *vars_ptr++;
|
|
while (vars--) {
|
|
mark_external_reference(vars_ptr);
|
|
vars_ptr++;
|
|
}
|
|
}
|
|
nargs = 0;
|
|
break;
|
|
case _trie_trust_var:
|
|
case _trie_retry_var:
|
|
case _trie_trust_var_in_pair:
|
|
case _trie_retry_var_in_pair:
|
|
case _trie_trust_val:
|
|
case _trie_retry_val:
|
|
case _trie_trust_val_in_pair:
|
|
case _trie_retry_val_in_pair:
|
|
case _trie_trust_atom:
|
|
case _trie_retry_atom:
|
|
case _trie_trust_atom_in_pair:
|
|
case _trie_retry_atom_in_pair:
|
|
case _trie_trust_null:
|
|
case _trie_retry_null:
|
|
case _trie_trust_null_in_pair:
|
|
case _trie_retry_null_in_pair:
|
|
case _trie_trust_pair:
|
|
case _trie_retry_pair:
|
|
case _trie_trust_appl:
|
|
case _trie_retry_appl:
|
|
case _trie_trust_appl_in_pair:
|
|
case _trie_retry_appl_in_pair:
|
|
case _trie_trust_extension:
|
|
case _trie_retry_extension:
|
|
case _trie_trust_double:
|
|
case _trie_retry_double:
|
|
case _trie_trust_longint:
|
|
case _trie_retry_longint:
|
|
case _trie_trust_gterm:
|
|
case _trie_retry_gterm:
|
|
{
|
|
CELL *vars_ptr;
|
|
int heap_arity, vars_arity, subs_arity;
|
|
vars_ptr = (CELL *)(gc_B + 1);
|
|
heap_arity = vars_ptr[0];
|
|
vars_arity = vars_ptr[1 + heap_arity];
|
|
subs_arity = vars_ptr[2 + heap_arity + vars_arity];
|
|
vars_ptr += 2 + heap_arity + subs_arity + vars_arity;
|
|
if (subs_arity) {
|
|
while (subs_arity--) {
|
|
mark_external_reference(vars_ptr);
|
|
vars_ptr--;
|
|
}
|
|
}
|
|
vars_ptr--; /* skip subs_arity entry */
|
|
if (vars_arity) {
|
|
while (vars_arity--) {
|
|
mark_external_reference(vars_ptr);
|
|
vars_ptr--;
|
|
}
|
|
}
|
|
vars_ptr--; /* skip vars_arity entry */
|
|
if (heap_arity) {
|
|
while (heap_arity--) {
|
|
if (*vars_ptr == 0) /* double/longint extension mark */
|
|
break;
|
|
mark_external_reference(vars_ptr);
|
|
vars_ptr--;
|
|
}
|
|
}
|
|
}
|
|
nargs = 0;
|
|
break;
|
|
#endif /* TABLING */
|
|
case _profiled_retry_and_mark:
|
|
case _count_retry_and_mark:
|
|
case _retry_and_mark:
|
|
mark_ref_in_use((DBRef)ClauseCodeToDynamicClause(gc_B->cp_ap));
|
|
case _retry2:
|
|
nargs = 2;
|
|
break;
|
|
case _retry3:
|
|
nargs = 3;
|
|
break;
|
|
case _retry4:
|
|
nargs = 4;
|
|
break;
|
|
case _try_logical:
|
|
case _retry_logical:
|
|
{
|
|
/* find out who owns this sequence of try-retry-trust */
|
|
/* I don't like this code, it's a bad idea to do a linear scan,
|
|
on the other hand it's the only way we can be sure we can reclaim
|
|
space
|
|
*/
|
|
yamop *end = rtp->u.OtaLl.n;
|
|
while (end->opc != trust_lu &&
|
|
end->opc != count_trust_lu &&
|
|
end->opc != profiled_trust_lu )
|
|
end = end->u.OtaLl.n;
|
|
mark_ref_in_use((DBRef)end->u.OtILl.block);
|
|
}
|
|
/* mark timestamp */
|
|
nargs = rtp->u.OtaLl.s+1;
|
|
break;
|
|
case _count_retry_logical:
|
|
{
|
|
/* find out who owns this sequence of try-retry-trust */
|
|
/* I don't like this code, it's a bad idea to do a linear scan,
|
|
on the other hand it's the only way we can be sure we can reclaim
|
|
space
|
|
*/
|
|
yamop *end = rtp->u.OtaLl.n;
|
|
while (Yap_op_from_opcode(end->opc) != _count_trust_logical)
|
|
end = end->u.OtaLl.n;
|
|
mark_ref_in_use((DBRef)end->u.OtILl.block);
|
|
}
|
|
/* mark timestamp */
|
|
nargs = rtp->u.OtaLl.s+1;
|
|
break;
|
|
case _profiled_retry_logical:
|
|
{
|
|
/* find out who owns this sequence of try-retry-trust */
|
|
/* I don't like this code, it's a bad idea to do a linear scan,
|
|
on the other hand it's the only way we can be sure we can reclaim
|
|
space
|
|
*/
|
|
yamop *end = rtp->u.OtaLl.n;
|
|
while (Yap_op_from_opcode(end->opc) != _profiled_trust_logical)
|
|
end = end->u.OtaLl.n;
|
|
mark_ref_in_use((DBRef)end->u.OtILl.block);
|
|
}
|
|
/* mark timestamp */
|
|
nargs = rtp->u.OtaLl.s+1;
|
|
break;
|
|
case _trust_logical:
|
|
case _count_trust_logical:
|
|
case _profiled_trust_logical:
|
|
/* mark timestamp */
|
|
mark_ref_in_use((DBRef)rtp->u.OtILl.block);
|
|
nargs = rtp->u.OtILl.d->ClPred->ArityOfPE+1;
|
|
break;
|
|
#ifdef DEBUG
|
|
case _retry_me:
|
|
case _trust_me:
|
|
case _profiled_retry_me:
|
|
case _profiled_trust_me:
|
|
case _count_retry_me:
|
|
case _count_trust_me:
|
|
case _retry:
|
|
case _trust:
|
|
if (IN_BETWEEN(H0,(CELL *)(gc_B->cp_ap),H)) {
|
|
fprintf(stderr,"OOPS in GC: gc not supported in this case!!!\n");
|
|
exit(1);
|
|
}
|
|
nargs = rtp->u.Otapl.s;
|
|
break;
|
|
default:
|
|
fprintf(Yap_stderr, "OOPS in GC: Unexpected opcode: %d\n", opnum);
|
|
nargs = 0;
|
|
#else
|
|
default:
|
|
nargs = rtp->u.Otapl.s;
|
|
#endif
|
|
}
|
|
|
|
|
|
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) {
|
|
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->opc != count_trust_lu &&
|
|
pt->opc != profiled_trust_lu
|
|
)
|
|
pt = pt->u.OtaLl.n;
|
|
mark_ref_in_use((DBRef)pt->u.OtILl.block);
|
|
}
|
|
}
|
|
/* for each saved register */
|
|
for (saved_reg = &gc_B->cp_a1;
|
|
/* assumes we can count registers in CP this
|
|
way */
|
|
saved_reg < &gc_B->cp_a1 + nargs;
|
|
saved_reg++) {
|
|
mark_external_reference(saved_reg);
|
|
}
|
|
}
|
|
#if TABLING
|
|
gc_B = youngest_cp(gc_B->cp_b, &depfr);
|
|
#else
|
|
gc_B = gc_B->cp_b;
|
|
#endif /* TABLING */
|
|
}
|
|
}
|
|
|
|
|
|
|
|
|
|
/*
|
|
* insert a cell which points to a heap object into relocation chain of that
|
|
* object
|
|
*/
|
|
|
|
static inline void
|
|
into_relocation_chain(CELL_PTR current, CELL_PTR next)
|
|
{
|
|
CELL current_tag;
|
|
|
|
current_tag = TAG(*current);
|
|
if (RMARKED(next))
|
|
RMARK(current);
|
|
else {
|
|
UNRMARK(current);
|
|
RMARK(next);
|
|
}
|
|
*current = *next;
|
|
*next = (CELL) current | current_tag;
|
|
}
|
|
|
|
|
|
static void
|
|
CleanDeadClauses(void)
|
|
{
|
|
{
|
|
StaticClause **cptr;
|
|
StaticClause *cl;
|
|
|
|
cptr = &(DeadStaticClauses);
|
|
cl = DeadStaticClauses;
|
|
while (cl) {
|
|
if (!ref_in_use((DBRef)cl)) {
|
|
char *ocl = (char *)cl;
|
|
Yap_ClauseSpace -= cl->ClSize;
|
|
cl = cl->ClNext;
|
|
*cptr = cl;
|
|
Yap_FreeCodeSpace(ocl);
|
|
} else {
|
|
cptr = &(cl->ClNext);
|
|
cl = cl->ClNext;
|
|
}
|
|
}
|
|
}
|
|
{
|
|
StaticIndex **cptr;
|
|
StaticIndex *cl;
|
|
|
|
cptr = &(DeadStaticIndices);
|
|
cl = DeadStaticIndices;
|
|
while (cl) {
|
|
if (!ref_in_use((DBRef)cl)) {
|
|
char *ocl = (char *)cl;
|
|
if (cl->ClFlags & SwitchTableMask)
|
|
Yap_IndexSpace_SW -= cl->ClSize;
|
|
else
|
|
Yap_IndexSpace_Tree -= cl->ClSize;
|
|
cl = cl->SiblingIndex;
|
|
*cptr = cl;
|
|
Yap_FreeCodeSpace(ocl);
|
|
} else {
|
|
cptr = &(cl->SiblingIndex);
|
|
cl = cl->SiblingIndex;
|
|
}
|
|
}
|
|
}
|
|
{
|
|
MegaClause **cptr;
|
|
MegaClause *cl;
|
|
|
|
cptr = &(DeadMegaClauses);
|
|
cl = DeadMegaClauses;
|
|
while (cl) {
|
|
if (!ref_in_use((DBRef)cl)) {
|
|
char *ocl = (char *)cl;
|
|
Yap_ClauseSpace -= cl->ClSize;
|
|
cl = cl->ClNext;
|
|
*cptr = cl;
|
|
Yap_FreeCodeSpace(ocl);
|
|
} else {
|
|
cptr = &(cl->ClNext);
|
|
cl = cl->ClNext;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
/* insert trail cells which point to heap objects into relocation chains */
|
|
|
|
static void
|
|
sweep_trail(choiceptr gc_B, tr_fr_ptr old_TR)
|
|
{
|
|
tr_fr_ptr trail_ptr, dest;
|
|
Int OldHeapUsed = HeapUsed;
|
|
#ifdef DEBUG
|
|
Int hp_entrs = 0, hp_erased = 0, hp_not_in_use = 0,
|
|
hp_in_use_erased = 0, code_entries = 0;
|
|
#endif
|
|
|
|
#ifndef FROZEN_STACKS
|
|
{
|
|
choiceptr current = gc_B;
|
|
choiceptr next = gc_B->cp_b;
|
|
tr_fr_ptr source, dest;
|
|
|
|
/* invert cp ptrs */
|
|
current->cp_b = NULL;
|
|
while (next) {
|
|
choiceptr n = next;
|
|
next = n->cp_b;
|
|
n->cp_b = current;
|
|
current = n;
|
|
}
|
|
|
|
next = current;
|
|
current = NULL;
|
|
/* next, clean trail */
|
|
source = dest = (tr_fr_ptr)Yap_TrailBase;
|
|
while (source < old_TR) {
|
|
CELL trail_cell;
|
|
|
|
while (next && source == next->cp_tr) {
|
|
choiceptr b = next;
|
|
b->cp_tr = dest;
|
|
next = b->cp_b;
|
|
b->cp_b = current;
|
|
current = b;
|
|
}
|
|
trail_cell = TrailTerm(source);
|
|
if (trail_cell != (CELL)source) {
|
|
dest++;
|
|
}
|
|
source++;
|
|
}
|
|
while (next) {
|
|
choiceptr b = next;
|
|
b->cp_tr = dest;
|
|
next = b->cp_b;
|
|
b->cp_b = current;
|
|
current = b;
|
|
}
|
|
}
|
|
#endif /* FROZEN_STACKS */
|
|
|
|
/* 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 (IN_BETWEEN(Yap_GlobalBase,TrailTerm(trail_ptr),Yap_TrailTop) &&
|
|
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)));
|
|
}
|
|
}
|
|
}
|
|
|
|
/* next, follows the real trail entries */
|
|
trail_ptr = (tr_fr_ptr)Yap_TrailBase;
|
|
dest = trail_ptr;
|
|
while (trail_ptr < old_TR) {
|
|
register CELL trail_cell;
|
|
|
|
trail_cell = TrailTerm(trail_ptr);
|
|
|
|
#ifndef FROZEN_STACKS
|
|
/* recover a trail cell */
|
|
if (trail_cell == (CELL)trail_ptr) {
|
|
TrailTerm(dest) = trail_cell;
|
|
trail_ptr++;
|
|
/* just skip cell */
|
|
} else
|
|
#endif
|
|
{
|
|
TrailTerm(dest) = trail_cell;
|
|
if (IsVarTerm(trail_cell)) {
|
|
/* we need to check whether this is a honest to god trail entry */
|
|
/* make sure it is a heap cell before we test whether it has been marked */
|
|
if ((CELL *)trail_cell < H && (CELL *)trail_cell >= H0 && MARKED_PTR((CELL *)trail_cell)) {
|
|
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_PTR(&TrailVal(dest))) {
|
|
if (HEAP_PTR(TrailVal(dest))) {
|
|
into_relocation_chain(&TrailVal(dest), GET_NEXT(TrailVal(dest)));
|
|
}
|
|
}
|
|
#endif
|
|
} else if (IsPairTerm(trail_cell)) {
|
|
CELL *pt0 = RepPair(trail_cell);
|
|
CELL flags;
|
|
|
|
if (IN_BETWEEN(Yap_GlobalBase, pt0, H) && IsAttVar(pt0)) {
|
|
TrailTerm(dest) = trail_cell;
|
|
/* be careful with partial gc */
|
|
if (HEAP_PTR(TrailTerm(dest))) {
|
|
into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell));
|
|
}
|
|
dest++;
|
|
trail_ptr++;
|
|
continue;
|
|
}
|
|
#ifdef FROZEN_STACKS /* TRAIL */
|
|
/* process all segments */
|
|
if (
|
|
#ifdef SBA
|
|
(ADDR) pt0 >= Yap_GlobalBase
|
|
#else
|
|
(ADDR) pt0 >= Yap_TrailBase
|
|
#endif
|
|
) {
|
|
trail_ptr++;
|
|
dest++;
|
|
continue;
|
|
}
|
|
#endif /* FROZEN_STACKS */
|
|
flags = *pt0;
|
|
#ifdef DEBUG
|
|
hp_entrs++;
|
|
if (!ref_in_use((DBRef)pt0)) {
|
|
hp_not_in_use++;
|
|
if (!FlagOn(DBClMask, flags)) {
|
|
code_entries++;
|
|
}
|
|
if (FlagOn(ErasedMask, flags)) {
|
|
hp_erased++;
|
|
}
|
|
} else {
|
|
if (FlagOn(ErasedMask, flags)) {
|
|
hp_in_use_erased++;
|
|
}
|
|
}
|
|
#endif
|
|
if (!ref_in_use((DBRef)pt0)) {
|
|
if (FlagOn(DBClMask, flags)) {
|
|
DBRef dbr = (DBRef) ((CELL)pt0 - (CELL) &(((DBRef) NIL)->Flags));
|
|
dbr->Flags &= ~InUseMask;
|
|
DEC_DBREF_COUNT(dbr);
|
|
if (dbr->Flags & ErasedMask) {
|
|
Yap_ErDBE(dbr);
|
|
}
|
|
} else {
|
|
if (flags & LogUpdMask) {
|
|
if (flags & IndexMask) {
|
|
LogUpdIndex *indx = ClauseFlagsToLogUpdIndex(pt0);
|
|
int erase;
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
/*
|
|
gc may be called when executing a dynamic goal,
|
|
check PP to avoid deadlock
|
|
*/
|
|
PredEntry *ap = indx->ClPred;
|
|
if (ap != PP)
|
|
PELOCK(85,ap);
|
|
#endif
|
|
DEC_CLREF_COUNT(indx);
|
|
indx->ClFlags &= ~InUseMask;
|
|
erase = (indx->ClFlags & ErasedMask
|
|
&& !indx->ClRefCount);
|
|
if (erase) {
|
|
/* at this point,
|
|
no one is accessing the clause */
|
|
Yap_ErLogUpdIndex(indx);
|
|
}
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (ap != PP)
|
|
UNLOCK(ap->PELock);
|
|
#endif
|
|
} else {
|
|
LogUpdClause *cl = ClauseFlagsToLogUpdClause(pt0);
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
PredEntry *ap = cl->ClPred;
|
|
#endif
|
|
int erase;
|
|
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (ap != PP)
|
|
PELOCK(86,ap);
|
|
#endif
|
|
DEC_CLREF_COUNT(cl);
|
|
cl->ClFlags &= ~InUseMask;
|
|
erase = ((cl->ClFlags & ErasedMask) && !cl->ClRefCount);
|
|
if (erase) {
|
|
/* at this point,
|
|
no one is accessing the clause */
|
|
Yap_ErLogUpdCl(cl);
|
|
}
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
if (ap != PP)
|
|
UNLOCK(ap->PELock);
|
|
#endif
|
|
}
|
|
} else {
|
|
DynamicClause *cl = ClauseFlagsToDynamicClause(pt0);
|
|
int erase;
|
|
DEC_CLREF_COUNT(cl);
|
|
cl->ClFlags &= ~InUseMask;
|
|
erase = (cl->ClFlags & ErasedMask)
|
|
#if defined(YAPOR) || defined(THREADS)
|
|
&& (cl->ClRefCount == 0)
|
|
#endif
|
|
;
|
|
if (erase) {
|
|
/* at this point,
|
|
no one is accessing the clause */
|
|
Yap_ErCl(cl);
|
|
}
|
|
}
|
|
}
|
|
RESET_VARIABLE(&TrailTerm(dest));
|
|
#ifdef FROZEN_STACKS
|
|
RESET_VARIABLE(&TrailVal(dest));
|
|
#endif
|
|
discard_trail_entries++;
|
|
}
|
|
#if MULTI_ASSIGNMENT_VARIABLES
|
|
} else {
|
|
#ifdef FROZEN_STACKS
|
|
CELL trail_cell = TrailTerm(trail_ptr+1);
|
|
CELL old = TrailVal(trail_ptr);
|
|
CELL old1 = TrailVal(trail_ptr+1);
|
|
Int marked_ptr = MARKED_PTR(&TrailTerm(trail_ptr+1));
|
|
Int marked_val_old = MARKED_PTR(&TrailVal(trail_ptr));
|
|
Int marked_val_ptr = MARKED_PTR(&TrailVal(trail_ptr+1));
|
|
|
|
TrailTerm(dest+1) = TrailTerm(dest) = trail_cell;
|
|
TrailVal(dest) = old;
|
|
TrailVal(dest+1) = old1;
|
|
if (marked_ptr) {
|
|
UNMARK(&TrailTerm(dest));
|
|
UNMARK(&TrailTerm(dest+1));
|
|
if (HEAP_PTR(trail_cell)) {
|
|
into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell));
|
|
into_relocation_chain(&TrailTerm(dest+1), GET_NEXT(trail_cell));
|
|
}
|
|
}
|
|
if (marked_val_old) {
|
|
UNMARK(&TrailVal(dest));
|
|
if (HEAP_PTR(old)) {
|
|
into_relocation_chain(&TrailVal(dest), GET_NEXT(old));
|
|
}
|
|
}
|
|
if (marked_val_ptr) {
|
|
UNMARK(&TrailVal(dest+1));
|
|
if (HEAP_PTR(old1)) {
|
|
into_relocation_chain(&TrailVal(dest+1), GET_NEXT(old1));
|
|
}
|
|
}
|
|
trail_ptr ++;
|
|
dest ++;
|
|
#else
|
|
CELL trail_cell = TrailTerm(trail_ptr+2);
|
|
CELL old = TrailTerm(trail_ptr+1);
|
|
Int marked_ptr = MARKED_PTR(&TrailTerm(trail_ptr+2));
|
|
Int marked_old = MARKED_PTR(&TrailTerm(trail_ptr+1));
|
|
CELL *ptr;
|
|
/* be sure we don't overwrite before we read */
|
|
|
|
if (marked_ptr)
|
|
ptr = RepAppl(UNMARK_CELL(trail_cell));
|
|
else
|
|
ptr = RepAppl(trail_cell);
|
|
|
|
TrailTerm(dest+1) = old;
|
|
if (marked_old) {
|
|
UNMARK(&TrailTerm(dest+1));
|
|
if (HEAP_PTR(old)) {
|
|
into_relocation_chain(&TrailTerm(dest+1), GET_NEXT(old));
|
|
}
|
|
}
|
|
TrailTerm(dest+2) = TrailTerm(dest) = trail_cell;
|
|
if (marked_ptr) {
|
|
UNMARK(&TrailTerm(dest));
|
|
UNMARK(&TrailTerm(dest+2));
|
|
if (HEAP_PTR(trail_cell)) {
|
|
into_relocation_chain(&TrailTerm(dest), GET_NEXT(trail_cell));
|
|
into_relocation_chain(&TrailTerm(dest+2), GET_NEXT(trail_cell));
|
|
}
|
|
}
|
|
trail_ptr += 2;
|
|
dest += 2;
|
|
#endif
|
|
#endif
|
|
}
|
|
trail_ptr++;
|
|
dest++;
|
|
}
|
|
}
|
|
new_TR = dest;
|
|
if (is_gc_verbose()) {
|
|
if (old_TR != (tr_fr_ptr)Yap_TrailBase)
|
|
fprintf(Yap_stderr,
|
|
"%% Trail: discarded %d (%ld%%) cells out of %ld\n",
|
|
discard_trail_entries,
|
|
(unsigned long int)(discard_trail_entries*100/(old_TR-(tr_fr_ptr)Yap_TrailBase)),
|
|
(unsigned long int)(old_TR-(tr_fr_ptr)Yap_TrailBase));
|
|
#ifdef DEBUG
|
|
if (hp_entrs > 0)
|
|
fprintf(Yap_stderr,
|
|
"%% Trail: unmarked %ld dbentries (%ld%%) out of %ld\n",
|
|
(long int)hp_not_in_use,
|
|
(long int)(hp_not_in_use*100/hp_entrs),
|
|
(long int)hp_entrs);
|
|
if (hp_in_use_erased > 0 && hp_erased > 0)
|
|
fprintf(Yap_stderr,
|
|
"%% Trail: deleted %ld dbentries (%ld%%) out of %ld\n",
|
|
(long int)hp_erased,
|
|
(long int)(hp_erased*100/(hp_erased+hp_in_use_erased)),
|
|
(long int)(hp_erased+hp_in_use_erased));
|
|
#endif
|
|
if (OldHeapUsed) {
|
|
fprintf(Yap_stderr,
|
|
"%% Heap: recovered %ld bytes (%ld%%) out of %ld\n",
|
|
(unsigned long int)(OldHeapUsed-HeapUsed),
|
|
(unsigned long int)((OldHeapUsed-HeapUsed)/(OldHeapUsed/100)),
|
|
(unsigned long int)OldHeapUsed);
|
|
}
|
|
}
|
|
CleanDeadClauses();
|
|
}
|
|
|
|
|
|
/*
|
|
* insert cells of a chain of environments which point to heap objects into
|
|
* relocation chains
|
|
*/
|
|
|
|
static void
|
|
sweep_environments(CELL_PTR gc_ENV, OPREG size, CELL *pvbmap)
|
|
{
|
|
CELL_PTR saved_var;
|
|
|
|
while (gc_ENV != NULL) { /* no more environments */
|
|
Int bmap = 0;
|
|
int currv = 0;
|
|
|
|
|
|
/* for each saved variable */
|
|
|
|
if (size > EnvSizeInCells) {
|
|
int tsize = size - EnvSizeInCells;
|
|
|
|
|
|
currv = sizeof(CELL)*8-tsize%(sizeof(CELL)*8);
|
|
if (pvbmap != NULL) {
|
|
pvbmap += tsize/(sizeof(CELL)*8);
|
|
bmap = *pvbmap;
|
|
} else {
|
|
bmap = ((CELL)-1);
|
|
}
|
|
bmap = (Int)(((CELL)bmap) << currv);
|
|
}
|
|
for (saved_var = gc_ENV - size; saved_var < gc_ENV - EnvSizeInCells; saved_var++) {
|
|
|
|
if (currv == sizeof(CELL)*8) {
|
|
if (pvbmap != NULL) {
|
|
pvbmap--;
|
|
bmap = *pvbmap;
|
|
} else {
|
|
bmap = ((CELL)-1);
|
|
}
|
|
currv = 0;
|
|
}
|
|
if (bmap < 0) {
|
|
CELL env_cell = *saved_var;
|
|
if (MARKED_PTR(saved_var)) {
|
|
UNMARK(saved_var);
|
|
if (HEAP_PTR(env_cell)) {
|
|
into_relocation_chain(saved_var, GET_NEXT(env_cell));
|
|
}
|
|
}
|
|
}
|
|
bmap <<= 1;
|
|
currv++;
|
|
}
|
|
/* have we met this environment before?? */
|
|
/* we use the B field in the environment to tell whether we have
|
|
been here before or not
|
|
*/
|
|
if (!MARKED_PTR(gc_ENV+E_CB))
|
|
return;
|
|
UNMARK(gc_ENV+E_CB);
|
|
|
|
size = EnvSize((yamop *) (gc_ENV[E_CP])); /* size = EnvSize(CP) */
|
|
pvbmap = EnvBMap((yamop *) (gc_ENV[E_CP]));
|
|
gc_ENV = (CELL_PTR) gc_ENV[E_E]; /* link to prev
|
|
* environment */
|
|
}
|
|
}
|
|
|
|
static void
|
|
sweep_slots(void)
|
|
{
|
|
Int curslot = CurSlot;
|
|
while (curslot) {
|
|
CELL *ptr = LCL0-curslot;
|
|
Int ns = IntOfTerm(*ptr);
|
|
ptr++;
|
|
while (ns > 0) {
|
|
CELL cp_cell = *ptr;
|
|
if (MARKED_PTR(ptr)) {
|
|
UNMARK(ptr);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(ptr, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
ptr++;
|
|
ns--;
|
|
}
|
|
curslot = IntegerOfTerm(*ptr);
|
|
}
|
|
}
|
|
|
|
static void
|
|
sweep_b(choiceptr gc_B, UInt arity)
|
|
{
|
|
register CELL_PTR saved_reg;
|
|
|
|
sweep_environments(gc_B->cp_env,
|
|
EnvSize((yamop *) (gc_B->cp_cp)),
|
|
EnvBMap((yamop *) (gc_B->cp_cp)));
|
|
|
|
/* for each saved register */
|
|
for (saved_reg = &gc_B->cp_a1;
|
|
saved_reg < &gc_B->cp_a1 + arity;
|
|
saved_reg++) {
|
|
CELL cp_cell = *saved_reg;
|
|
if (MARKED_PTR(saved_reg)) {
|
|
UNMARK(saved_reg);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(saved_reg, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
|
|
/*
|
|
* insert cells of each choicepoint & its chain of environments which point
|
|
* to heap objects into relocation chains
|
|
*/
|
|
static void
|
|
sweep_choicepoints(choiceptr gc_B)
|
|
{
|
|
#ifdef TABLING
|
|
dep_fr_ptr depfr = LOCAL_top_dep_fr;
|
|
sg_fr_ptr aux_sg_fr = LOCAL_top_sg_fr;
|
|
#endif /* TABLING */
|
|
|
|
#ifdef TABLING
|
|
gc_B = youngest_cp(gc_B, &depfr);
|
|
#endif /* TABLING */
|
|
while (gc_B != NULL) {
|
|
yamop *rtp = gc_B->cp_ap;
|
|
register OPCODE op;
|
|
op_numbers opnum;
|
|
|
|
#ifdef TABLING
|
|
if (rtp == NULL) {
|
|
if (aux_sg_fr && gc_B == SgFr_gen_cp(aux_sg_fr)) {
|
|
/* found generator */
|
|
opnum = _table_completion;
|
|
} else {
|
|
/* found sld node is done */
|
|
opnum = _trust_fail;
|
|
}
|
|
} else {
|
|
#endif /* TABLING */
|
|
op = rtp->opc;
|
|
opnum = Yap_op_from_opcode(op);
|
|
#ifdef TABLING
|
|
}
|
|
if (aux_sg_fr && gc_B == SgFr_gen_cp(aux_sg_fr)) {
|
|
aux_sg_fr = SgFr_next(aux_sg_fr);
|
|
}
|
|
#endif /* TABLING */
|
|
|
|
restart_cp:
|
|
/*
|
|
* fprintf(Yap_stderr,"sweeping cps: %x, %x, %x\n",
|
|
* *gc_B,CP_Extra(gc_B),CP_Nargs(gc_B));
|
|
*/
|
|
/* any choice point */
|
|
switch (opnum) {
|
|
case _Nstop:
|
|
/* end of the road, say bye bye! */
|
|
sweep_environments(gc_B->cp_env,
|
|
EnvSizeInCells,
|
|
NULL);
|
|
if (gc_B->cp_b != NULL) {
|
|
break;
|
|
} else
|
|
return;
|
|
case _trust_fail:
|
|
break;
|
|
case _or_else:
|
|
case _or_last:
|
|
|
|
sweep_environments((CELL_PTR)(gc_B->cp_a1),
|
|
-gc_B->cp_cp->u.Osblp.s / ((OPREG)sizeof(CELL)),
|
|
gc_B->cp_cp->u.Osblp.bmap
|
|
);
|
|
break;
|
|
case _retry_profiled:
|
|
case _count_retry:
|
|
rtp = NEXTOP(rtp,l);
|
|
op = rtp->opc;
|
|
opnum = Yap_op_from_opcode(op);
|
|
goto restart_cp;
|
|
case _jump:
|
|
rtp = rtp->u.l.l;
|
|
op = rtp->opc;
|
|
opnum = Yap_op_from_opcode(op);
|
|
goto restart_cp;
|
|
#ifdef TABLING
|
|
case _table_load_answer:
|
|
{
|
|
CELL *vars_ptr, vars;
|
|
sweep_environments(gc_B->cp_env, EnvSize(gc_B->cp_cp), EnvBMap(gc_B->cp_cp));
|
|
vars_ptr = (CELL *) (LOAD_CP(gc_B) + 1);
|
|
vars = *vars_ptr++;
|
|
while (vars--) {
|
|
CELL cp_cell = *vars_ptr;
|
|
if (MARKED_PTR(vars_ptr)) {
|
|
UNMARK(vars_ptr);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(vars_ptr, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
vars_ptr++;
|
|
}
|
|
}
|
|
break;
|
|
case _table_try_answer:
|
|
case _table_retry_me:
|
|
case _table_trust_me:
|
|
case _table_retry:
|
|
case _table_trust:
|
|
{
|
|
int nargs;
|
|
CELL *vars_ptr, vars;
|
|
sweep_environments(gc_B->cp_env, EnvSize(gc_B->cp_cp), EnvBMap(gc_B->cp_cp));
|
|
vars_ptr = (CELL *)(GEN_CP(gc_B) + 1);
|
|
nargs = rtp->u.Otapl.s;
|
|
while(nargs--) {
|
|
CELL cp_cell = *vars_ptr;
|
|
if (MARKED_PTR(vars_ptr)) {
|
|
UNMARK(vars_ptr);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(vars_ptr, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
vars_ptr++;
|
|
}
|
|
vars = *vars_ptr++;
|
|
while (vars--) {
|
|
CELL cp_cell = *vars_ptr;
|
|
if (MARKED_PTR(vars_ptr)) {
|
|
UNMARK(vars_ptr);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(vars_ptr, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
vars_ptr++;
|
|
}
|
|
}
|
|
break;
|
|
case _table_completion:
|
|
{
|
|
int nargs;
|
|
CELL *vars_ptr, vars;
|
|
#ifdef DETERMINISTIC_TABLING
|
|
if (IS_DET_GEN_CP(gc_B))
|
|
vars_ptr = (CELL *)(DET_GEN_CP(gc_B) + 1);
|
|
else
|
|
#endif /* DETERMINISTIC_TABLING */
|
|
{
|
|
sweep_environments(gc_B->cp_env, EnvSize(gc_B->cp_cp), EnvBMap(gc_B->cp_cp));
|
|
vars_ptr = (CELL *)(GEN_CP(gc_B) + 1);
|
|
nargs = SgFr_arity(GEN_CP(gc_B)->cp_sg_fr);
|
|
while(nargs--) {
|
|
CELL cp_cell = *vars_ptr;
|
|
if (MARKED_PTR(vars_ptr)) {
|
|
UNMARK(vars_ptr);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(vars_ptr, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
vars_ptr++;
|
|
}
|
|
}
|
|
vars = *vars_ptr++;
|
|
while (vars--) {
|
|
CELL cp_cell = *vars_ptr;
|
|
if (MARKED_PTR(vars_ptr)) {
|
|
UNMARK(vars_ptr);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(vars_ptr, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
vars_ptr++;
|
|
}
|
|
}
|
|
break;
|
|
case _table_answer_resolution:
|
|
{
|
|
CELL *vars_ptr, vars;
|
|
sweep_environments(gc_B->cp_env, EnvSize(gc_B->cp_cp), EnvBMap(gc_B->cp_cp));
|
|
init_substitution_pointer(gc_B, vars_ptr, CONS_CP(gc_B)->cp_dep_fr);
|
|
vars = *vars_ptr++;
|
|
while (vars--) {
|
|
CELL cp_cell = *vars_ptr;
|
|
if (MARKED_PTR(vars_ptr)) {
|
|
UNMARK(vars_ptr);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(vars_ptr, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
vars_ptr++;
|
|
}
|
|
}
|
|
break;
|
|
case _trie_trust_var:
|
|
case _trie_retry_var:
|
|
case _trie_trust_var_in_pair:
|
|
case _trie_retry_var_in_pair:
|
|
case _trie_trust_val:
|
|
case _trie_retry_val:
|
|
case _trie_trust_val_in_pair:
|
|
case _trie_retry_val_in_pair:
|
|
case _trie_trust_atom:
|
|
case _trie_retry_atom:
|
|
case _trie_trust_atom_in_pair:
|
|
case _trie_retry_atom_in_pair:
|
|
case _trie_trust_null:
|
|
case _trie_retry_null:
|
|
case _trie_trust_null_in_pair:
|
|
case _trie_retry_null_in_pair:
|
|
case _trie_trust_pair:
|
|
case _trie_retry_pair:
|
|
case _trie_trust_appl:
|
|
case _trie_retry_appl:
|
|
case _trie_trust_appl_in_pair:
|
|
case _trie_retry_appl_in_pair:
|
|
case _trie_trust_extension:
|
|
case _trie_retry_extension:
|
|
case _trie_trust_double:
|
|
case _trie_retry_double:
|
|
case _trie_trust_longint:
|
|
case _trie_retry_longint:
|
|
case _trie_trust_gterm:
|
|
case _trie_retry_gterm:
|
|
{
|
|
CELL *vars_ptr;
|
|
int heap_arity, vars_arity, subs_arity;
|
|
sweep_environments(gc_B->cp_env, EnvSize(gc_B->cp_cp), EnvBMap(gc_B->cp_cp));
|
|
vars_ptr = (CELL *)(gc_B + 1);
|
|
heap_arity = vars_ptr[0];
|
|
vars_arity = vars_ptr[1 + heap_arity];
|
|
subs_arity = vars_ptr[2 + heap_arity + vars_arity];
|
|
vars_ptr += 2 + heap_arity + subs_arity + vars_arity;
|
|
if (subs_arity) {
|
|
while (subs_arity--) {
|
|
CELL cp_cell = *vars_ptr;
|
|
if (MARKED_PTR(vars_ptr)) {
|
|
UNMARK(vars_ptr);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(vars_ptr, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
vars_ptr--;
|
|
}
|
|
}
|
|
vars_ptr--; /* skip subs_arity entry */
|
|
if (vars_arity) {
|
|
while (vars_arity--) {
|
|
CELL cp_cell = *vars_ptr;
|
|
if (MARKED_PTR(vars_ptr)) {
|
|
UNMARK(vars_ptr);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(vars_ptr, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
vars_ptr--;
|
|
}
|
|
}
|
|
vars_ptr--; /* skip vars_arity entry */
|
|
if (heap_arity) {
|
|
while (heap_arity--) {
|
|
CELL cp_cell = *vars_ptr;
|
|
if (*vars_ptr == 0) /* double/longint extension mark */
|
|
break;
|
|
if (MARKED_PTR(vars_ptr)) {
|
|
UNMARK(vars_ptr);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(vars_ptr, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
vars_ptr--;
|
|
}
|
|
}
|
|
}
|
|
break;
|
|
#endif /* TABLING */
|
|
case _try_logical:
|
|
case _retry_logical:
|
|
case _count_retry_logical:
|
|
case _profiled_retry_logical:
|
|
/* sweep timestamp */
|
|
sweep_b(gc_B, rtp->u.OtaLl.s+1);
|
|
break;
|
|
case _trust_logical:
|
|
case _count_trust_logical:
|
|
case _profiled_trust_logical:
|
|
sweep_b(gc_B, rtp->u.OtILl.d->ClPred->ArityOfPE+1);
|
|
break;
|
|
case _retry2:
|
|
sweep_b(gc_B, 2);
|
|
break;
|
|
case _retry3:
|
|
sweep_b(gc_B, 3);
|
|
break;
|
|
case _retry4:
|
|
sweep_b(gc_B, 4);
|
|
break;
|
|
case _retry_c:
|
|
case _retry_userc:
|
|
{
|
|
register CELL_PTR saved_reg;
|
|
|
|
/* for each extra saved register */
|
|
for (saved_reg = &(gc_B->cp_a1)+rtp->u.OtapFs.s;
|
|
saved_reg < &(gc_B->cp_a1)+rtp->u.OtapFs.s+rtp->u.OtapFs.extra;
|
|
saved_reg++) {
|
|
CELL cp_cell = *saved_reg;
|
|
if (MARKED_PTR(saved_reg)) {
|
|
UNMARK(saved_reg);
|
|
if (HEAP_PTR(cp_cell)) {
|
|
into_relocation_chain(saved_reg, GET_NEXT(cp_cell));
|
|
}
|
|
}
|
|
}
|
|
}
|
|
/* continue to clean environments and arguments */
|
|
default:
|
|
sweep_b(gc_B,rtp->u.Otapl.s);
|
|
}
|
|
|
|
/* link to prev choicepoint */
|
|
#if TABLING
|
|
gc_B = youngest_cp(gc_B->cp_b, &depfr);
|
|
#else
|
|
gc_B = gc_B->cp_b;
|
|
#endif /* TABLING */
|
|
}
|
|
}
|
|
|
|
|
|
|
|
|
|
/* update a relocation chain to point all its cells to new location of object */
|
|
static void
|
|
update_relocation_chain(CELL_PTR current, CELL_PTR dest)
|
|
{
|
|
CELL_PTR next;
|
|
CELL ccur = *current;
|
|
|
|
int rmarked = RMARKED(current);
|
|
|
|
UNRMARK(current);
|
|
while (rmarked) {
|
|
CELL current_tag;
|
|
next = GET_NEXT(ccur);
|
|
current_tag = TAG(ccur);
|
|
ccur = *next;
|
|
rmarked = RMARKED(next);
|
|
UNRMARK(next);
|
|
*next = (CELL) dest | current_tag;
|
|
}
|
|
*current = ccur;
|
|
}
|
|
|
|
static inline choiceptr
|
|
update_B_H( choiceptr gc_B, CELL *current, CELL *dest, CELL *odest
|
|
#ifdef TABLING
|
|
, dep_fr_ptr *depfrp
|
|
#endif /* TABLING */
|
|
) {
|
|
/* also make the value of H in a choicepoint
|
|
coherent with the new global
|
|
*/
|
|
#ifdef TABLING
|
|
dep_fr_ptr depfr = *depfrp;
|
|
#endif /* TABLING */
|
|
|
|
while (gc_B && current <= gc_B->cp_h) {
|
|
if (gc_B->cp_h == current) {
|
|
gc_B->cp_h = dest;
|
|
} else {
|
|
gc_B->cp_h = odest;
|
|
}
|
|
gc_B = gc_B->cp_b;
|
|
#ifdef TABLING
|
|
/* make sure we include consumers */
|
|
if (depfr && gc_B >= DepFr_cons_cp(depfr)) {
|
|
gc_B = DepFr_cons_cp(depfr);
|
|
*depfrp = depfr = DepFr_next(depfr);
|
|
}
|
|
#endif /* TABLING */
|
|
}
|
|
return gc_B;
|
|
}
|
|
|
|
static inline CELL *
|
|
set_next_hb(choiceptr gc_B)
|
|
{
|
|
if (gc_B) {
|
|
return gc_B->cp_h;
|
|
} else {
|
|
return H0;
|
|
}
|
|
}
|
|
|
|
/*
|
|
* move marked objects on the heap upwards over unmarked objects, and reset
|
|
* all pointers to point to new locations
|
|
*/
|
|
static void
|
|
compact_heap(void)
|
|
{
|
|
CELL_PTR dest, current, next;
|
|
#ifdef DEBUG
|
|
Int found_marked = 0;
|
|
#endif /* DEBUG */
|
|
choiceptr gc_B = B;
|
|
int in_garbage = 0;
|
|
CELL *next_hb;
|
|
CELL *start_from = H0;
|
|
#ifdef TABLING
|
|
dep_fr_ptr depfr = LOCAL_top_dep_fr;
|
|
#endif /* TABLING */
|
|
|
|
|
|
/*
|
|
* upward phase - scan heap from high to low, setting marked upward
|
|
* ptrs to point to what will be the new locations of the
|
|
* 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 /* TABLING */
|
|
next_hb = set_next_hb(gc_B);
|
|
dest = H0 + total_marked - 1;
|
|
|
|
gc_B = update_B_H(gc_B, H, dest+1, dest+2
|
|
#ifdef TABLING
|
|
, &depfr
|
|
#endif /* TABLING */
|
|
);
|
|
for (current = H - 1; current >= start_from; current--) {
|
|
if (MARKED_PTR(current)) {
|
|
CELL ccell = UNMARK_CELL(*current);
|
|
|
|
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 /* TABLING */
|
|
);
|
|
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++;
|
|
MARK(ptr);
|
|
#ifdef DEBUG
|
|
found_marked+=nofcells;
|
|
#endif
|
|
/* 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 */
|
|
update_relocation_chain(current, dest);
|
|
if (HEAP_PTR(*current)) {
|
|
next = GET_NEXT(*current);
|
|
if (next < current) /* push into reloc.
|
|
* chain */
|
|
into_relocation_chain(current, next);
|
|
else if (current == next) { /* cell pointing to
|
|
* itself */
|
|
UNRMARK(current);
|
|
*current = (CELL) dest; /* no tag */
|
|
}
|
|
}
|
|
dest--;
|
|
} else {
|
|
in_garbage++;
|
|
}
|
|
}
|
|
if (in_garbage)
|
|
start_from[0] = in_garbage;
|
|
|
|
#ifdef DEBUG
|
|
if (dest != start_from-1)
|
|
fprintf(Yap_stderr,"%% Bad Dest (%lu): %p should be %p\n",
|
|
(unsigned long int)GcCalls,
|
|
dest,
|
|
start_from);
|
|
if (total_marked != found_marked)
|
|
fprintf(Yap_stderr,"%% Upward (%lu): %lu total against %lu found\n",
|
|
(unsigned long int)GcCalls,
|
|
(unsigned long int)total_marked,
|
|
(unsigned long int)found_marked);
|
|
found_marked = start_from-H0;
|
|
#endif
|
|
|
|
|
|
/*
|
|
* downward phase - scan heap from low to high, moving marked objects
|
|
* to their new locations & setting downward pointers to pt to new
|
|
* locations
|
|
*/
|
|
|
|
dest = (CELL_PTR) start_from;
|
|
for (current = start_from; current < H; current++) {
|
|
CELL ccur = *current;
|
|
if (MARKED_PTR(current)) {
|
|
CELL uccur = UNMARK_CELL(ccur);
|
|
if (uccur == EndSpecials) {
|
|
CELL *old_dest = dest;
|
|
|
|
dest++;
|
|
current++;
|
|
while (!MARKED_PTR(current)) {
|
|
*dest++ = *current++;
|
|
}
|
|
*old_dest = *current;
|
|
*dest++ = EndSpecials;
|
|
#ifdef DEBUG
|
|
found_marked += (dest-old_dest);
|
|
#endif
|
|
continue;
|
|
}
|
|
#ifdef DEBUG
|
|
found_marked++;
|
|
#endif
|
|
update_relocation_chain(current, dest);
|
|
ccur = *current;
|
|
next = GET_NEXT(ccur);
|
|
if (HEAP_PTR(ccur) &&
|
|
(next = GET_NEXT(ccur)) < H && /* move current cell &
|
|
* push */
|
|
next > current) { /* into relocation chain */
|
|
*dest = ccur;
|
|
into_relocation_chain(dest, next);
|
|
UNMARK(dest);
|
|
} else {
|
|
/* just move current cell */
|
|
*dest = ccur = UNMARK_CELL(ccur);
|
|
}
|
|
/* next cell, please */
|
|
dest++;
|
|
} else {
|
|
current += (ccur-1);
|
|
}
|
|
}
|
|
#ifdef DEBUG
|
|
if (total_marked != found_marked)
|
|
fprintf(Yap_stderr,"%% Downward (%lu): %lu total against %lu found\n",
|
|
(unsigned long int)GcCalls,
|
|
(unsigned long int)total_marked,
|
|
(unsigned long int)found_marked);
|
|
#endif
|
|
|
|
H = dest; /* reset H */
|
|
HB = B->cp_h;
|
|
#ifdef TABLING
|
|
if (B_FZ == (choiceptr)LCL0)
|
|
H_FZ = H0;
|
|
else
|
|
H_FZ = B_FZ->cp_h;
|
|
#endif /* TABLING */
|
|
|
|
}
|
|
|
|
#ifdef HYBRID_SCHEME
|
|
/*
|
|
* move marked objects on the heap upwards over unmarked objects, and reset
|
|
* all pointers to point to new locations
|
|
*/
|
|
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
|
|
* ptrs to point to what will be the new locations of the
|
|
* 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 /* TABLING */
|
|
next_hb = set_next_hb(gc_B);
|
|
dest = (CELL_PTR) H0 + total_marked - 1;
|
|
gc_B = update_B_H(gc_B, H, dest+1, dest+2
|
|
#ifdef TABLING
|
|
, &depfr
|
|
#endif /* TABLING */
|
|
);
|
|
for (iptr = iptop - 1; iptr >= ibase; iptr--) {
|
|
CELL ccell;
|
|
CELL_PTR current;
|
|
|
|
current = *iptr;
|
|
ccell = UNMARK_CELL(*current);
|
|
if (current <= next_hb) {
|
|
gc_B = update_B_H(gc_B, current, dest, dest+1
|
|
#ifdef TABLING
|
|
, &depfr
|
|
#endif /* TABLING */
|
|
);
|
|
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, dest);
|
|
if (HEAP_PTR(*current)) {
|
|
CELL_PTR next;
|
|
next = GET_NEXT(*current);
|
|
if (next < current) /* push into reloc.
|
|
* chain */
|
|
into_relocation_chain(current, next);
|
|
else if (current == next) { /* cell pointing to
|
|
* itself */
|
|
UNRMARK(current);
|
|
*current = (CELL) dest; /* no tag */
|
|
}
|
|
}
|
|
dest--;
|
|
}
|
|
|
|
#ifdef DEBUG
|
|
if (dest != H0-1)
|
|
fprintf(Yap_stderr,"%% Bad Dest (%lu): %p should be %p\n",
|
|
(unsigned long int)GcCalls,
|
|
dest,
|
|
H0-1);
|
|
if (total_marked != found_marked)
|
|
fprintf(Yap_stderr,"%% Upward (%lu): %lu total against %lu found\n",
|
|
(unsigned long int)GcCalls,
|
|
(unsigned long int)total_marked,
|
|
(unsigned long int)found_marked);
|
|
found_marked = 0;
|
|
#endif
|
|
|
|
|
|
/*
|
|
* downward phase - scan heap from low to high, moving marked objects
|
|
* to their new locations & setting downward pointers to pt to new
|
|
* locations
|
|
*/
|
|
|
|
dest = H0;
|
|
for (iptr = ibase; iptr < iptop; iptr++) {
|
|
CELL_PTR next;
|
|
CELL *current = *iptr;
|
|
CELL ccur = *current;
|
|
CELL uccur = UNMARK_CELL(ccur);
|
|
|
|
if (uccur == EndSpecials) {
|
|
CELL *old_dest = dest;
|
|
|
|
/* leave a hole */
|
|
dest++;
|
|
current++;
|
|
while (!MARKED_PTR(current)) {
|
|
*dest++ = *current++;
|
|
}
|
|
/* fill in hole */
|
|
*old_dest = *current;
|
|
*dest++ = EndSpecials;
|
|
#ifdef DEBUG
|
|
found_marked += dest-old_dest;
|
|
#endif
|
|
continue;
|
|
}
|
|
#ifdef DEBUG
|
|
found_marked++;
|
|
#endif
|
|
update_relocation_chain(current, dest);
|
|
ccur = *current;
|
|
next = GET_NEXT(ccur);
|
|
if (HEAP_PTR(ccur) && /* move current cell &
|
|
* push */
|
|
next > current) { /* into relocation chain */
|
|
*dest = ccur;
|
|
into_relocation_chain(dest, next);
|
|
UNMARK(dest);
|
|
dest++;
|
|
} else {
|
|
/* just move current cell */
|
|
*dest++ = ccur = UNMARK_CELL(ccur);
|
|
}
|
|
}
|
|
#ifdef DEBUG
|
|
if (H0+total_marked != dest)
|
|
fprintf(Yap_stderr,"%% Downward (%lu): %p total against %p found\n",
|
|
(unsigned long int)GcCalls,
|
|
H0+total_marked,
|
|
dest);
|
|
if (total_marked != found_marked)
|
|
fprintf(Yap_stderr,"%% Downward (%lu): %lu total against %lu found\n",
|
|
(unsigned long int)GcCalls,
|
|
(unsigned long int)total_marked,
|
|
(unsigned long int)found_marked);
|
|
#endif
|
|
|
|
H = dest; /* reset H */
|
|
HB = B->cp_h;
|
|
#ifdef TABLING
|
|
if (B_FZ == (choiceptr)LCL0)
|
|
H_FZ = H0;
|
|
else
|
|
H_FZ = B_FZ->cp_h;
|
|
#endif /* TABLING */
|
|
|
|
}
|
|
#endif /* HYBRID_SCHEME */
|
|
|
|
|
|
#ifdef EASY_SHUNTING
|
|
static void
|
|
set_conditionals(tr_fr_ptr str) {
|
|
while (str != sTR0) {
|
|
CELL *cptr;
|
|
str -= 2;
|
|
cptr = (CELL *)TrailTerm(str+1);
|
|
*cptr = TrailTerm(str);
|
|
}
|
|
sTR = sTR0 = NULL;
|
|
}
|
|
#endif
|
|
|
|
|
|
/*
|
|
* mark all objects on the heap that are accessible from active registers,
|
|
* the trail, environments, and choicepoints
|
|
*/
|
|
|
|
static void
|
|
marking_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp)
|
|
{
|
|
|
|
#ifdef EASY_SHUNTING
|
|
current_B = B;
|
|
prev_HB = H;
|
|
#endif
|
|
init_dbtable(old_TR);
|
|
#ifdef EASY_SHUNTING
|
|
sTR0 = (tr_fr_ptr)db_vec;
|
|
sTR = (tr_fr_ptr)db_vec;
|
|
/* make sure we set HB before we do any variable shunting!!! */
|
|
#else
|
|
cont_top0 = (cont *)db_vec;
|
|
#endif
|
|
cont_top = (cont *)db_vec;
|
|
/* These two must be marked first so that our trail optimisation won't lose
|
|
values */
|
|
mark_slots();
|
|
mark_regs(old_TR); /* active registers & trail */
|
|
/* active environments */
|
|
mark_environments(current_env, EnvSize(curp), EnvBMap(curp));
|
|
mark_choicepoints(B, old_TR, is_gc_very_verbose()); /* choicepoints, and environs */
|
|
#ifdef EASY_SHUNTING
|
|
set_conditionals(sTR);
|
|
#endif
|
|
}
|
|
|
|
static void
|
|
sweep_oldgen(CELL *max, CELL *base)
|
|
{
|
|
CELL *ptr = base;
|
|
char *bpb = Yap_bp+(base-(CELL*)Yap_GlobalBase);
|
|
|
|
while (ptr < max) {
|
|
if (*bpb) {
|
|
if (HEAP_PTR(*ptr)) {
|
|
into_relocation_chain(ptr, GET_NEXT(*ptr));
|
|
}
|
|
}
|
|
ptr++;
|
|
bpb++;
|
|
}
|
|
}
|
|
|
|
|
|
/*
|
|
* move marked heap objects upwards over unmarked objects, and reset all
|
|
* pointers to point to new locations
|
|
*/
|
|
|
|
static void
|
|
compaction_phase(tr_fr_ptr old_TR, CELL *current_env, yamop *curp)
|
|
{
|
|
CELL *CurrentH0 = NULL;
|
|
|
|
int icompact = (iptop < (CELL_PTR *)ASP && 10*total_marked < H-H0);
|
|
|
|
if (icompact) {
|
|
/* we are going to reuse the total space */
|
|
if (HGEN != H0) {
|
|
/* undo optimisation */
|
|
total_marked += total_oldies;
|
|
}
|
|
} else {
|
|
if (HGEN != H0) {
|
|
CurrentH0 = H0;
|
|
H0 = HGEN;
|
|
sweep_oldgen(HGEN, CurrentH0);
|
|
}
|
|
}
|
|
sweep_slots();
|
|
sweep_environments(current_env, EnvSize(curp), EnvBMap(curp));
|
|
sweep_choicepoints(B);
|
|
sweep_trail(B, old_TR);
|
|
#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);
|
|
fprintf(Yap_stderr,"%% using pointers (%d)\n", effectiveness);
|
|
#endif
|
|
if (CurrentH0) {
|
|
H0 = CurrentH0;
|
|
HGEN = H0;
|
|
total_marked += total_oldies;
|
|
CurrentH0 = NULL;
|
|
}
|
|
quicksort((CELL_PTR *)H, 0, (iptop-(CELL_PTR *)H)-1);
|
|
icompact_heap();
|
|
} else
|
|
#endif /* HYBRID_SCHEME */
|
|
{
|
|
#ifdef DEBUG
|
|
/*
|
|
#ifdef HYBRID_SCHEME
|
|
int effectiveness = (((H-H0)-total_marked)*100)/(H-H0);
|
|
fprintf(stderr,"%% not using pointers (%d) ASP: %p, ip %p (expected %p) \n", effectiveness, ASP, iptop, H+total_marked);
|
|
|
|
#endif
|
|
*/
|
|
#endif
|
|
compact_heap();
|
|
}
|
|
if (CurrentH0) {
|
|
H0 = CurrentH0;
|
|
}
|
|
}
|
|
|
|
static int
|
|
do_gc(Int predarity, CELL *current_env, yamop *nextop)
|
|
{
|
|
Int heap_cells;
|
|
int gc_verbose;
|
|
volatile tr_fr_ptr old_TR = NULL;
|
|
UInt m_time, c_time, time_start, gc_time;
|
|
Int effectiveness, tot;
|
|
int gc_trace;
|
|
UInt gc_phase;
|
|
UInt alloc_sz;
|
|
heap_cells = H-H0;
|
|
gc_verbose = is_gc_verbose();
|
|
effectiveness = 0;
|
|
gc_trace = FALSE;
|
|
GcCalls++;
|
|
#ifdef INSTRUMENT_GC
|
|
{
|
|
int i;
|
|
for (i=0; i<16; i++)
|
|
chain[i]=0;
|
|
vars[gc_var] = 0;
|
|
vars[gc_ref] = 0;
|
|
vars[gc_atom] = 0;
|
|
vars[gc_int] = 0;
|
|
vars[gc_num] = 0;
|
|
vars[gc_list] = 0;
|
|
vars[gc_appl] = 0;
|
|
vars[gc_func] = 0;
|
|
vars[gc_susp] = 0;
|
|
env_vars = 0;
|
|
old_vars = new_vars = 0;
|
|
TrueHB = HB;
|
|
num_bs = 0;
|
|
}
|
|
#endif
|
|
#ifdef DEBUG
|
|
check_global();
|
|
#endif
|
|
if (Yap_GetValue(AtomGcTrace) != TermNil)
|
|
gc_trace = 1;
|
|
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 %lu:\n", (unsigned long int)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);
|
|
fprintf(Yap_stderr, "%% Trail:%8ld cells (%p-%p)\n",
|
|
(unsigned long int)(TR-(tr_fr_ptr)Yap_TrailBase),Yap_TrailBase,TR);
|
|
}
|
|
#if !USE_SYSTEM_MALLOC
|
|
if (HeapTop >= Yap_GlobalBase - MinHeapGap) {
|
|
*--ASP = (CELL)current_env;
|
|
if (!Yap_growheap(FALSE, MinHeapGap, NULL)) {
|
|
Yap_Error(OUT_OF_HEAP_ERROR, TermNil, Yap_ErrorMessage);
|
|
return -1;
|
|
}
|
|
current_env = (CELL *)*ASP;
|
|
ASP++;
|
|
}
|
|
#endif
|
|
time_start = Yap_cputime();
|
|
if (_setjmp(Yap_gc_restore) == 2) {
|
|
UInt sz;
|
|
|
|
/* we cannot recover, fail system */
|
|
restore_machine_regs();
|
|
sz = Yap_TrailTop-(ADDR)OldTR;
|
|
/* ask for double the size */
|
|
sz = 2*sz;
|
|
TR = OldTR;
|
|
|
|
*--ASP = (CELL)current_env;
|
|
if (
|
|
!Yap_growtrail(sz, FALSE)
|
|
) {
|
|
Yap_Error(OUT_OF_TRAIL_ERROR,TermNil,"out of %lB during gc", sz);
|
|
return -1;
|
|
} else {
|
|
total_marked = 0;
|
|
total_oldies = 0;
|
|
#ifdef COROUTING
|
|
total_smarked = 0;
|
|
#endif
|
|
discard_trail_entries = 0;
|
|
current_env = (CELL *)*ASP;
|
|
ASP++;
|
|
}
|
|
}
|
|
#if EASY_SHUNTING
|
|
sTR0 = sTR = NULL;
|
|
#endif
|
|
total_marked = 0;
|
|
total_oldies = 0;
|
|
#ifdef COROUTING
|
|
total_smarked = 0;
|
|
#endif
|
|
discard_trail_entries = 0;
|
|
alloc_sz = (CELL *)Yap_TrailTop-(CELL*)Yap_GlobalBase;
|
|
Yap_bp = Yap_PreAllocCodeSpace();
|
|
while (Yap_bp+alloc_sz > (char *)AuxSp) {
|
|
/* not enough space */
|
|
*--ASP = (CELL)current_env;
|
|
Yap_bp = (char *)Yap_ExpandPreAllocCodeSpace(alloc_sz, NULL, TRUE);
|
|
if (!Yap_bp)
|
|
return -1;
|
|
current_env = (CELL *)*ASP;
|
|
ASP++;
|
|
}
|
|
memset((void *)Yap_bp, 0, alloc_sz);
|
|
#ifdef HYBRID_SCHEME
|
|
iptop = (CELL_PTR *)H;
|
|
#endif
|
|
/* get the number of active registers */
|
|
HGEN = VarOfTerm(Yap_ReadTimedVar(GcGeneration));
|
|
|
|
gc_phase = (UInt)IntegerOfTerm(Yap_ReadTimedVar(GcPhase));
|
|
/* old HGEN are not very reliable, but still may have data to recover */
|
|
if (gc_phase != GcCurrentPhase) {
|
|
HGEN = H0;
|
|
}
|
|
/* fprintf(stderr,"HGEN is %ld, %p, %p/%p\n", IntegerOfTerm(Yap_ReadTimedVar(GcGeneration)), HGEN, H,H0);*/
|
|
OldTR = (tr_fr_ptr)(old_TR = TR);
|
|
push_registers(predarity, nextop);
|
|
/* make sure we clean bits after a reset */
|
|
marking_phase(old_TR, current_env, nextop);
|
|
if (total_oldies > ((HGEN-H0)*8)/10) {
|
|
total_marked -= total_oldies;
|
|
tot = total_marked+(HGEN-H0);
|
|
} else {
|
|
if (HGEN != H0) {
|
|
HGEN = H0;
|
|
GcCurrentPhase++;
|
|
}
|
|
tot = total_marked;
|
|
}
|
|
m_time = Yap_cputime();
|
|
gc_time = m_time-time_start;
|
|
if (heap_cells) {
|
|
if (heap_cells > 1000000)
|
|
effectiveness = (heap_cells-tot)/(heap_cells/100);
|
|
else
|
|
effectiveness = 100*(heap_cells-tot)/heap_cells;
|
|
} else
|
|
effectiveness = 0;
|
|
if (gc_verbose) {
|
|
fprintf(Yap_stderr, "%% Mark: Marked %ld cells of %ld (efficiency: %ld%%) in %g sec\n",
|
|
(long int)tot, (long int)heap_cells, (long int)effectiveness, (double)(m_time-time_start)/1000);
|
|
if (HGEN-H0)
|
|
fprintf(Yap_stderr,"%% previous generation has size " UInt_FORMAT ", with " UInt_FORMAT " (" UInt_FORMAT "%%) unmarked\n", (UInt)(HGEN-H0), (UInt)((HGEN-H0)-total_oldies), (UInt)(100*((HGEN-H0)-total_oldies)/(HGEN-H0)));
|
|
#ifdef INSTRUMENT_GC
|
|
{
|
|
int i;
|
|
for (i=0; i<16; i++) {
|
|
if (chain[i]) {
|
|
fprintf(Yap_stderr, "%% chain[%d]=%lu\n", i, chain[i]);
|
|
}
|
|
}
|
|
put_type_info((unsigned long int)tot);
|
|
fprintf(Yap_stderr,"%% %lu/%ld before and %lu/%ld after\n", old_vars, (unsigned long int)(B->cp_h-H0), new_vars, (unsigned long int)(H-B->cp_h));
|
|
fprintf(Yap_stderr,"%% %ld choicepoints\n", num_bs);
|
|
}
|
|
#endif
|
|
}
|
|
time_start = m_time;
|
|
compaction_phase(old_TR, current_env, nextop);
|
|
TR = old_TR;
|
|
pop_registers(predarity, nextop);
|
|
TR = new_TR;
|
|
/* fprintf(Yap_stderr,"NEW HGEN %ld (%ld)\n", H-H0, HGEN-H0);*/
|
|
{
|
|
Term t = MkVarTerm();
|
|
Yap_UpdateTimedVar(GcGeneration, t);
|
|
}
|
|
Yap_UpdateTimedVar(GcPhase, MkIntegerTerm(GcCurrentPhase));
|
|
c_time = Yap_cputime();
|
|
if (gc_verbose) {
|
|
fprintf(Yap_stderr, "%% Compress: took %g sec\n", (double)(c_time-time_start)/1000);
|
|
}
|
|
gc_time += (c_time-time_start);
|
|
TotGcTime += gc_time;
|
|
TotGcRecovered += heap_cells-tot;
|
|
if (gc_verbose) {
|
|
fprintf(Yap_stderr, "%% GC %lu took %g sec, total of %g sec doing GC so far.\n", (unsigned long int)GcCalls, (double)gc_time/1000, (double)TotGcTime/1000);
|
|
fprintf(Yap_stderr, "%% Left %ld cells free in stacks.\n",
|
|
(unsigned long int)(ASP-H));
|
|
}
|
|
check_global();
|
|
return effectiveness;
|
|
}
|
|
|
|
static int
|
|
is_gc_verbose(void)
|
|
{
|
|
if (Yap_PrologMode == BootMode)
|
|
return FALSE;
|
|
#ifdef INSTRUMENT_GC
|
|
/* always give info when we are debugging gc */
|
|
return(TRUE);
|
|
#else
|
|
return(Yap_GetValue(AtomGcVerbose) != TermNil ||
|
|
Yap_GetValue(AtomGcVeryVerbose) != TermNil);
|
|
#endif
|
|
}
|
|
|
|
int
|
|
Yap_is_gc_verbose(void)
|
|
{
|
|
return is_gc_verbose();
|
|
}
|
|
|
|
static int
|
|
is_gc_very_verbose(void)
|
|
{
|
|
if (Yap_PrologMode == BootMode)
|
|
return FALSE;
|
|
return Yap_GetValue(AtomGcVeryVerbose) != TermNil;
|
|
}
|
|
|
|
Int
|
|
Yap_total_gc_time(void)
|
|
{
|
|
return(TotGcTime);
|
|
}
|
|
|
|
static Int
|
|
p_inform_gc(void)
|
|
{
|
|
Term tn = MkIntegerTerm(TotGcTime);
|
|
Term tt = MkIntegerTerm(GcCalls);
|
|
Term ts = Yap_Mk64IntegerTerm((TotGcRecovered*sizeof(CELL)));
|
|
|
|
return(Yap_unify(tn, ARG2) && Yap_unify(tt, ARG1) && Yap_unify(ts, ARG3));
|
|
|
|
}
|
|
|
|
|
|
static int
|
|
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, 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 6 calls, that would ask about 2MB minimum */
|
|
if (GcCalls < 8)
|
|
gc_margin <<= GcCalls;
|
|
else {
|
|
/* next grow linearly */
|
|
gc_margin <<= 8;
|
|
/* don't do this: it forces the system to ask for ever more stack!!
|
|
gc_margin *= GcCalls;
|
|
*/
|
|
}
|
|
}
|
|
if (gc_margin < gc_lim)
|
|
gc_margin = gc_lim;
|
|
HGEN = VarOfTerm(Yap_ReadTimedVar(GcGeneration));
|
|
if (gc_on && !(Yap_PrologMode & InErrorMode) &&
|
|
/* make sure there is a point in collecting the heap */
|
|
(ASP-H0)*sizeof(CELL) > gc_lim &&
|
|
H-HGEN > (LCL0-ASP)/2) {
|
|
effectiveness = do_gc(predarity, current_env, nextop);
|
|
if (effectiveness < 0)
|
|
return FALSE;
|
|
if (effectiveness > 90 && !gc_t) {
|
|
while (gc_margin < (H-H0)/sizeof(CELL))
|
|
gc_margin <<= 1;
|
|
}
|
|
} else {
|
|
effectiveness = 0;
|
|
}
|
|
/* expand the stack if effectiveness is less than 20 % */
|
|
if (ASP - H < gc_margin/sizeof(CELL) ||
|
|
effectiveness < 20) {
|
|
LeaveGCMode();
|
|
if (gc_margin < 2*CalculateStackGap())
|
|
gc_margin = 2*CalculateStackGap();
|
|
return Yap_growstack(gc_margin);
|
|
}
|
|
/*
|
|
* debug for(save_total=1; save_total<=N; ++save_total)
|
|
* plwrite(XREGS[save_total],Yap_DebugPutc,0);
|
|
*/
|
|
return TRUE;
|
|
}
|
|
|
|
static void
|
|
LeaveGCMode()
|
|
{
|
|
if (Yap_PrologMode & GCMode)
|
|
Yap_PrologMode &= ~GCMode;
|
|
if (Yap_PrologMode & AbortMode) {
|
|
Yap_PrologMode &= ~AbortMode;
|
|
Yap_Error(PURE_ABORT, TermNil, "");
|
|
P = FAILCODE;
|
|
}
|
|
}
|
|
|
|
int
|
|
Yap_gc(Int predarity, CELL *current_env, yamop *nextop)
|
|
{
|
|
int res;
|
|
Yap_PrologMode |= GCMode;
|
|
res=call_gc(4096, predarity, current_env, nextop);
|
|
LeaveGCMode();
|
|
if (Yap_PrologMode & GCMode)
|
|
Yap_PrologMode &= ~GCMode;
|
|
return res;
|
|
}
|
|
|
|
int
|
|
Yap_gcl(UInt gc_lim, Int predarity, CELL *current_env, yamop *nextop)
|
|
{
|
|
int res;
|
|
UInt min = CalculateStackGap()*sizeof(CELL);
|
|
|
|
Yap_PrologMode |= GCMode;
|
|
if (gc_lim < min)
|
|
gc_lim = min;
|
|
res = call_gc(gc_lim, predarity, current_env, nextop);
|
|
LeaveGCMode();
|
|
return res;
|
|
}
|
|
|
|
|
|
static Int
|
|
p_gc(void)
|
|
{
|
|
int res;
|
|
Yap_PrologMode |= GCMode;
|
|
if (P->opc == Yap_opcode(_execute_cpred))
|
|
res = do_gc(0, ENV, CP) >= 0;
|
|
else
|
|
res = do_gc(0, ENV, P) >= 0;
|
|
LeaveGCMode();
|
|
return res;
|
|
}
|
|
|
|
void
|
|
Yap_init_gc(void)
|
|
{
|
|
Yap_InitCPred("$gc", 0, p_gc, HiddenPredFlag);
|
|
Yap_InitCPred("$inform_gc", 3, p_inform_gc, HiddenPredFlag);
|
|
}
|
|
|
|
void
|
|
Yap_inc_mark_variable()
|
|
{
|
|
total_marked++;
|
|
}
|