This is heap.c in view mode; [Download] [Up]
/* SCHEME->C */
/* Copyright 1989 Digital Equipment Corporation
* All Rights Reserved
*
* Permission to use, copy, and modify this software and its documentation is
* hereby granted only under the following terms and conditions. Both the
* above copyright notice and this permission notice must appear in all copies
* of the software, derivative works or modified versions, and any portions
* thereof, and both notices must appear in supporting documentation.
*
* Users of this software agree to the terms and conditions set forth herein,
* and hereby grant back to Digital a non-exclusive, unrestricted, royalty-free
* right and license under any changes, enhancements or extensions made to the
* core functions of the software, including but not limited to those affording
* compatibility with other hardware or software environments, but excluding
* applications which incorporate this software. Users further agree to use
* their best efforts to return to Digital any such changes, enhancements or
* extensions that they make and inform Digital of noteworthy uses of this
* software. Correspondence should be provided to Digital at:
*
* Director of Licensing
* Western Research Laboratory
* Digital Equipment Corporation
* 100 Hamilton Avenue
* Palo Alto, California 94301
*
* This software may be distributed (but not offered for sale or transferred
* for compensation) to third parties, provided such third parties agree to
* abide by the terms and conditions of this notice.
*
* THE SOFTWARE IS PROVIDED "AS IS" AND DIGITAL EQUIPMENT CORP. DISCLAIMS ALL
* WARRANTIES WITH REGARD TO THIS SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF
* MERCHANTABILITY AND FITNESS. IN NO EVENT SHALL DIGITAL EQUIPMENT
* CORPORATION BE LIABLE FOR ANY SPECIAL, DIRECT, INDIRECT, OR CONSEQUENTIAL
* DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM LOSS OF USE, DATA OR
* PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE OR OTHER TORTIOUS
* ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS
* SOFTWARE.
*/
/* This module implements the object storage storage system. */
/* Import definitions */
#include "objects.h"
#include "scinit.h"
#include "heap.h"
#include "callcc.h"
#include "signal.h"
#include "apply.h"
extern abort();
#ifdef GGC
#include "GGC.h"
#endif
#ifdef MIPS
extern sc_s0tos8();
#endif
#ifdef VAX
extern sc_r2tor11();
#endif
#ifdef APOLLO
extern sc_regs();
#endif
#if defined(SUN3) || defined(NeXT)
extern sc_a2to5d2to7();
#endif
/* Forward declarations */
extern int move_ptr();
extern SCP move_object();
/* Allocate storage which is defined in "heap.h" */
int *sc_pagegeneration, /* page generation table */
*sc_pagetype, /* page type table */
*sc_pagelock, /* page lock table */
*sc_pagelink, /* page lock list link table */
sc_initiallink, /* Value to put in sc_pagelink field for a
newly allocated page */
sc_locklist, /* list header for locked pages */
sc_genlist, /* list of modified pages */
sc_lockcnt, /* # of locked pages */
sc_current_generation, /* current generation */
sc_next_generation; /* next generation */
int sc_firstheappage, /* first page in the Scheme heap */
sc_lastheappage, /* last page in the Scheme heap */
sc_limit, /* % of heap allocated after collecton
that forces total collection */
sc_freepage, /* free page index */
sc_heappages, /* # of pages in the Scheme heap */
sc_allocatedheappages, /* # of pages currently allocated */
sc_generationpages, /* # of pages in saved generations */
*sc_firstheapp, /* ptr to first word in the Scheme heap */
*sc_lastheapp; /* ptr to last word in the Scheme heap */
int sc_conscnt; /* # cons cells in sc_consp */
SCP sc_consp; /* pointer to next cons cell */
int sc_extobjwords, /* # of words for ext objs in sc_extobjp */
sc_extwaste; /* # of words wasted on page crossings */
SCP sc_extobjp; /* pointer to next free extended obj word */
int sc_gcinfo; /* controls logging */
#ifndef SYSV
static struct rusage gcru, /* resource consumption during collection */
startru,
stopru;
#endif
int *sc_stackbase; /* pointer to base of the stack */
TSCP sc_whenfreed, /* list of items needing cleanup when free */
sc_freed; /* list of free items to be cleanup */
TSCP sc_after_2dcollect_v; /* Collection status callback */
#ifndef SYSV
/* The following function converts a rusage structure into an 18 word Scheme
vector composed of the same items.
*/
static TSCP rusagevector( ru )
struct rusage *ru;
{
TSCP v;
PATSCP ve;
v = sc_make_2dvector( C_FIXED( 18 ), EMPTYLIST );
ve = &(T_U( v )->vector.element0);
*ve++ = C_FIXED( ru->ru_utime.tv_sec );
*ve++ = C_FIXED( ru->ru_utime.tv_usec );
*ve++ = C_FIXED( ru->ru_stime.tv_sec );
*ve++ = C_FIXED( ru->ru_stime.tv_usec );
*ve++ = C_FIXED( ru->ru_maxrss );
*ve++ = C_FIXED( ru->ru_ixrss );
*ve++ = C_FIXED( ru->ru_idrss );
*ve++ = C_FIXED( ru->ru_isrss );
*ve++ = C_FIXED( ru->ru_minflt );
*ve++ = C_FIXED( ru->ru_majflt );
*ve++ = C_FIXED( ru->ru_nswap );
*ve++ = C_FIXED( ru->ru_inblock );
*ve++ = C_FIXED( ru->ru_oublock );
*ve++ = C_FIXED( ru->ru_msgsnd );
*ve++ = C_FIXED( ru->ru_msgrcv );
*ve++ = C_FIXED( ru->ru_nsignals );
*ve++ = C_FIXED( ru->ru_nvcsw );
*ve++ = C_FIXED( ru->ru_nivcsw );
return( v );
}
/* Garbage collector resource usage is accumulated by the following function.
It will accumlate the resources used in gcru, and change stopru to reflect
the resource usage this collection.
*/
static updategcru()
{
int x;
/* Compute deltas in stopru */
if (stopru.ru_utime.tv_usec < startru.ru_utime.tv_usec) {
stopru.ru_utime.tv_sec = stopru.ru_utime.tv_sec-
startru.ru_utime.tv_sec-1;
stopru.ru_utime.tv_usec = 1000000+stopru.ru_utime.tv_usec-
startru.ru_utime.tv_usec;
}
else {
stopru.ru_utime.tv_sec = stopru.ru_utime.tv_sec-
startru.ru_utime.tv_sec;
stopru.ru_utime.tv_usec = stopru.ru_utime.tv_usec-
startru.ru_utime.tv_usec;
}
if (stopru.ru_stime.tv_usec < startru.ru_stime.tv_usec) {
stopru.ru_stime.tv_sec = stopru.ru_stime.tv_sec-
startru.ru_stime.tv_sec-1;
stopru.ru_stime.tv_usec = 1000000+stopru.ru_stime.tv_usec-
startru.ru_stime.tv_usec;
}
else {
stopru.ru_stime.tv_sec = stopru.ru_stime.tv_sec-
startru.ru_stime.tv_sec;
stopru.ru_stime.tv_usec = stopru.ru_stime.tv_usec-
startru.ru_stime.tv_usec;
}
stopru.ru_minflt -= startru.ru_minflt;
stopru.ru_majflt -= startru.ru_majflt;
stopru.ru_nswap -= startru.ru_nswap;
stopru.ru_inblock -= startru.ru_inblock;
stopru.ru_oublock -= startru.ru_oublock;
stopru.ru_msgsnd -= startru.ru_msgsnd;
stopru.ru_msgrcv -= startru.ru_msgrcv;
stopru.ru_nsignals -= startru.ru_nsignals;
stopru.ru_nvcsw -= startru.ru_nvcsw;
stopru.ru_nivcsw -= startru.ru_nivcsw;
/* Accumulate totals in gcru */
x = gcru.ru_utime.tv_usec+stopru.ru_utime.tv_usec;
gcru.ru_utime.tv_usec = x % 1000000;
gcru.ru_utime.tv_sec = gcru.ru_utime.tv_sec+stopru.ru_utime.tv_sec+
x / 1000000;
x = gcru.ru_stime.tv_usec+stopru.ru_stime.tv_usec;
gcru.ru_stime.tv_usec = x % 1000000;
gcru.ru_stime.tv_sec = gcru.ru_stime.tv_sec+stopru.ru_stime.tv_sec+
x / 1000000;
gcru.ru_maxrss = stopru.ru_maxrss;
gcru.ru_ixrss = stopru.ru_ixrss;
gcru.ru_idrss = stopru.ru_idrss;
gcru.ru_minflt += stopru.ru_minflt;
gcru.ru_majflt += stopru.ru_majflt;
gcru.ru_nswap += stopru.ru_nswap;
gcru.ru_inblock += stopru.ru_inblock;
gcru.ru_oublock += stopru.ru_oublock;
gcru.ru_msgsnd += stopru.ru_msgsnd;
gcru.ru_msgrcv += stopru.ru_msgrcv;
gcru.ru_nsignals += stopru.ru_nsignals;
gcru.ru_nvcsw += stopru.ru_nvcsw;
gcru.ru_nivcsw += stopru.ru_nivcsw;
}
/* The following function returns the resource usage information for the
process. It returns a vector formed of the elements in the rusage struct
returned by getrusage. It is visible in Scheme as (MY-RUSAGE).
*/
TSCP sc_my_2drusage_v;
TSCP sc_my_2drusage()
{
struct rusage ru;
getrusage( 0, &ru );
return( rusagevector( &ru ) );
}
/* The following function returns the resource usage information for the
garbage collector. It returns a vector formed of the elements in the rusage
struct maintained by the collector. It is visible in Scheme as
(COLLECT-RUSAGE).
*/
TSCP sc_collect_2drusage_v;
TSCP sc_collect_2drusage()
{
return( rusagevector( &gcru ) );
}
#else
#define getrusage(x,y) /* no operation */
#define updategcru() /* no operation */
#endif /* SYSV-BSD dependency */
/* Errors detected during garbage collection are logged by the following
procedure. If any errors occur, the program will abort after logging
them. More than 30 errors will result in the program being aborted at
once
*/
static SCP moving_object;
static int pointer_errors = 0;
static void pointererror( msg, pp )
SCP pp;
{
fprintf( stderr, "***** COLLECT pointer error in %x, ",
moving_object );
fprintf( stderr, msg, pp );
if (++pointer_errors == 30) abort();
}
#ifdef TITAN
/* The following function is called to read one of the Titan registers. It
must be open-coded using constant register numbers as zzReadRegister is
actually a Mahler inline function which expects a constant register
number.
*/
int *sc_processor_register( regnum )
{
switch (regnum) {
case 0: return( zzReadRegister( 0 ) );
case 1: return( zzReadRegister( 1 ) );
case 2: return( zzReadRegister( 2 ) );
case 3: return( zzReadRegister( 3 ) );
case 4: return( zzReadRegister( 4 ) );
case 5: return( zzReadRegister( 5 ) );
case 6: return( zzReadRegister( 6 ) );
case 7: return( zzReadRegister( 7 ) );
case 8: return( zzReadRegister( 8 ) );
case 9: return( zzReadRegister( 9 ) );
case 10: return( zzReadRegister( 10 ) );
case 11: return( zzReadRegister( 11 ) );
case 12: return( zzReadRegister( 12 ) );
case 13: return( zzReadRegister( 13 ) );
case 14: return( zzReadRegister( 14 ) );
case 15: return( zzReadRegister( 15 ) );
case 16: return( zzReadRegister( 16 ) );
case 17: return( zzReadRegister( 17 ) );
case 18: return( zzReadRegister( 18 ) );
case 19: return( zzReadRegister( 19 ) );
case 20: return( zzReadRegister( 20 ) );
case 21: return( zzReadRegister( 21 ) );
case 22: return( zzReadRegister( 22 ) );
case 23: return( zzReadRegister( 23 ) );
case 24: return( zzReadRegister( 24 ) );
case 25: return( zzReadRegister( 25 ) );
case 26: return( zzReadRegister( 26 ) );
case 27: return( zzReadRegister( 27 ) );
case 28: return( zzReadRegister( 28 ) );
case 29: return( zzReadRegister( 29 ) );
case 30: return( zzReadRegister( 30 ) );
case 31: return( zzReadRegister( 31 ) );
case 32: return( zzReadRegister( 32 ) );
case 33: return( zzReadRegister( 33 ) );
case 34: return( zzReadRegister( 34 ) );
case 35: return( zzReadRegister( 35 ) );
case 36: return( zzReadRegister( 36 ) );
case 37: return( zzReadRegister( 37 ) );
case 38: return( zzReadRegister( 38 ) );
case 39: return( zzReadRegister( 39 ) );
case 40: return( zzReadRegister( 40 ) );
case 41: return( zzReadRegister( 41 ) );
case 42: return( zzReadRegister( 42 ) );
case 43: return( zzReadRegister( 43 ) );
case 44: return( zzReadRegister( 44 ) );
case 45: return( zzReadRegister( 45 ) );
case 46: return( zzReadRegister( 46 ) );
case 47: return( zzReadRegister( 47 ) );
case 48: return( zzReadRegister( 48 ) );
case 49: return( zzReadRegister( 49 ) );
case 50: return( zzReadRegister( 50 ) );
case 51: return( zzReadRegister( 51 ) );
case 52: return( zzReadRegister( 52 ) );
case 53: return( zzReadRegister( 53 ) );
case 54: return( zzReadRegister( 54 ) );
case 55: return( zzReadRegister( 55 ) );
case 56: return( zzReadRegister( 56 ) );
case 57: return( zzReadRegister( 57 ) );
case 58: return( zzReadRegister( 58 ) );
case 59: return( zzReadRegister( 59 ) );
case 60: return( zzReadRegister( 60 ) );
case 61: return( zzReadRegister( 61 ) );
case 62: return( zzReadRegister( 62 ) );
case 63: return( zzReadRegister( 63 ) );
default: return( 0 );
}
}
/* All processor registers are traced by the following procedure. */
static trace_stack_and_registers()
{
int i, *r0tor60[ 61 ], *pp;
for (i = 0; i <= 60; i++) r0tor60[ i ] = sc_processor_register( i );
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
#endif /* TITAN */
#ifdef VAX
/* The following code is used to read the stack pointer. The register
number is passed in to force an argument to be on the stack, which in
turn can be used to find the address of the top of stack.
*/
int *sc_processor_register( reg )
int reg;
{
return( ®+1 );
}
/* All processor registers which might contain pointers are traced by the
following procedure.
*/
static trace_stack_and_registers()
{
int i, r2tor11[10], *pp;
sc_r2tor11( r2tor11 );
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
#endif /* VAX */
#ifdef MIPS
/* The following code is used to read the stack pointer. The register
number is passed in to force an argument to be on the stack, which in
turn can be used to find the address of the top of stack.
*/
int *sc_processor_register( reg )
int reg;
{
return( ® );
}
/* All processor registers which might contain pointers are traced by the
following procedure.
*/
static trace_stack_and_registers()
{
int i, s0tos8[9], *pp;
sc_s0tos8( s0tos8 );
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
#endif /* MIPS */
#ifdef APOLLO
/* The following code is used to read the stack pointer. The register
number is passed in to force an argument to be on the stack, which in
turn can be used to find the address of the top of stack.
*/
int *sc_processor_register( reg )
int reg;
{
return( ® );
}
/* All processor registers that might contain pointers are traced by the
following procedure.
*/
static trace_stack_and_registers()
{
int i, a1toa4_d0tod7[12], *pp;
sc_regs( a1toa4_d0tod7 );
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
#endif /* APOLLO */
#ifdef PRISM
/* All processor registers that might contain pointers are traced by the
following procedure.
*/
static trace_stack_and_registers()
{
int i, regs[12], *pp;
sc_regs( regs );
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
#endif /* PRISM */
#ifdef SPARC
/* All processor registers which might contain pointers are traced by the
following procedure.
*/
static trace_stack_and_registers()
{
int i, *pp;
jmp_buf tmp;
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
#endif SPARC
#if defined(SUN3) || defined(NeXT)
/* The following code is used to read the stack pointer. The register
number is passed in to force an argument to be on the stack, which in
turn can be used to find the address of the top of stack.
*/
int *sc_processor_register( reg )
int reg;
{
return( ®+1 );
}
/* All processor registers which might contain pointers are traced by the
following procedure.
*/
static trace_stack_and_registers()
{
int i, a2to5d2to7[10], *pp;
sc_a2to5d2to7( a2to5d2to7 );
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
#endif /* SUN3 or NeXT */
#ifdef I386
/* The following code is used to read the stack pointer. The register
number is passed in to force an argument to be on the stack, which in
turn can be used to find the address of the top of stack.
*/
int *sc_processor_register( reg )
int reg;
{
return( ® );
}
/* All processor registers which might contain pointers are traced by the
following procedure.
*/
static trace_stack_and_registers()
{
int i, *pp;
jmp_buf tmp;
setjmp(tmp);
pp = STACKPTR;
while (pp != sc_stackbase) move_continuation_ptr( *pp++ );
}
#endif I386
/* The size of an extended object in words is returned by the following
function.
*/
static int extendedsize( obj )
SCP obj;
{
switch (obj->extendedobj.tag) {
case SYMBOLTAG:
return( SYMBOLSIZE );
case STRINGTAG:
return( STRINGSIZE( obj->string.length ) );
case VECTORTAG:
return( VECTORSIZE( obj->vector.length ) );
case PROCEDURETAG:
return( PROCEDURESIZE );
case CLOSURETAG:
return( CLOSURESIZE( obj->closure.length ) );
case CONTINUATIONTAG:
return( CONTINUATIONSIZE( obj->continuation.length ) );
case FLOAT32TAG:
return( FLOAT32SIZE );
case FLOAT64TAG:
return( FLOAT64SIZE );
case FORWARDTAG:
return( FORWARDSIZE( obj->forward.length ) );
case WORDALIGNTAG:
return( WORDALIGNSIZE );
default:
fprintf( stderr,
"***** COLLECT Unknown extended object: %x %x\n",
obj, obj->extendedobj.tag );
abort();
}
}
/* Words inside continuations are checked by the following function. If the
word looks like a pointer, then the page containing the object will be
locked and the object will be moved.
*/
static move_continuation_ptr( pp )
SCP pp;
{
int page, tag;
SCP sweep, next;
if (pp >= (SCP)sc_firstheapp && pp < (SCP)sc_lastheapp) {
page = ADDRESS_PAGE( pp );
if (sc_current_generation == sc_pagegeneration[ page ]) {
tag = sc_pagetype[ page ];
if (tag == PAIRTAG) {
/* Trace just that PAIR */
pp = (SCP)(((int)pp) & ~(CONSBYTES-1));
if (sc_pagelock[ page ] == 0) {
sc_pagelock[ page ] = 1;
sc_pagelink[ page ] = sc_locklist;
sc_locklist = page;
sc_lockcnt = sc_lockcnt+1;
#ifdef GGC
GGCmarkLocked( page, 1 );
#endif
}
if (sc_gcinfo == 2 && pp->forward.tag != FORWARDTAG)
fprintf( stderr,
" move_continuation_ptr %x\n",
U_T( pp, PAIRTAG ) );
move_ptr( U_T( pp, PAIRTAG ) );
return;
}
/* Trace the referenced object */
if (tag == BIGEXTENDEDTAG) {
while (sc_pagetype[ page ] != EXTENDEDTAG) page--;
}
sweep = (SCP)PAGE_ADDRESS( page );
if (sc_pagelock[ page ] == 0) {
sc_pagelock[ page ] = 1;
sc_pagelink[ page ] = sc_locklist;
sc_locklist = page;
if (sweep->wordalign.tag == WORDALIGNTAG) {
sweep = (SCP)( ((int*)sweep)+WORDALIGNSIZE );
}
sc_lockcnt = (extendedsize( sweep )+PAGEWORDS-1)/PAGEWORDS+
sc_lockcnt;
#ifdef GGC
GGCmarkLocked( sc_locklist, (extendedsize( sweep )+
PAGEWORDS-1)/PAGEWORDS );
#endif
}
while (ADDRESS_PAGE( sweep ) == page &&
sweep->unsi.gned != ENDOFPAGE) {
next = (SCP)( ((int*)sweep)+extendedsize( sweep ) );
if ((unsigned)pp < (unsigned)next) {
/* sweep points to object to move */
if (sc_gcinfo == 2 && sweep->forward.tag != FORWARDTAG)
fprintf( stderr,
" move_continuation_ptr %x\n",
U_TX( sweep ) );
move_ptr( U_TX( sweep ) );
return;
}
sweep = next;
}
}
}
}
/* Objects are moved from old space to new space by calling this procedure
with a Scheme pointer to the object. Note that this function does not
return the new value of the pointer, as it cannot be discerned at this time
as all locked pages may not have been found yet. N.B. in the generational
scheme, only objects in sc_current_generation are moved.
*/
static move_ptr( tpp )
TSCP tpp;
{
int length, words, *oldp, *newp, page;
TSCP new;
SCP pp;
pp = T_U( tpp );
switch TSCPTAG( tpp ) {
case FIXNUMTAG:
return;
case EXTENDEDTAG:
page = ADDRESS_PAGE( pp );
if (page < sc_firstheappage || page > sc_lastheappage ||
pp->forward.tag == FORWARDTAG ||
pp->wordalign.tag == WORDALIGNTAG ||
sc_pagegeneration[ page ] != sc_current_generation)
return;
if (sc_pagetype[ page ] != EXTENDEDTAG) {
pointererror( "%x not in an EXTENDEDTAG page\n", pp );
return;
}
words = extendedsize( pp );
length = words;
newp = (int*)sc_allocateheap( extendedsize( pp ),
pp->extendedobj.tag, 0 );
new = U_T( newp, EXTENDEDTAG );
oldp = (int*)pp;
while (words--) *newp++ = *oldp++;
pp->forward.tag = FORWARDTAG;
pp->forward.length = length;
pp->forward.forward = new;
return;
case IMMEDIATETAG:
return;
case PAIRTAG:
page = ADDRESS_PAGE( pp );
if (pp->forward.tag == FORWARDTAG ||
sc_pagegeneration[ page ] != sc_current_generation)
return;
if (sc_pagetype[ page ] != PAIRTAG) {
pointererror( "%x not in a PAIRTAG page\n", pp );
return;
}
pp->forward.forward = sc_cons( pp->pair.car, pp->pair.cdr );
pp->forward.tag = FORWARDTAG;
pp->forward.length = CONSSIZE;
return;
}
}
/* MOVE_OBJECT is called to move all extended objects in a page starting at
a starting point. It will return a pointer to the first object that it
could not move, or NULL if the page was finished.
*/
static SCP move_object( pp )
SCP pp;
{
int page, size, cnt, vpage;
PATSCP obj;
page = ADDRESS_PAGE( pp );
while (ADDRESS_PAGE( pp ) == page &&
(pp != sc_extobjp || sc_extobjwords == 0) &&
pp->unsi.gned != ENDOFPAGE) {
moving_object = pp;
switch ( pp->extendedobj.tag ) {
case SYMBOLTAG:
move_ptr( pp->symbol.name );
vpage = ADDRESS_PAGE( pp->symbol.ptrtovalue );
if (vpage >= sc_firstheappage && vpage <= sc_lastheappage)
pp->symbol.ptrtovalue = &pp->symbol.value;
move_ptr( *pp->symbol.ptrtovalue );
move_ptr( pp->symbol.propertylist );
size = SYMBOLSIZE;
break;
case STRINGTAG:
size = STRINGSIZE( pp->string.length );
break;
case VECTORTAG:
cnt = pp->vector.length;
obj = &pp->vector.element0;
while (cnt--) move_ptr( *obj++ );
size = VECTORSIZE( pp->vector.length );
break;
case PROCEDURETAG:
move_ptr( pp->procedure.closure );
size = PROCEDURESIZE;
break;
case CLOSURETAG:
move_ptr( pp->closure.closure );
cnt = pp->closure.length;
obj = &pp->closure.var0;
while (cnt--) move_ptr( *obj++ );
size = CLOSURESIZE( pp->closure.length );
break;
case CONTINUATIONTAG:
move_ptr( pp->continuation.continuation );
obj = &pp->continuation.continuation;
cnt = pp->continuation.length;
while (cnt--) move_continuation_ptr( *(++obj) );
size = CONTINUATIONSIZE( pp->continuation.length );
break;
case FLOAT32TAG:
size = FLOAT32SIZE;
break;
case FLOAT64TAG:
size = FLOAT64SIZE;
break;
case FORWARDTAG:
size = FORWARDSIZE( pp->forward.length );
break;
case WORDALIGNTAG:
size = WORDALIGNSIZE;
break;
default:
pointererror( "%x is not a valid extended object tag\n",
pp->extendedobj.tag );
}
pp = (SCP)( ((int*)pp)+size );
}
if (ADDRESS_PAGE( pp ) == page && pp == sc_extobjp &&
sc_extobjwords != 0)
return( pp );
return( NULL );
}
/* The following function is called to resolve a pointer that might be
forwarded. It returns the resolved pointer.
*/
static TSCP resolveptr( obj )
TSCP obj;
{
if ((TSCPTAG( obj ) & 1) && (T_U( obj )->forward.tag == FORWARDTAG))
return( T_U( obj )->forward.forward );
return( obj );
}
/* Once all objects are moved, objects needing special action on deletion are
discovered by examining SC_WHENFREED. All objects that have not been moved
are placed on SC_FREED, and those that have been moved are retained on
SC_WHENFREED.
*/
static check_unreferenced()
{
TSCP objects, object_procedure, object;
objects = resolveptr( sc_whenfreed );
sc_whenfreed = EMPTYLIST;
while (objects != EMPTYLIST) {
object_procedure = resolveptr( PAIR_CAR( objects ) );
object = PAIR_CAR( object_procedure );
if (object == resolveptr( object ) &&
sc_pagegeneration[ ADDRESS_PAGE( object ) ] ==
sc_current_generation) {
/* Object was not forwarded, so it needs to be cleaned up. */
sc_freed = sc_cons( object_procedure, sc_freed );
}
else {
/* Object was forwarded, so leave it on sc_whenfreed. */
sc_whenfreed = sc_cons( object_procedure, sc_whenfreed );
}
objects = resolveptr( PAIR_CDR( objects ) );
}
}
/* The moves are coordinated by the following function which moves objects on
newly allocated pages until there is nothing left to move.
*/
static move_the_heap( startpage )
int startpage;
{
int progress, consstart, extstart, count, unreferenced;
SCP myconsp, myextobjp, newp;
myconsp = NULL;
consstart = startpage;
myextobjp = NULL;
extstart = startpage;
unreferenced = 1;
progress = 1;
while (progress--) {
/* Move all the currently allocated, but unmoved pairs. */
while (myconsp == NULL && consstart != sc_freepage) {
if (sc_pagegeneration[ consstart ] == sc_next_generation &&
sc_pagetype[ consstart ] == PAIRTAG)
myconsp = (SCP)PAGE_ADDRESS( consstart );
consstart = NEXTPAGE( consstart );
}
if (myconsp != NULL &&
(myconsp != sc_consp || sc_conscnt == 0)) {
count = (PAGEBYTES-ADDRESS_OFFSET( myconsp ))/CONSBYTES;
progress = 1;
while (count-- && (myconsp != sc_consp || sc_conscnt == 0)) {
moving_object = myconsp;
move_ptr( myconsp->pair.car );
move_ptr( myconsp->pair.cdr );
myconsp = (SCP)(((char*)myconsp)+CONSBYTES);
}
if (count == -1) myconsp = NULL;
}
/* Move all currently allocated, but unmoved extended items */
while (myextobjp == NULL && extstart != sc_freepage) {
if (sc_pagegeneration[ extstart ] == sc_next_generation &&
sc_pagetype[ extstart ] == EXTENDEDTAG)
myextobjp = (SCP)PAGE_ADDRESS( extstart );
extstart = NEXTPAGE( extstart );
}
if (myextobjp != NULL) {
newp = move_object( myextobjp );
if (newp != myextobjp) progress = 1;
myextobjp = newp;
}
/* Find unreferenced objects needing cleanup */
if (progress == 0 && unreferenced) {
unreferenced = 0;
check_unreferenced();
progress = 1;
}
}
if (pointer_errors) abort();
}
/* Objects in the current generation that have references in previous
generations are moved in the following routine.
*/
static move_the_generations()
{
int page = sc_genlist, count;
SCP myconsp;
/* Correct the newly allocated pages */
while (page != -1) {
switch (sc_pagetype[ page ]) {
case PAIRTAG:
myconsp = (SCP)PAGE_ADDRESS( page );
count = PAGEBYTES/CONSBYTES;
while (count--) {
move_ptr( myconsp->pair.car );
move_ptr( myconsp->pair.cdr );
myconsp = (SCP)(((char*)myconsp)+CONSBYTES);
}
break;
case EXTENDEDTAG:
move_object( (SCP)PAGE_ADDRESS( page ) );
break;
}
page = sc_pagelink[ page ];
}
}
/* Once all objects are moved, pointers can be corrected to either point to the
new object (when it can be copied), or point to the old object (when the
page is locked). This is done by the following function which takes a
tagged pointer as its argument and returns the new value of the pointer.
*/
static TSCP correct( tobj )
TSCP tobj;
{
SCP obj;
if (((int)tobj) & 1) {
obj = T_U( tobj );
if ( (obj->forward.tag != FORWARDTAG) ||
sc_pagelock[ ADDRESS_PAGE( obj ) ] ) return tobj;
return( obj->forward.forward );
}
return( tobj );
}
/* The pointers within extended objects are corrected by the following
function. It is called with a pointer to an object. All objects which
follow it on that page will be corrected.
*/
static correct_object( pp )
SCP pp;
{
int page, size, cnt;
PATSCP obj;
page = ADDRESS_PAGE( pp );
while (ADDRESS_PAGE( pp ) == page &&
pp->unsi.gned != ENDOFPAGE &&
(pp != sc_extobjp || sc_extobjwords == 0)) {
switch ( pp->extendedobj.tag ) {
case SYMBOLTAG:
pp->symbol.name = correct( pp->symbol.name );
*pp->symbol.ptrtovalue = correct( *pp->symbol.ptrtovalue );
pp->symbol.propertylist = correct( pp->symbol.propertylist );
size = SYMBOLSIZE;
break;
case STRINGTAG:
size = STRINGSIZE( pp->string.length );
break;
case VECTORTAG:
cnt = pp->vector.length;
obj = &pp->vector.element0;
while (cnt--) {
*obj = correct( *obj );
obj++;
}
size = VECTORSIZE( pp->vector.length );
break;
case PROCEDURETAG:
pp->procedure.closure = correct( pp->procedure.closure );
size = PROCEDURESIZE;
break;
case CLOSURETAG:
pp->closure.closure = correct( pp->closure.closure );
cnt = pp->closure.length;
obj = &pp->closure.var0;
while (cnt--) {
*obj = correct( *obj );
obj++;
}
size = CLOSURESIZE( pp->closure.length );
break;
case CONTINUATIONTAG:
pp->continuation.continuation =
correct( pp->continuation.continuation );
size = CONTINUATIONSIZE( pp->continuation.length );
break;
case FLOAT32TAG:
size = FLOAT32SIZE;
break;
case FLOAT64TAG:
size = FLOAT64SIZE;
break;
case WORDALIGNTAG:
size = WORDALIGNSIZE;
break;
default:
fprintf( stderr,
"***** COLLECT Unknown extended object: %x %x\n",
pp, pp->extendedobj.tag );
abort();
}
pp = (SCP)( ((int*)pp)+size );
}
}
/* Pointer correction is driven by the following function which corrects all
pointers in the newly allocated storage.
*/
static correct_all_pointers( startpage )
int startpage;
{
int count;
PATSCP ptr;
/* Correct the newly allocated pages */
while (startpage != sc_freepage) {
if (sc_pagegeneration[ startpage ] == sc_next_generation) {
switch (sc_pagetype[ startpage ]) {
case PAIRTAG:
ptr = (PATSCP)PAGE_ADDRESS( startpage );
count = PAGEBYTES/(CONSBYTES/2);
while (count-- &&
(sc_consp != (SCP)ptr || sc_conscnt == 0)) {
if ((*((int*)ptr) & 1) &&
(T_U(*ptr)->forward.tag == FORWARDTAG) &&
(sc_pagelock[ ADDRESS_PAGE( *ptr ) ] == 0))
*ptr = T_U(*ptr)->forward.forward;
ptr++;
}
break;
case EXTENDEDTAG:
correct_object( (SCP)PAGE_ADDRESS( startpage ) );
break;
}
}
startpage = NEXTPAGE( startpage );
}
}
/* Pointer correction to newly allocated storage in previous generations is
done by the following procedure.
*/
static correct_all_generations()
{
int page = sc_genlist, count, i;
PATSCP ptr;
/* Correct the newly allocated pages */
while (page != -1) {
switch (sc_pagetype[ page ]) {
case PAIRTAG:
ptr = (PATSCP)PAGE_ADDRESS( page );
count = PAGEBYTES/(CONSBYTES/2);
while (count--) {
if ((*((int*)ptr) & 1) &&
(T_U(*ptr)->forward.tag == FORWARDTAG) &&
(sc_pagelock[ ADDRESS_PAGE( *ptr ) ] == 0))
*ptr = T_U(*ptr)->forward.forward;
ptr++;
}
i = page;
page = sc_pagelink[ page ];
sc_pagelink[ i ] = 0;
break;
case EXTENDEDTAG:
correct_object( (SCP)PAGE_ADDRESS( page ) );
i = page;
page = sc_pagelink[ page ];
do sc_pagelink[ i++ ] = 0;
while (i <= sc_lastheappage &&
sc_pagetype[ i ] == BIGEXTENDEDTAG);
break;
}
}
}
/* After pointers have been corrected, the items on locked pages need to have
their correct version (found in the new copy) copied to the old page. In
addition, objects which were not forwarded must be changed so that their
pointers will no longer be followed. This is done by setting the CAR and
CDR of the pair to 0, and turning extended objects into strings. Pages
that are locked are added to sc_genlist so that will be checked on the
next collection.
*/
static copyback_locked_pages( locklist )
int locklist;
{
int page, count, vpage;
SCP obj, fobj, sobj;
while (locklist) {
page = locklist;
#ifdef GGC
GGCmarkUnlock( page );
#endif
obj = (SCP)PAGE_ADDRESS( page );
sc_pagelock[ page ] = 0;
sc_pagegeneration[ page ] = sc_next_generation;
locklist = sc_pagelink[ locklist ];
sc_pagelink[ page ] = sc_genlist;
sc_genlist = page;
if (sc_pagetype[ page ] == PAIRTAG) {
/* Move back only the forwarded CONS cells */
count = PAGEBYTES/CONSBYTES;
while (count--) {
if (obj->forward.tag == FORWARDTAG) {
fobj = T_U( obj->forward.forward );
obj->pair.car = fobj->pair.car;
obj->pair.cdr = fobj->pair.cdr;
}
else {
obj->pair.car = 0;
obj->pair.cdr = 0;
}
obj = (SCP)((char*)(obj)+CONSBYTES);
}
}
else if (sc_pagetype[ page ] == EXTENDEDTAG) {
/* Move extra pages into the next generation */
if (obj->wordalign.tag == WORDALIGNTAG) {
obj = (SCP)( ((int*)obj)+WORDALIGNSIZE );
}
count = extendedsize( obj );
vpage = page;
while (count > PAGEWORDS) {
sc_pagegeneration[ ++vpage ] = sc_next_generation;
sc_pagelink[ vpage ] = OKTOSET;
count = count-PAGEWORDS;
#ifdef GGC
GGCmarkUnlock( vpage );
#endif
}
/* Move back the forwarded extended items */
while (ADDRESS_PAGE( obj ) == page &&
(obj != sc_extobjp || sc_extobjwords == 0) &&
obj->unsi.gned != ENDOFPAGE) {
if (obj->forward.tag == FORWARDTAG) {
sobj = obj;
fobj = T_U( obj->forward.forward );
count = obj->forward.length;
while (count--) {
*((int*)obj) = *((int*)fobj);
obj = (SCP)(((int*)obj)+1);
fobj = (SCP)(((int*)fobj)+1);
}
if (sobj->symbol.tag == SYMBOLTAG) {
vpage = ADDRESS_PAGE( sobj->symbol.ptrtovalue );
if (vpage >= sc_firstheappage &&
vpage <= sc_lastheappage)
sobj->symbol.ptrtovalue = &sobj->symbol.value;
}
}
else if (obj->wordalign.tag == WORDALIGNTAG) {
obj = (SCP)( ((int*)obj)+WORDALIGNSIZE );
}
else {
count = extendedsize( obj );
obj->string.length = ((count-2)*4)+3;
obj->string.tag = STRINGTAG;
obj = (SCP)( ((int*)obj)+count );
}
}
}
}
}
/* This function is called to check the obarray to make sure that it is
intact.
*/
static int check_obarray()
{
int i, len, page;
PATSCP ep;
TSCP lp, symbol, value;
SCP obarray;
obarray = T_U( sc_obarray );
if (TSCPTAG( sc_obarray ) != EXTENDEDTAG ||
obarray->vector.tag != VECTORTAG) {
fprintf( stderr, "***** COLLECT OBARRAY is not a vector %x\n",
sc_obarray );
abort();
}
len = obarray->vector.length;
if (len != 1023) {
fprintf( stderr, "***** COLLECT OBARRAY length is wrong %x\n",
sc_obarray );
abort();
}
ep = &obarray->vector.element0;
for (i = 0; i < len; i++) {
lp = *ep++;
while (lp != EMPTYLIST) {
if (TSCPTAG( lp ) != PAIRTAG) {
fprintf( stderr,
"***** COLLECT OBARRAY element is not a list %x\n",
lp );
abort();
}
symbol = T_U( lp )->pair.car;
if (T_U( symbol )->symbol.tag != SYMBOLTAG) {
fprintf( stderr,
"***** COLLECT OBARRAY entry is not a symbol %x\n",
symbol );
abort();
}
page = ADDRESS_PAGE( symbol );
if (sc_pagegeneration[ page ] & 1 &&
sc_pagegeneration[ page ] != sc_current_generation) {
fprintf( stderr,
"***** COLLECT OBARRAY symbol generation error %x\n",
symbol );
abort();
}
value = *T_U( symbol )->symbol.ptrtovalue;
page = ADDRESS_PAGE( value );
if (TSCPTAG( value ) & 1 &&
page >= sc_firstheappage && page <= sc_lastheappage &&
sc_pagegeneration[ page ] & 1 &&
sc_pagegeneration[ page ] != sc_current_generation) {
fprintf( stderr,
"***** COLLECT OBARRAY value generation error %x\n",
symbol );
abort();
}
if (TSCPTAG( value ) & 1 &&
(~sc_pagegeneration[ ADDRESS_PAGE( symbol ) ]) & 1 &&
sc_pagegeneration[ page ] == sc_current_generation &&
sc_pagelink[ ADDRESS_PAGE( symbol ) ] == 0 &&
ADDRESS_PAGE( symbol ) ==
ADDRESS_PAGE( T_U( symbol )->symbol.ptrtovalue )) {
fprintf( stderr,
"***** COLLECT OBARRAY missed a top-level set! %x\n",
symbol );
abort();
}
if (sc_pagetype[ ADDRESS_PAGE( symbol ) ] != EXTENDEDTAG) {
fprintf( stderr,
"***** COLLECT OBARRAY symbol page type error %x\n",
symbol );
abort();
}
lp = T_U( lp )->pair.cdr;
}
}
}
/* The following procedure verifies that a pointer is correct. */
static check_ptr( tpp )
TSCP tpp;
{
int page;
page = ADDRESS_PAGE( tpp );
if (page >= sc_firstheappage && page <= sc_lastheappage &&
((int) tpp) & 1) {
if ((sc_pagegeneration[ page ] != sc_current_generation &&
sc_pagegeneration[ page ] & 1) ||
sc_pagetype[ page ] != TSCPTAG( tpp )) {
pointererror( "%x fails check_ptr\n", T_U( tpp ) );
}
}
else if (TSCPTAG( tpp ) == PAIRTAG) {
pointererror( "%x fails check_ptr\n", T_U( tpp ) );
}
}
/* A page of objects is checked by the following procedure. */
static SCP check_object( pp )
SCP pp;
{
int page, size, cnt, vpage;
PATSCP obj;
page = ADDRESS_PAGE( pp );
while (ADDRESS_PAGE( pp ) == page &&
(pp != sc_extobjp || sc_extobjwords == 0) &&
pp->unsi.gned != ENDOFPAGE) {
moving_object = pp;
switch ( pp->extendedobj.tag ) {
case SYMBOLTAG:
check_ptr( pp->symbol.name );
vpage = ADDRESS_PAGE( pp->symbol.ptrtovalue );
if (vpage >= sc_firstheappage && vpage <= sc_lastheappage)
pp->symbol.ptrtovalue = &pp->symbol.value;
check_ptr( *pp->symbol.ptrtovalue );
check_ptr( pp->symbol.propertylist );
size = SYMBOLSIZE;
break;
case STRINGTAG:
size = STRINGSIZE( pp->string.length );
break;
case VECTORTAG:
cnt = pp->vector.length;
obj = &pp->vector.element0;
while (cnt--) check_ptr( *obj++ );
size = VECTORSIZE( pp->vector.length );
break;
case PROCEDURETAG:
check_ptr( pp->procedure.closure );
size = PROCEDURESIZE;
break;
case CLOSURETAG:
check_ptr( pp->closure.closure );
cnt = pp->closure.length;
obj = &pp->closure.var0;
while (cnt--) check_ptr( *obj++ );
size = CLOSURESIZE( pp->closure.length );
break;
case CONTINUATIONTAG:
check_ptr( pp->continuation.continuation );
size = CONTINUATIONSIZE( pp->continuation.length );
break;
case FLOAT32TAG:
size = FLOAT32SIZE;
break;
case FLOAT64TAG:
size = FLOAT64SIZE;
break;
case FORWARDTAG:
size = FORWARDSIZE( pp->forward.length );
break;
case WORDALIGNTAG:
size = WORDALIGNSIZE;
break;
default:
pointererror( "%x is not a valid extended object tag\n",
pp->extendedobj.tag );
}
pp = (SCP)( ((int*)pp)+size );
}
if (ADDRESS_PAGE( pp ) == page && pp == sc_extobjp &&
sc_extobjwords != 0)
return( pp );
return( NULL );
}
/* A page of pairs is checkled by the following procedure. */
static void check_pairs( pp )
SCP pp;
{
int count;
PATSCP ptr;
ptr = (PATSCP)pp;
count = (PAGEBYTES/CONSBYTES)*2;
while (count-- &&
(ptr != (PATSCP)sc_consp || sc_conscnt == 0)) {
moving_object = (SCP)(((unsigned)ptr) & 0xfffffff8);
check_ptr( *ptr );
ptr++;
}
}
/* The following function can be called to check that all objects in the
heap are valid.
*/
static void check_heap( )
{
int i;
/* Verify that all pages containing pairs are in good shape */
for (i = sc_firstheappage; i <= sc_lastheappage; i++) {
if ((sc_pagegeneration[ i ] == sc_current_generation ||
~sc_pagegeneration[ i ] & 1)) {
if (sc_pagetype[ i ] == PAIRTAG) {
check_pairs( (SCP)PAGE_ADDRESS( i ) );
}
if (sc_pagetype[ i ] == EXTENDEDTAG) {
check_object( (SCP)PAGE_ADDRESS( i ) );
}
}
}
if (pointer_errors) abort();
}
/* Garbage collection is invoked to attempt to recover free storage when a
request for storage cannot be met. It will recover using a generational
version of the "mostly copying" method. See the .h file or the research
report for more details.
*/
TSCP sc_collect_v;
TSCP sc_collect()
{
int i, wasallocated, startpage;
TSCP constl;
#ifdef GGC
GGCbeginCollection();
#endif
if (sc_current_generation != sc_next_generation) {
fprintf( stderr, "***** COLLECT Out of space during collection\n" );
abort();
}
sc_gcinprogress( 1 );
sc_initiallink = ~OKTOSET;
wasallocated = sc_allocatedheappages;
if (sc_gcinfo == 2) {
/* Perform additional consistency checks */
check_obarray();
check_heap();
}
if (sc_gcinfo) {
fprintf( stderr,
"\n***** COLLECT %d%% allocated (%d%% waste) -> \n",
(wasallocated*100)/sc_heappages,
(sc_extwaste*100)/(sc_heappages*PAGEWORDS) );
}
getrusage( 0, &startru );
/* Zero the current cons block, end the current extended block,
initialize sc_locklist, advance the generation.
*/
sc_conscnt = sc_conscnt+sc_conscnt;
while (sc_conscnt-- > 0) {
*((int*)sc_consp) = 0;
sc_consp = (SCP)(((int*)sc_consp)+1);
}
sc_conscnt = 0;
if (sc_extobjwords) {
sc_extobjp->unsi.gned = ENDOFPAGE;
sc_extobjwords = 0;
}
sc_extwaste = 0;
sc_allocatedheappages = 0;
sc_locklist = 0;
sc_lockcnt = 0;
sc_next_generation = INC_GENERATION( sc_current_generation );
startpage = sc_freepage;
/* Move the globals, display, and constants (as needed) */
for ( i = 0; i < sc_globals->count; i++ ) {
move_ptr( *(sc_globals->ptrs[ i ]) );
}
for ( i = 0; i < sc_maxdisplay; i++ ) move_ptr( sc_display[ i ] );
if (sc_pagegeneration[ ADDRESS_PAGE( *(sc_constants->ptrs[ 0 ]) ) ] ==
sc_current_generation) {
for ( i = 0; i < sc_constants->count; i++ )
move_ptr( *(sc_constants->ptrs[ i ]) );
}
/* Look into the stack and the registers and treat anything that
might be a pointer as a root and move it.
*/
trace_stack_and_registers();
#ifdef GGC
GGCafterLockingInCollection();
#endif
/* Move new objects referenced in previous generations */
move_the_generations();
/* Continue the moving the current generation until it terminates */
move_the_heap( startpage );
sc_allocatedheappages = sc_allocatedheappages+sc_lockcnt;
/* Correct pointers in the copied heap */
correct_all_pointers( startpage );
/* Correct pointers in previous generations */
correct_all_generations();
/* Correct pointers in globals, display, and constants (if moved) */
for ( i = 0; i < sc_globals->count; i++ )
*(sc_globals->ptrs[ i ]) = correct( *(sc_globals->ptrs[ i ]) );
for ( i = 0; i < sc_maxdisplay; i++ )
sc_display[ i ] = correct( sc_display[ i ] );
if (sc_pagegeneration[ ADDRESS_PAGE( *(sc_constants->ptrs[ 0 ]) ) ] ==
sc_current_generation) {
for ( i = 0; i < sc_constants->count; i++ )
*(sc_constants->ptrs[ i ]) =
correct( *(sc_constants->ptrs[ i ]) );
}
/* Copy back the locked objects and add locked pages to sc_genlist */
sc_genlist = -1;
copyback_locked_pages( sc_locklist );
#ifdef GGC
GGCafterUnlockingInCollection();
#endif
/* Fully allocate partial pages and step to the next odd generation */
sc_conscnt = sc_conscnt+sc_conscnt;
while (sc_conscnt-- > 0) {
*((int*)sc_consp) = 0;
sc_consp = (SCP)(((int*)sc_consp)+1);
}
sc_conscnt = 0;
if (sc_extobjwords) {
sc_extobjp->unsi.gned = ENDOFPAGE;
sc_extobjwords = 0;
}
sc_next_generation = sc_current_generation =
INC_GENERATION( sc_next_generation );
sc_generationpages = sc_generationpages+sc_allocatedheappages;
sc_allocatedheappages = sc_generationpages;
/* Finish up */
getrusage( 0, &stopru );
updategcru();
if (sc_gcinfo) {
#ifndef SYSV
fprintf( stderr,
" %d%% locked %d%% retained %d user ms",
(sc_lockcnt*100)/sc_heappages,
(sc_generationpages*100)/sc_heappages,
stopru.ru_utime.tv_sec*1000+stopru.ru_utime.tv_usec/1000 );
fprintf( stderr,
" %d system ms %d page faults\n",
stopru.ru_stime.tv_sec*1000+stopru.ru_stime.tv_usec/1000,
stopru.ru_majflt );
#else
fprintf( stderr,
" %d%% locked %d%% retained\n",
(sc_lockcnt*100)/sc_heappages,
(sc_generationpages*100)/sc_heappages);
#endif
}
if (sc_gcinfo == 2) {
/* Perform additional consistency checks */
check_obarray();
check_heap();
}
#ifdef GGC
for (i = sc_firstheappage; i <= sc_lastheappage; i++) {
if (sc_pagegeneration[ i ] != sc_current_generation)
GGCmarkFree(i);
}
GGCendCollection();
#endif
/* Compact the whole heap if > sc_limit % of pages allocated */
sc_initiallink = OKTOSET;
sc_gcinprogress( 0 );
if ((sc_allocatedheappages*100)/sc_heappages > sc_limit)
sc_collect_2dall();
if (sc_after_2dcollect_v != FALSEVALUE)
sc_apply_2dtwo( sc_after_2dcollect_v,
sc_cons( C_FIXED( sc_heappages*PAGEBYTES ),
sc_cons( C_FIXED( sc_allocatedheappages*PAGEBYTES ),
sc_cons( C_FIXED( sc_limit ),
EMPTYLIST ) ) ) );
return( TRUEVALUE );
}
/* A complete garbage collection can be forced by calling the following
procedure.
*/
TSCP sc_collect_2dall_v;
TSCP sc_collect_2dall()
{
int i,
save_sc_limit = sc_limit;
MUTEXON;
sc_limit = 100;
if (sc_generationpages != sc_allocatedheappages) sc_collect();
sc_limit = save_sc_limit;
MUTEXOFF;
MUTEXON;
sc_next_generation =
INC_GENERATION( INC_GENERATION( sc_next_generation ) );
sc_current_generation = sc_next_generation;
for (i = sc_firstheappage; i <= sc_lastheappage; i++) {
if (~sc_pagegeneration[ i ] & 1)
sc_pagegeneration[ i ] = sc_current_generation;
}
sc_generationpages = 0;
sc_genlist = -1;
sc_limit = 100;
sc_collect();
sc_limit = save_sc_limit;
MUTEXOFF;
return( TRUEVALUE );
}
/* Pages in the heap are allocated by the following function. It is called
with a page count and sets the appropriate allocation pointers as
required. The sc_pagegeneration, sc_pagelink, sc_pagetype fields are
set for each page here. The garbage collector is invoked as needed.
*/
static int allocatepage_failed = 0; /* Set following collection, cleared on
successful allocation */
static allocatepage( count, tag )
int count, tag;
{
int start, page, freecnt, generation;
if ((count+sc_allocatedheappages) > sc_heappages/2) {
failed:
if (allocatepage_failed) {
fprintf( stderr,
"***** ALLOCATEPAGE cannot allocate %d bytes",
count*PAGEBYTES );
fprintf( stderr, " with %d %% of heap allocated\n",
(sc_allocatedheappages*100)/sc_heappages );
exit( 1 );
}
sc_collect();
allocatepage_failed = 1;
return;
}
start = sc_freepage;
freecnt = 0;
do {
generation = sc_pagegeneration[ sc_freepage ];
if (generation & 1 && generation != sc_current_generation) {
if (freecnt == 0) page = sc_freepage;
freecnt++;
}
else
freecnt = 0;
if (sc_freepage == sc_lastheappage) {
if (freecnt != count) freecnt = 0;
sc_freepage = sc_firstheappage;
}
else sc_freepage++;
if (sc_freepage == start) goto failed;
} while (count != freecnt);
allocatepage_failed = 0;
sc_allocatedheappages = sc_allocatedheappages+count;
sc_pagegeneration[ page ] = sc_next_generation;
sc_pagetype[ page ] = tag;
sc_pagelink[ page ] = sc_initiallink;
if (tag == PAIRTAG) {
sc_conscnt = PAGEBYTES/CONSBYTES;
sc_consp = (SCP)PAGE_ADDRESS( page );
#ifdef GGC
GGCmarkPair( page );
#endif
}
else {
sc_extobjp = (SCP)PAGE_ADDRESS( page );
sc_extobjwords = count*PAGEWORDS;
#ifdef GGC
GGCmarkExtended( page );
GGCmarkContinuations( page+1, count-1 );
#endif
while (--count) {
sc_pagegeneration[ ++page ] = sc_next_generation;
sc_pagetype[ page ] = BIGEXTENDEDTAG;
sc_pagelink[ page ] = sc_initiallink;
}
}
}
/* When a pointer to a new object may be stored in a old page, the following
procedure is called to add the old page to the list of changed older pages
and then do the assignment. N.B. set-top-level-value! may set global
values outside the heap.
*/
TSCP sc_setgeneration( a, b )
TSCP* a;
TSCP b;
{
int oldpage = ADDRESS_PAGE( a );
MUTEXON;
if (oldpage >= sc_firstheappage && oldpage <= sc_lastheappage &&
sc_pagelink[ oldpage ] == 0) {
if (sc_pagetype[ oldpage ] == PAIRTAG) {
if (sc_pagegeneration[ oldpage ] == sc_current_generation) {
sc_pagelink[ oldpage ] = OKTOSET;
}
else {
sc_pagelink[ oldpage ] = sc_genlist;
sc_genlist = oldpage;
}
}
else {
while (sc_pagetype[ oldpage ] == BIGEXTENDEDTAG) oldpage--;
if (sc_pagegeneration[ oldpage ] == sc_current_generation) {
sc_pagelink[ oldpage ] = OKTOSET;
}
else {
sc_pagelink[ oldpage ] = sc_genlist;
sc_genlist = oldpage;
}
while (++oldpage < sc_lastheappage &&
sc_pagetype[ oldpage ] == BIGEXTENDEDTAG) {
sc_pagelink[ oldpage ] = OKTOSET;
}
}
}
*a = b;
MUTEXOFF;
return( b );
}
/* Heap based storage is allocated by the following function. It is called
with a word count and a value to put in the first word. It will return
an UNTAGGED pointer to the storage. Note that the minimum permissible
allocation size is two words.
N.B. IT IS THE CALLER'S RESPONSIBILITY TO ASSURE THAT SIGNALS DO NOT
CAUSE PROBLEMS DURING ALLOCATION.
*/
SCP sc_allocateheap( wordsize, tag, rest )
int wordsize, tag, rest;
{
SCP alloc;
int isastring = (tag == STRINGTAG);
EVEN_EXTOBJP( tag == FLOAT64TAG );
ODD_EXTOBJP( isastring );
if (wordsize <= sc_extobjwords) {
alloc = sc_extobjp;
sc_extobjp = (SCP)(((int*)alloc)+wordsize);
sc_extobjwords = sc_extobjwords-wordsize;
}
else if (wordsize < PAGEWORDS) {
while (wordsize > sc_extobjwords) {
sc_extwaste = sc_extwaste+sc_extobjwords;
if (sc_extobjwords) sc_extobjp->unsi.gned = ENDOFPAGE;
allocatepage( 1, EXTENDEDTAG );
EVEN_EXTOBJP( tag == FLOAT64TAG );
ODD_EXTOBJP( isastring );
}
alloc = sc_extobjp;
sc_extobjwords = sc_extobjwords-wordsize;
sc_extobjp = (SCP)(((int*)alloc)+wordsize);
}
else {
while (wordsize > sc_extobjwords) {
sc_extwaste = sc_extwaste+sc_extobjwords;
if (sc_extobjwords) sc_extobjp->unsi.gned = ENDOFPAGE;
allocatepage( (wordsize+PAGEWORDS-1+isastring)/PAGEWORDS,
EXTENDEDTAG );
}
ODD_EXTOBJP( isastring );
alloc = sc_extobjp;
sc_extobjp = NULL;
sc_extobjwords = 0;
}
alloc->extendedobj.tag = tag;
alloc->extendedobj.rest = rest;
return( alloc );
}
/* 32-bit floating point numbers are constructed by the following function. It
is called with a 32-bit floating point value and it returns a pointer to
the Scheme object with that value.
*/
#ifdef PRISM
TSCP sc_makefloat32( float value )
#else
TSCP sc_makefloat32( value )
float value;
#endif
{
SCP pp;
MUTEXON;
if (sc_extobjwords >= FLOAT32SIZE) {
pp = sc_extobjp;
sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT32SIZE);
sc_extobjwords = sc_extobjwords-FLOAT32SIZE;
pp->float32.tag = FLOAT32TAG;
pp->float32.rest = 0;
}
else
pp = sc_allocateheap( FLOAT32SIZE, FLOAT32TAG, 0 );
pp->float32.value = value;
MUTEXOFF;
return( U_T( pp, EXTENDEDTAG ) );
}
/* 64-bit floating point numbers are constructed by the following function. It
is called with a 64-bit floating point value and it returns a pointer to
the Scheme object with that value.
On the Apollo Prism, it is vital that we use a function prototype,
so the compiler knows that the function's argument is being passed
in a register. Without the prototype, the argument is read from
the stack. See prism.asm for examples where it is simpler to pass
the argument in a register. Also see objects.h for the declaration.
*/
#ifdef PRISM
TSCP sc_makefloat64( double value )
#else
TSCP sc_makefloat64( value )
double value;
#endif
{
SCP pp;
MUTEXON;
EVEN_EXTOBJP( 1 );
if (sc_extobjwords >= FLOAT64SIZE) {
pp = sc_extobjp;
sc_extobjp = (SCP)(((int*)sc_extobjp)+FLOAT64SIZE);
sc_extobjwords = sc_extobjwords-FLOAT64SIZE;
pp->float64.tag = FLOAT64TAG;
pp->float64.rest = 0;
}
else
pp = sc_allocateheap( FLOAT64SIZE, FLOAT64TAG, 0 );
pp->float64.value = value;
MUTEXOFF;
return( U_T( pp, EXTENDEDTAG ) );
}
/* The following function forms a dotted-pair with any two Scheme pointers. It
returns a tagged pointer to the pair as its value.
*/
TSCP sc_cons_v;
TSCP sc_cons( x, y )
TSCP x, y;
{
SCP oconsp;
MUTEXON;
retry:
if (sc_conscnt > 0) {
oconsp = sc_consp;
sc_consp->pair.car = x;
sc_consp->pair.cdr = y;
sc_consp = (SCP)(((int*)sc_consp)+2);
sc_conscnt--;
MUTEXOFF;
return( U_T( oconsp, PAIRTAG ) );
}
allocatepage( 1, PAIRTAG );
goto retry;
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.