home
***
CD-ROM
|
disk
|
FTP
|
other
***
search
/
The World of Computer Software
/
World_Of_Computer_Software-02-387-Vol-3of3.iso
/
p
/
plbin.zip
/
pl
/
src
/
pl-gc.c
< prev
next >
Wrap
C/C++ Source or Header
|
1993-02-23
|
36KB
|
1,280 lines
/* pl-gc.c,v 1.3 1993/02/23 13:16:32 jan Exp
Copyright (c) 1990 Jan Wielemaker. All rights reserved.
See ../LICENCE to find out about your rights.
jan@swi.psy.uva.nl
Purpose: Garbage Collection
*/
/*#define O_DEBUG 1*/
#include "pl-incl.h"
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
This module is based on
Karen Appleby, Mats Carlsson, Seif Haridi and Dan Sahlin
``Garbage Collection for Prolog Based on WAM''
Communications of the ACM, June 1988, vol. 31, No. 6, pages 719-741.
Garbage collection is invoked if the WAM interpreter is at the call
port. This implies the current environment has its arguments filled.
For the moment we assume the other reachable environments are filled
completely. There is room for some optimisations here. But we will
exploit these later.
The sole fact that the garbage collector can only be invoked if the
machinery is in a well known phase of the execution is irritating, but
sofar I see no solutions around this, nor have had any indications from
other Prolog implementors or the literature that this was feasible. As
a consequence however, we should start the garbage collector well before
the system runs out of memory.
In theory, we could have the compiler calculating the maximum amount of
global stack data created before the next `save point'. This
unfortunately is not possible for the trail stack, which also benifits
from a garbage collection pass. Furthermore, there is the problem of
foreign code creating global stack data (=../2, name/2, read/1, etc.).
CONSEQUENCES FOR THE VIRTUAL MACHINE
The virtual machine interpreter now should ensure the stack frames are
in a predicatable state. For the moment, this implies that all frames,
except for the current one (which only has its arguments filled) should
be initialised fully. I'm not yet sure whether we can't do better, but
this is simple and save and allows us to debug the garbage collector
first before starting on the optimisations.
CONSEQUENCES FOR THE DATA REPRESENTATION
The garbage collector needs two bits on each cell of `Prolog data'. I
decided to use the low order two bits for this. The advantage of this
that pointers to word aligned data are not affected (at least on 32 bits
machines. Unfortunately, you will have to use 4 bytes alignment on 16
bits machines now as well). This demand only costs us two bits for
integers, which are now shifted two bits to the left when stored on the
stack. The normal Prolog machinery expects the lower two bits of any
Prolog data object to be zero. The garbage collection part must be
carefull to strip of these two bits before operating on the data.
Finally, for the compacting phase we should be able to scan the global
stack both upwards and downwards while identifying the objects in it.
This implies reals are now packed into two words and strings are
surrounded by a word at the start and end, indicating their length.
DEBUGGING
Debugging a garbage collector is a difficult job. Bugs --like bugs in
memory allocation-- usually cause crashes long after the garbage
collection has finished. To simplify debugging a large number of
actions are counted during garbage collection. At regular points the
consistency between these counts is verified. This causes a small
performance degradation, but for the moment is worth this I think.
If the O_DEBUG cpp flag is set some additional expensive consistency
checks that need considerable amounts of memory and cpu time are added.
Garbage collection gets about 3-4 times as slow.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Marking, testing marks and extracting values from GC masked words.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#define GC_MASK (MARK_MASK|FIRST_MASK)
#define VALUE_MASK (~GC_MASK)
#if O_DEBUG
#define recordMark(p) { if ( (p) < gTop ) *mark_top++ = (p); }
#else
#define recordMark(p)
#define needsRelocation(p) { needs_relocation++; }
#define check_relocation(p)
#endif
#define ldomark(p) { *(p) |= MARK_MASK; }
#define domark(p) { if ( marked(p) ) sysError("marked twice: 0x%lx (*= 0x%lx), gTop = 0x%lx", p, *(p), gTop); \
*(p) |= MARK_MASK; \
total_marked++; \
recordMark(p); \
DEBUG(4, printf("marked(0x%lx)\n", p)); \
}
#define unmark(p) (*(p) &= ~MARK_MASK)
#define marked(p) (*(p) & MARK_MASK)
#define mark_first(p) (*(p) |= FIRST_MASK)
#define unmark_first(p) (*(p) &= ~FIRST_MASK)
#define is_first(p) (*(p) & FIRST_MASK)
#define get_value(p) (*(p) & VALUE_MASK)
#define set_value(p, w) { *(p) &= GC_MASK; *(p) |= w; }
#define onGlobal(p) ((Word)(p) >= gBase && (Word)(p) < gTop)
#define isGlobalRef(w) ( ((isIndirect(w) || isPointer(w)) \
&& onGlobal(unMask(w))) \
|| (isRef(w) && onGlobal(unRef(w))))
#define L_MARK 0 /* Foreign reference marks */
#define L_WORD 1
#define L_POINTER 2
forwards long offset_cell P((Word));
forwards Word previous_gcell P((Word));
forwards void mark_variable P((Word));
forwards void mark_foreign P((void));
forwards void clear_uninitialised P((LocalFrame, Code));
forwards LocalFrame mark_environments P((LocalFrame));
forwards void mark_choicepoints P((LocalFrame));
forwards void mark_stacks P((LocalFrame));
forwards void mark_phase P((LocalFrame));
forwards void update_relocation_chain P((Word, Word));
forwards void into_relocation_chain P((Word));
forwards void compact_trail P((void));
forwards void sweep_mark P((mark *));
forwards void sweep_foreign P((void));
forwards void sweep_trail P((void));
forwards LocalFrame sweep_environments P((LocalFrame));
forwards void sweep_choicepoints P((LocalFrame));
forwards void sweep_stacks P((LocalFrame));
forwards void sweep_local P((LocalFrame));
forwards bool is_downward_ref P((Word));
forwards bool is_upward_ref P((Word));
forwards void compact_global P((void));
forwards void collect_phase P((LocalFrame));
#if O_DEBUG
forwards int cmp_address P((Word *, Word *));
forwards void check_relocation P((Word));
forwards void needsRelocation P((Word));
forwards bool scan_global P((void));
#endif
/********************************
* GLOBALS *
*********************************/
static long total_marked; /* # marked global cells */
static long trailcells_deleted; /* # garbage trailcells */
static long relocation_chains; /* # relocation chains (debugging) */
static long relocation_cells; /* # relocation cells */
static long relocated_cells; /* # relocated cells */
static long needs_relocation; /* # cells that need relocation */
static long local_marked; /* # cells marked local -> global ptrs */
static long relocation_refs; /* # refs that need relocation */
static long relocation_indirect;/* # indirects */
#if O_DEBUG
/********************************
* DEBUGGING *
*********************************/
static Word *mark_base; /* Array of addresses of marked cells */
static Word *mark_top; /* Top of this array */
static Table check_table = NULL; /* relocation address table */
static void
needsRelocation(addr)
Word addr;
{ needs_relocation++;
addHTable(check_table, addr, (Void) TRUE);
}
static void
check_relocation(addr)
Word addr;
{ Symbol s;
if ( (s=lookupHTable(check_table, addr)) == NULL )
{ sysError("Address 0x%lx was not supposed to be relocated", addr);
return;
}
if ( s->value == FALSE )
{ sysError("Relocated twice: 0x%lx", addr);
return;
}
s->value = FALSE;
}
#endif /* O_DEBUG */
/********************************
* UTILITIES *
*********************************/
static long
offset_cell(p)
Word p;
{ word w = get_value(p);
if ( (w & DATA_TAG_MASK) == REAL_MASK )
{ DEBUG(3, printf("REAL at 0x%lx (w = 0x%lx)\n", p, w));
return 1;
}
if ( (w & DATA_TAG_MASK) == STRING_MASK )
{ long l = ((w) << DMASK_BITS) >> (DMASK_BITS+LMASK_BITS);
DEBUG(3, printf("STRING ``%s'' at 0x%lx (w = 0x%lx)\n", p, p+1, w));
return allocSizeString(l) / sizeof(word) - 1;
}
return 0;
}
static Word
previous_gcell(p)
Word p;
{ p--;
return p - offset_cell(p);
}
/********************************
* MARKING *
*********************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
void mark_variable(start)
Word start;
After the marking phase has been completed, the following statements are
supposed to hold:
- All non-garbage cells on the local- and global stack are
marked.
- `total_marked' equals the size of the global stack AFTER
compacting (e.i. the amount of non-garbage) in words.
- `needs_relocation' holds the total number of references from the
argument- and local variable fields of the local stack and the
internal global stack references that need be relocated. This
number is only used for consistency checking with the relocation
statistic obtained during the compacting phase.
The marking algorithm forms a two-state machine. While going deeper
into the reference tree, the pointers are reversed and the first bit is
set to indicate the choiche points created by complex terms with arity >
1. Also the actuall mark bit is set on the cells. If a leafe is
reached the process reverses, restoring the old pointers. If a `first'
mark is reached we are either finished, or have reached a choice point,
in which case the alternative is the cell above (structures are handled
last-argument-first).
Mark the tree of global stack cells, referenced by the local stack word
`start'. Things are a bit more difficult than described in the liteture
above as SWI-Prolog does not use a structure to describe a general
Prolog object, but just a 32 bits long. This has performance advantages
as we can exploit things like using negative numbers for references. It
has some disadvantages here as we have to distinguis some more cases.
Strings and reals on the stacks complicate matters even more.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
#define FORWARD goto forward
#define BACKWARD goto backward
static void
mark_variable(start)
Word start;
{ register Word current; /* current cell examined */
register word val; /* old value of current cell */
register Word next; /* cell to be examined */
DEBUG(2, printf("marking 0x%lx\n", start));
if ( marked(start) )
sysError("Attempth to mark twice");
local_marked++;
current = start;
mark_first(current);
val = get_value(current);
total_marked--; /* do not count local stack cell */
FORWARD;
forward: /* Go into the tree */
if ( marked(current) ) /* have been here */
BACKWARD;
domark(current);
if ( isRef(val) )
{ next = unRef(val); /* address pointing to */
if ( next < gBase )
sysError("REF pointer to 0x%lx\n", next);
needsRelocation(current);
relocation_refs++;
if ( is_first(next) ) /* ref to choice point. we will */
BACKWARD; /* get there some day anyway */
val = get_value(next); /* invariant */
set_value(next, makeRef(current)); /* create backwards pointer */
DEBUG(5, printf("Marking REF from 0x%lx to 0x%lx\n", current, next));
current = next; /* invariant */
FORWARD;
}
/* This is isTerm(); but that is not selective enough (TROUBLE) */
if ( isPointer(val) &&
isPointer(get_value((Word)val)) &&
((FunctorDef)get_value((Word)val))->type == FUNCTOR_TYPE )
{ int args;
needsRelocation(current);
next = (Word) val; /* address of term on global stack */
if ( next < gBase || next >= gTop )
sysError("TERM pointer to 0x%lx\n", next);
if ( marked(next) )
BACKWARD; /* term has already been marked */
args = functorTerm(val)->arity - 1; /* members to flag first */
DEBUG(5, printf("Marking TERM %s/%d at 0x%lx\n", stringAtom(functorTerm(val)->name), args+1, next));
domark(next);
for( next += 2; args > 0; args--, next++ )
mark_first(next);
next--; /* last cell of term */
val = get_value(next); /* invariant */
set_value(next, (word)current); /* backwards pointer (NO ref!) */
current = next;
FORWARD;
}
if ( isIndirect(val) ) /* string or real pointer */
{ next = (Word) unMask(val);
if ( next < gBase )
sysError("INDIRECT pointer from 0x%lx to 0x%lx\n", current, next);
needsRelocation(current);
relocation_indirect++;
if ( marked(next) ) /* can be referenced from multiple */
BACKWARD; /* places */
domark(next);
DEBUG(3, printf("Marked indirect data type, size = %ld\n",
offset_cell(next) + 1));
total_marked += offset_cell(next);
}
BACKWARD;
backward: /* reversing backwards */
if ( !is_first(current) )
{ if ( isRef(get_value(current)) ) /* internal cell */
{ next = unRef(get_value(current));
set_value(current, val); /* restore its value */
val = makeRef(current); /* invariant */
current = next; /* invariant */
BACKWARD;
} else /* first cell of term */
{ next = (Word) get_value(current);
set_value(current, val); /* elements of term ok now */
val = (word)(current - 1); /* invariant */
current = next;
BACKWARD;
}
}
unmark_first(current);
if ( current == start )
return;
{ word tmp;
tmp = get_value(current);
set_value(current, val); /* restore old value */
current--;
val = get_value(current); /* invariant */
set_value(current, tmp);
FORWARD;
}
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
References from foreign code.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static void
mark_foreign()
{ Lock l;
for( l = pBase; l < pTop; l++ )
{ switch( l->type )
{ case L_WORD:
{ Word sp = (Word) (l->value << 2);
if ( isGlobalRef(*sp) );
{ DEBUG(5, printf("Marking foreign value at 0x%lx\n"));
mark_variable(sp);
}
break;
}
case L_POINTER:
{ Word *sp = (Word *) (l->value << 2);
if ( !marked(*sp) && isGlobalRef(**sp) )
{ DEBUG(5, printf("Marking foreign pointer at 0x%lx\n"));
mark_variable(*sp);
}
break;
}
case L_MARK:
break;
}
}
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Marking the environments.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static void
clear_uninitialised(fr, PC)
LocalFrame fr;
Code PC;
{ if ( PC != NULL )
{ Code branch_end = NULL;
for( ; ; PC += (codeTable[decode(*PC)].arguments + 1))
{ switch(decode(*PC))
{ case I_EXIT:
return;
case C_JMP:
if ( PC >= branch_end )
branch_end = PC + PC[1] + 2;
break;
case B_FIRSTVAR:
case B_ARGFIRSTVAR:
case C_VAR:
if ( varFrameP(fr, PC[1]) < argFrameP(fr, fr->procedure->functor->arity) )
sysError("Reset instruction on argument");
if ( PC >= branch_end )
setVar(varFrame(fr, PC[1]));
break;
}
if ( decode(*PC) > I_HIGHEST )
sysError("GC: Illegal WAM instruction: %d", decode(*PC));
}
}
}
static LocalFrame
mark_environments(fr)
LocalFrame fr;
{ Code PC = NULL;
if ( fr == (LocalFrame) NULL )
return (LocalFrame) NULL;
for( ; ; )
{ int slots;
Word sp;
if ( true(fr, FR_MARKED) )
return (LocalFrame) NULL; /* from choicepoints only */
set(fr, FR_MARKED);
DEBUG(2, printf("Marking [%ld] %s\n",
levelFrame(fr), procedureName(fr->procedure)));
clear_uninitialised(fr, PC);
slots = (PC == NULL ? fr->procedure->functor->arity : slotsFrame(fr));
sp = argFrameP(fr, 0);
for( ; slots > 0; slots--, sp++ )
{ if ( !marked(sp) )
{ if ( isGlobalRef(*sp) )
mark_variable(sp);
else
ldomark(sp);
}
}
PC = fr->programPointer;
if ( fr->parent != NULL )
fr = fr->parent;
else
return parentFrame(fr); /* Prolog --> C --> Prolog calls */
}
}
static void
mark_choicepoints(bfr)
LocalFrame bfr;
{ TrailEntry te = tTop - 1;
trailcells_deleted = 0;
for( ; bfr != (LocalFrame)NULL; bfr = bfr->backtrackFrame )
{ Word top = argFrameP(bfr, bfr->procedure->functor->arity);
for( ; te >= bfr->mark.trailtop; te-- ) /* early reset of vars */
{ if ( te->address >= top )
{ te->address = (Word) NULL;
trailcells_deleted++;
} else if ( !marked(te->address) )
{ setVar(*te->address);
DEBUG(3, printf("Early reset of 0x%lx\n", te->address));
te->address = (Word) NULL;
trailcells_deleted++;
}
}
needsRelocation((Word)&bfr->mark.trailtop);
into_relocation_chain((Word)&bfr->mark.trailtop);
mark_environments(bfr);
}
DEBUG(3, printf("Trail stack garbage: %ld cells\n", trailcells_deleted));
}
static void
mark_stacks(fr)
LocalFrame fr;
{ LocalFrame pfr;
if ( (pfr = mark_environments(fr)) != NULL )
mark_stacks(pfr);
mark_choicepoints(fr);
}
#if O_DEBUG
static int
cmp_address(p1, p2)
Word *p1, *p2;
{ return *p1 > *p2 ? 1 : *p1 == *p2 ? 0 : -1;
}
#endif
static void
mark_phase(fr)
LocalFrame fr;
{ total_marked = 0;
#if O_DEBUG
mark_top = mark_base = (Word *) addPointer(lTop, 8192); /* hack */
#endif
mark_foreign();
mark_stacks(fr);
#if O_DEBUG
qsort(mark_base, mark_top - mark_base, sizeof(Word), cmp_address);
#endif
DEBUG(2, { long size = gTop - gBase;
printf("%ld referenced cell; %ld garbage (gTop = 0x%lx)\n",
total_marked, size - total_marked, gTop);
});
}
/********************************
* COMPACTING *
*********************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Relocation chain management
A relocation chain is a linked chain of cells, whose elements all should
point to `dest' after it is unwound. SWI-Prolog knows about a number of
different pointers. This routine is supposed to restore the correct
pointer. The following types are identified:
source types
local address values (gTop references)
term, reference and indirect pointers
trail address values (reset addresses)
global term, reference and indirect pointers
To do this, a pointer of the same type is stored in the relocation
chain.
update_relocation_chain(current, dest)
This function checks whether current is the head of a relocation
chain. As we know `dest' is the place `current' is going to
move to, we can reverse the chain and have all pointers in it
pointing to `dest'.
We must clear the `first' bit on the field.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static void
update_relocation_chain(current, dest)
Word current, dest;
{ if ( is_first(current) )
{ Word head = current;
word val = get_value(current);
DEBUG(2, printf("unwinding relocation chain at 0x%lx to 0x%lx\n", current, dest));
do
{ unmark_first(current);
if ( isRef(val) )
{ current = unRef(val);
val = get_value(current);
DEBUG(2, printf("Ref from 0x%lx\n", current));
set_value(current, makeRef(dest));
} else if ( isIndirect(val) )
{ current = (Word)unMask(val);
val = get_value(current);
DEBUG(2, printf("Indirect link from 0x%lx\n", current));
set_value(current, (word)dest | INDIRECT_MASK);
} else
{ current = (Word) val;
val = get_value(current);
DEBUG(2, printf("Pointer from 0x%lx\n", current));
set_value(current, (word)dest);
}
relocated_cells++;
} while( is_first(current) );
set_value(head, val);
relocation_chains--;
}
}
static void
into_relocation_chain(current)
Word current;
{ Word head;
word val = get_value(current);
if ( isRef(val) )
{ head = unRef(val);
set_value(current, get_value(head));
set_value(head, makeRef(current));
relocation_refs--;
} else if ( isIndirect(val) )
{ head = (Word)unMask(val);
set_value(current, get_value(head));
set_value(head, (word)current | INDIRECT_MASK);
relocation_indirect--;
} else
{ head = (Word) val;
set_value(current, get_value(head));
set_value(head, (word)current);
}
DEBUG(2, printf("Into relocation chain: 0x%lx (head = 0x%lx)\n", current, head));
if ( is_first(head) )
mark_first(current);
else
{ mark_first(head);
relocation_chains++;
}
relocation_cells++;
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Trail stack compacting.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static void
compact_trail()
{ TrailEntry dest, current;
Lock l;
/* get foreign references into the relocation chains */
for( l = pBase; l < pTop; l++ )
{ if ( l->type == L_MARK )
{ mark *m = (mark *) (l->value << 2);
if ( m->trailtop > tTop )
sysError("Illegal trail mark from foreign code");
DEBUG(5, printf("Foreign mark: "));
needsRelocation((Word) &m->trailtop);
into_relocation_chain((Word) &m->trailtop);
}
}
/* compact the trail stack */
for( dest = current = tBase; current < tTop; )
{ if ( is_first((Word) current) )
update_relocation_chain((Word) current, (Word) dest);
#if O_DEBUG
else
{ Symbol s;
if ( (s=lookupHTable(check_table, current)) != NULL && s->value == TRUE )
sysError("0x%lx was supposed to be relocated (*= 0x%lx)",
current, current->address);
}
#endif
if ( current->address != (Word) NULL )
*dest++ = *current++;
else
current++;
}
if ( is_first((Word) current) )
update_relocation_chain((Word) current, (Word) dest);
tTop = dest;
if ( relocated_cells != relocation_cells )
sysError("After trail: relocation cells = %ld; relocated_cells = %ld\n",
relocation_cells, relocated_cells);
}
static void
sweep_mark(m)
mark *m;
{ Word gm, prev;
gm = m->globaltop;
for(;;)
{ if ( gm == gBase )
{ m->globaltop = gm;
break;
}
prev = previous_gcell(gm);
if ( marked(prev) )
{ m->globaltop = gm;
DEBUG(2, printf("gTop mark from choice point: "));
needsRelocation((Word) &m->globaltop);
into_relocation_chain((Word) &m->globaltop);
break;
}
gm = prev;
}
}
static void
sweep_foreign()
{ Lock l;
for( l = pBase; l < pTop; l++ )
{ switch( l->type )
{ case L_WORD:
{ Word sp = (Word) (l->value << 2);
unmark(sp);
if ( isGlobalRef(get_value(sp)) )
{ DEBUG(5, printf("Foreign value: "));
check_relocation(sp);
into_relocation_chain(sp);
}
break;
}
case L_POINTER:
{ Word *sp = (Word *) (l->value << 2);
if ( marked(*sp) && isGlobalRef(get_value(*sp)) )
{ DEBUG(5, printf("Foreign pointer: "));
check_relocation(*sp);
into_relocation_chain(*sp);
}
break;
}
case L_MARK:
DEBUG(5, printf("Foreign mark: "));
sweep_mark((mark *) (l->value << 2));
break;
}
}
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
Sweeping the local and trail stack to insert necessary pointers in the
relocation chains.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static void
sweep_trail()
{ register TrailEntry te = tTop - 1;
for( ; te >= tBase; te-- )
{ if ( onGlobal(te->address) )
{ needsRelocation((Word) &te->address);
into_relocation_chain((Word) &te->address);
}
}
}
static LocalFrame
sweep_environments(fr)
LocalFrame fr;
{ Code PC = NULL;
if ( fr == (LocalFrame) NULL )
return (LocalFrame) NULL;
for( ; ; )
{ int slots;
Word sp;
if ( false(fr, FR_MARKED) )
return (LocalFrame) NULL;
clear(fr, FR_MARKED);
slots = (PC == NULL ? fr->procedure->functor->arity : slotsFrame(fr));
sp = argFrameP(fr, 0);
for( ; slots > 0; slots--, sp++ )
{ if ( marked(sp) )
{ unmark(sp);
if ( isGlobalRef(get_value(sp)) )
{ local_marked--;
check_relocation(sp);
into_relocation_chain(sp);
}
}
}
PC = fr->programPointer;
if ( fr->parent != NULL )
fr = fr->parent;
else
return parentFrame(fr); /* Prolog --> C --> Prolog calls */
}
}
static void
sweep_choicepoints(bfr)
LocalFrame bfr;
{ for( ; bfr != (LocalFrame)NULL; bfr = bfr->backtrackFrame )
{ sweep_environments(bfr);
sweep_mark(&bfr->mark);
}
}
static void
sweep_stacks(fr)
LocalFrame fr;
{ LocalFrame pfr;
if ( (pfr = sweep_environments(fr)) != NULL )
sweep_stacks(pfr);
sweep_choicepoints(fr);
}
static void
sweep_local(fr)
LocalFrame fr;
{ sweep_stacks(fr);
if ( local_marked != 0 )
sysError("local_marked = %ld", local_marked);
}
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
All preparations have been made now, and the actual compacting of the
global stack may start. The marking phase has calculated the total
number of words (cells) in the global stack that are none-garbage.
In the first phase, we will walk along the global stack from it's
current top towards the bottom. During this phase, `current' refers to
the current element we are processing, while `dest' refers to the place
this element will be after the compacting phase is completed. This
invariant is central and should be maintained carefully while processing
alien objects as strings and reals, which happen to have a non-standard
size.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
static bool
is_downward_ref(p)
Word p;
{ word val = get_value(p);
if ( isRef(val) )
{ DEBUG(5, if ( unRef(val) < p ) printf("REF: "));
return unRef(val) < p;
}
if ( isVar(val) || isInteger(val) )
fail;
if ( isIndirect(val) )
{ DEBUG(5, if ( (Word)unMask(val) < p ) printf("INDIRECT: "));
return (Word)unMask(val) < p;
}
DEBUG(5, if ( (Word)val < p && (Word)val >= gBase ) printf("TERM: "));
if ( (Word)val < p && (Word)val >= gBase && !marked((Word)val) )
sysError("Pointer to term should be marked (down)");
return (Word)val < p && (Word)val >= gBase;
}
static bool
is_upward_ref(p)
Word p;
{ word val = get_value(p);
if ( isRef(val) )
return unRef(val) > p;
if ( isVar(val) || isInteger(val) )
fail;
if ( isIndirect(val) )
return (Word)unMask(val) > p;
if ( (Word)val > p && (Word)val < gTop && !marked((Word)val) )
sysError("Pointer to term should be marked (up) \n\
p = 0x%lx, val = 0x%lx, *val = 0x%lx, gTop = 0x%lx",
p, val, *((Word)val), gTop);
return (Word)val > p && (Word)val < gTop;
}
static void
compact_global()
{ Word dest, current;
#if O_DEBUG
Word *v = mark_top;
#endif
DEBUG(2, printf("Scanning global stack downwards\n"));
dest = gBase + total_marked; /* first FREE cell */
for( current = gTop; current >= gBase; current-- )
{ long offset = (marked(current) || is_first(current) ? 0
: offset_cell(current));
current -= offset;
if ( marked(current) )
{
#if O_DEBUG
if ( current != *--v )
sysError("Marked cell at 0x%lx (*= 0x%lx); gTop = 0x%lx; should have been 0x%lx", current, *current, gTop, *v);
#endif
dest -= offset + 1;
DEBUG(3, printf("Marked cell at 0x%lx (size = %ld; dest = 0x%lx)\n",
current, offset+1, dest));
update_relocation_chain(current, dest);
if ( is_downward_ref(current) )
{ check_relocation(current);
into_relocation_chain(current);
}
} else
{ update_relocation_chain(current, dest); /* gTop refs from marks */
}
}
#if O_DEBUG
if ( v != mark_base )
{ for( v--; v >= mark_base; v-- )
{ printf("Expected marked cell at 0x%lx, (*= 0x%lx)\n", *v, **v);
}
sysError("v = 0x%lx; mark_base = 0x%lx", v, mark_base);
}
#endif
if ( dest != gBase )
sysError("Mismatch in down phase: dest = 0x%lx, gBase = 0x%lx\n",
dest, gBase);
if ( relocation_cells != relocated_cells )
sysError("After down phase: relocation_cells = %ld; relocated_cells = %ld",
relocation_cells, relocated_cells);
DEBUG(2, printf("Scanning global stack upwards\n"));
dest = gBase;
for(current = gBase; current < gTop; )
{ if ( marked(current) )
{ long l, n;
update_relocation_chain(current, dest);
if ( (l = offset_cell(current)) == 0 ) /* normal cells */
{ *dest = *current;
if ( is_upward_ref(current) )
{ check_relocation(current);
into_relocation_chain(dest);
}
unmark(dest);
dest++;
current++;
} else /* indirect values */
{ Word cdest, ccurrent;
l++;
for( cdest=dest, ccurrent=current, n=0; n < l; n++ )
*cdest++ = *ccurrent++;
unmark(dest);
dest += l;
current += l;
}
} else
current += offset_cell(current) + 1;
}
if ( dest != gBase + total_marked )
sysError("Mismatch in up phase: dest = 0x%lx, gBase + total_marked = 0x%lx\n", dest, gBase + total_marked );
gTop = dest;
}
static void
collect_phase(fr)
LocalFrame fr;
{ DEBUG(2, printf("Sweeping foreign references\n"));
sweep_foreign();
DEBUG(2, printf("Sweeping trail stack\n"));
sweep_trail();
DEBUG(2, printf("Sweeping local stack\n"));
sweep_local(fr);
DEBUG(2, printf("Compacting global stack\n"));
compact_global();
if ( relocation_chains != 0 )
sysError("relocation chains = %ld", relocation_chains);
if ( relocated_cells != relocation_cells ||
relocated_cells != needs_relocation ||
relocation_refs != 0 || relocation_indirect != 0)
sysError("relocation cells = %ld; relocated_cells = %ld, needs_relocation = %ld\n\trelocation_refs = %ld, relocation_indirect = %ld",
relocation_cells, relocated_cells, needs_relocation,
relocation_refs, relocation_indirect);
}
/********************************
* MAIN *
*********************************/
static long gsmall = 200000L;
static long tsmall = 100000L;
word
pl_collect_parms(g, t)
Word g, t;
{ if ( !isInteger(*g) || !isInteger(*t) )
return warning("$collect_parms/2: instantiation fault");
gsmall = valNum(*g);
tsmall = valNum(*t);
succeed;
}
#if O_DYNAMIC_STACKS
void
considerGarbageCollect(s)
Stack s;
{ if ( s == (Stack) &stacks.global )
{ Word gsegb = (gc_status.segment ? gc_status.segment->mark.globaltop
: gBase);
if ( s->max - (caddress)gsegb > (caddress)gsegb - s->base + gsmall )
{ DEBUG(1, printf("Global overflow: Posted garbage collect request\n"));
gc_status.requested = TRUE;
#if O_PROFILE
PROCEDURE_garbage_collect0->definition->profile_calls++;
#endif
}
}
if ( s == (Stack) &stacks.trail )
{ TrailEntry tsegb = (gc_status.segment ? gc_status.segment->mark.trailtop
: tBase);
if ( s->max - (caddress)tsegb > (caddress)tsegb - s->base + tsmall )
{ DEBUG(1, printf("Trail overflow: Posted garbage collect request\n"));
gc_status.requested = TRUE;
#if O_PROFILE
PROCEDURE_garbage_collect0->definition->profile_calls++;
#endif
}
}
}
#endif /* O_DYNAMIC_STACKS */
#if O_DEBUG
static bool
scan_global()
{ Word current;
int errors = 0;
long cells = 0;
for( current = gBase; current < gTop; current += (offset_cell(current)+1) )
{ cells++;
if ( (Word)(*current) >= gBase && (Word)(*current) < gTop )
if ( !isTerm(*current) )
sysError("Pointer on global stack is not a term");
if ( marked(current) || is_first(current) )
{ warning("Illegal cell in global stack (up) at 0x%lx (*= 0x%lx)", current, *current);
if ( isAtom(*current) )
warning("0x%lx is atom %s", current, stringAtom(*current));
if ( isTerm(*current) )
warning("0x%lx is term %s/%d", current,
stringAtom(functorTerm(*current)->name),
functorTerm(*current)->arity);
if ( ++errors > 10 )
{ printf("...\n");
break;
}
}
}
for( current = gTop - 1; current >= gBase; current-- )
{ cells --;
current -= offset_cell(current);
if ( marked(current) || is_first(current) )
{ warning("Illegal cell in global stack (down) at 0x%lx (*= 0x%lx)", current, *current);
if ( ++errors > 10 )
{ printf("...\n");
break;
}
}
}
if ( !errors && cells != 0 )
sysError("Different count of cells upwards and downwards: %ld\n", cells);
return errors == 0;
}
#endif
void
garbageCollect(fr)
LocalFrame fr;
{ long tgar, ggar;
real t = CpuTime();
if ( gc_status.blocked )
return;
gc_status.requested = FALSE;
gc_status.active = TRUE;
DEBUG(0, printf("Garbage collect ... "));
#if O_DEBUG
if ( !scan_global() )
sysError("Stack not ok at gc entry");
if ( check_table == NULL )
check_table = newHTable(256);
else
clearHTable(check_table);
#endif
needs_relocation = 0;
relocation_chains = 0;
relocation_cells = 0;
relocated_cells = 0;
local_marked = 0;
relocation_refs = 0;
relocation_indirect = 0;
STACKVERIFY( if ( gTop + 1 >= gMax ) outOf((Stack) &stacks.global) );
setVar(*gTop);
STACKVERIFY( if ( tTop + 1 >= tMax ) outOf((Stack) &stacks.trail) );
tTop->address = NULL;
mark_phase(fr);
tgar = trailcells_deleted * sizeof(struct trail_entry);
ggar = (gTop - gBase - total_marked) * sizeof(word);
gc_status.trail_gained += tgar;
gc_status.global_gained += ggar;
gc_status.collections++;
gc_status.segment = fr;
DEBUG(2, printf("Compacting trail ... "));
compact_trail();
collect_phase(fr);
#if O_DEBUG
if ( !scan_global() )
sysError("Stack not ok after gc; gTop = 0x%lx", gTop);
#endif
DEBUG(0, printf("gained %ld+%ld bytes (now: %ld+%ld bytes)\n",
ggar, tgar,
(gTop-gBase)*sizeof(word),
(tTop-tBase)*sizeof(word)));
gc_status.time += CpuTime() - t;
pl_trim_stacks();
gc_status.active = FALSE;
}
word
pl_garbage_collect(d)
Word d;
{ LocalFrame fr = environment_frame;
#if O_DEBUG
int ol = status.debugLevel;
if ( !isInteger(*d) )
return warning("garbage_collect/1: instantiation fault");
status.debugLevel = (int) valNum(*d);
#endif
gc_status.blocked--;
garbageCollect(fr);
gc_status.blocked++;
#if O_DEBUG
status.debugLevel = ol;
#endif
succeed;
}
void
resetGC()
{ gc_status.requested = FALSE;
gc_status.blocked = 0;
gc_status.segment = NULL;
gc_status.collections = gc_status.global_gained = gc_status.trail_gained = 0;
gc_status.time = 0.0;
}
/********************************
* LOCKING FOREIGN DATA *
*********************************/
/* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
There are various types of foreign data that are of interest to the
garbage collector. First of all the internal code both supports `word'
and `Word'. Both can refer to the stacks. Their value is non-garbage
and should be relocated similar to local stack variables. Second are
marks (Mark() and Undo()). Marks kept by foreign code should be treated
equal to marks kept in the choicepoints on the local stack.
- - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
void
lockw(p)
Word p;
{ Lock l = pTop++;
verifyStack(lock);
l->type = L_WORD;
l->value = (unsigned) p >> 2;
}
void
lockp(p)
Word *p;
{ Lock l = pTop++;
verifyStack(lock);
l->type = L_POINTER;
l->value = (unsigned) p >> 2;
}
void
lockMark(m)
mark *m;
{ Lock l = pTop++;
verifyStack(lock);
l->type = L_MARK;
l->value = (unsigned) m >> 2;
}
void
unlockw(p)
Word p;
{ if ( ((--pTop)->value << 2) != (unsigned)p )
sysError("Mismatch in lock()/unlock()\n");
}
void
unlockp(p)
Word *p;
{ if ( ((--pTop)->value << 2) != (unsigned)p )
sysError("Mismatch in lock()/unlock()\n");
}
void
unlockMark(m)
mark *m;
{ if ( ((--pTop)->value << 2) != (unsigned)m )
sysError("Mismatch in lock()/unlock()\n");
}