2006-08-12 15:00:13 -04:00
|
|
|
//----------------------------------------------------------------------
|
|
|
|
// vx-scheme : Scheme interpreter.
|
|
|
|
// Copyright (c) 2002,2003,2006 Colin Smith.
|
|
|
|
//
|
|
|
|
// You may distribute under the terms of the Artistic License,
|
|
|
|
// as specified in the LICENSE file.
|
|
|
|
//
|
|
|
|
// cell.cpp : cell creation, storage management, garbage collection.
|
|
|
|
|
|
|
|
#include "vx-scheme.h"
|
|
|
|
|
|
|
|
static const char * nomem_error = "out of memory";
|
|
|
|
|
|
|
|
Cell * Context::make ()
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::Cons);
|
|
|
|
c->ca.p = c->cd.p = &Cell::Nil;
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
Cell * Context::make_int (intptr_t i)
|
2006-08-12 15:00:13 -04:00
|
|
|
{
|
|
|
|
// SHORT INTEGER support: if the integer fits in 24 bits,
|
|
|
|
// then return a phony pointer with the short flag set and
|
|
|
|
// the integer in the upper 24. This avoids storage allocation
|
|
|
|
// and the attendant eventual garbage.
|
|
|
|
#if 1
|
|
|
|
if ((i << 8) >> 8 == i) {
|
|
|
|
return reinterpret_cast <Cell*> ((i << 8) | Cell::SHORT | Cell::ATOM);
|
|
|
|
}
|
|
|
|
#endif
|
|
|
|
Cell * c = alloc (Cell::Int);
|
|
|
|
c->cd.i = i;
|
|
|
|
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_char (char ch)
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::Char);
|
|
|
|
c->cd.c = ch;
|
|
|
|
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_real (double d)
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::Real);
|
|
|
|
double *pd = (double*) malloc(sizeof(double));
|
|
|
|
*pd = d;
|
|
|
|
c->cd.d = pd;
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
// Context::make_string
|
|
|
|
// Makes a string of the indicated length -- it is UNINITIALIZED
|
|
|
|
|
|
|
|
Cell * Context::make_string (size_t len)
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::String);
|
|
|
|
size_t boxsize = sizeof(Cell::StringBox) + len + 1;
|
|
|
|
Cell::StringBox* pbox = (Cell::StringBox*) xmalloc (boxsize);
|
|
|
|
pbox->length = len;
|
|
|
|
c->cd.s = pbox;
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_string (int len, char ch)
|
|
|
|
{
|
|
|
|
Cell * c = make_string (len);
|
|
|
|
memset (c->cd.s->s, ch, len);
|
|
|
|
c->cd.s->s[len] = '\0';
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_string (const char * s)
|
|
|
|
{
|
|
|
|
return make_string (s, strlen (s));
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_string (const char * s, size_t len)
|
|
|
|
{
|
|
|
|
Cell * c = make_string (len);
|
|
|
|
strncpy(c->cd.s->s, s, len);
|
|
|
|
c->cd.s->s[len] = '\0';
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_subr (subr_f s, const char * name)
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::Subr);
|
|
|
|
Cell::SubrBox * psubr = new Cell::SubrBox ();
|
|
|
|
psubr->subr = s;
|
|
|
|
psubr->name = name;
|
|
|
|
c->cd.f = psubr;
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_builtin (psymbol y)
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::Builtin);
|
|
|
|
c->cd.y = y;
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_symbol (psymbol y)
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::Symbol);
|
|
|
|
c->cd.y = y;
|
|
|
|
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_boolean (bool b)
|
|
|
|
{
|
|
|
|
return b ? &Cell::Bool_T : &Cell::Bool_F;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_vector (int n, Cell * init /* = &Unspecified */)
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::Vec);
|
|
|
|
c->cd.cv = cellvector::alloc(n);
|
|
|
|
c->flag (Cell::VREF, true);
|
|
|
|
|
|
|
|
for (int ix = 0; ix < n; ++ix)
|
|
|
|
c->cd.cv->set (ix, init);
|
|
|
|
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_iport (const char * fname)
|
|
|
|
{
|
|
|
|
FILE * ip = fopen (fname, "r");
|
|
|
|
if (ip)
|
|
|
|
return make_iport (ip);
|
|
|
|
|
|
|
|
error ("unable to open stream for reading");
|
|
|
|
return nil;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_iport (FILE * ip)
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::Iport);
|
|
|
|
c->cd.ip = ip;
|
|
|
|
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_oport (const char * fname)
|
|
|
|
{
|
|
|
|
FILE * ofs = fopen (fname, "w");
|
|
|
|
if (ofs)
|
|
|
|
return make_oport (ofs);
|
|
|
|
|
|
|
|
|
|
|
|
error ("unable to open stream for writing");
|
|
|
|
return nil;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_oport (FILE * op)
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::Oport);
|
|
|
|
c->cd.op = op;
|
|
|
|
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make (Cell * ca, Cell * cd /* = &Nil*/)
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::Cons);
|
|
|
|
c->ca.p = ca;
|
|
|
|
c->cd.p = cd;
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Context::make_magic (void * key, magic_set_f set_f, magic_get_f get_f)
|
|
|
|
{
|
|
|
|
Cell * c = alloc (Cell::Magic);
|
|
|
|
Cell::MagicBox* mbox = (Cell::MagicBox*) xmalloc(sizeof(Cell::MagicBox));
|
|
|
|
mbox->key = key;
|
|
|
|
mbox->set_f = set_f;
|
|
|
|
mbox->get_f = get_f;
|
|
|
|
return c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * Cell::notcons ()
|
|
|
|
{
|
|
|
|
error ("expecting a Cons");
|
|
|
|
return nil;
|
|
|
|
}
|
|
|
|
|
|
|
|
bool Cell::ispair() {
|
|
|
|
return type () == Cell::Cons
|
|
|
|
&& this != unspecified
|
|
|
|
&& this != nil;
|
|
|
|
}
|
|
|
|
|
|
|
|
void Cell::sanity_check ()
|
|
|
|
{
|
|
|
|
int bad = 0;
|
|
|
|
|
|
|
|
// Make sure that there are enough typebits to contain
|
|
|
|
// all the types we know about.
|
|
|
|
|
|
|
|
if ((1 << TYPEBITS) < NUM_ATOMS)
|
|
|
|
++bad, printf ("Not enough typebits!\n");
|
|
|
|
|
|
|
|
// Make sure that the size of a cell has not become greater
|
|
|
|
// than two machine pointers (car & cdr).
|
|
|
|
|
|
|
|
if (sizeof (Cell) > 2 * sizeof (void *))
|
|
|
|
printf ("Cell (%Zu) is larger than CAR+CDR!\n", sizeof (Cell));
|
|
|
|
|
|
|
|
// Make sure that the "zero zone" (the least significant
|
|
|
|
// bits of a pointer to a cell) is wide enough to accomodate
|
|
|
|
// the type and GC information stored there, assuming that
|
|
|
|
// a Cell is aligned to its own size in memory
|
|
|
|
|
|
|
|
if (sizeof (Cell) < (1 << TAGBITS))
|
|
|
|
++bad, printf ("Too many tag bits for cell size\n");
|
|
|
|
|
|
|
|
if (bad)
|
|
|
|
exit (bad);
|
|
|
|
};
|
|
|
|
|
|
|
|
bool Cell::eq (Cell * that)
|
|
|
|
{
|
|
|
|
if (this == that) // the easy case
|
|
|
|
return true;
|
|
|
|
if (short_atom (this) || short_atom (that))
|
|
|
|
return false; // then the above case would have detected equality
|
|
|
|
if (long_atom(ca.p) && long_atom(that->ca.p))
|
|
|
|
{
|
|
|
|
bool part1 = (ca.i & IGN_MASK) == (that->ca.i & IGN_MASK)
|
|
|
|
&& cd.i == that->cd.i;
|
|
|
|
|
|
|
|
return part1;
|
|
|
|
}
|
|
|
|
// If both are conses, they are eq iff they are the same cons.
|
|
|
|
// But that would have been detected by the first test.
|
|
|
|
return false;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
bool Cell::equal (Cell * c)
|
|
|
|
{
|
|
|
|
Type t0 = type ();
|
|
|
|
Type t1 = c->type ();
|
|
|
|
|
|
|
|
if (this == &Nil && c == &Nil)
|
|
|
|
return true;
|
|
|
|
else if (t0 == Cons && t1 == Cons)
|
|
|
|
return ca.p->equal (c->ca.p) && cd.p->equal (c->cd.p);
|
|
|
|
else if (t0 == Vec && t1 == Vec)
|
|
|
|
{
|
|
|
|
cellvector * cv = VectorValue();
|
|
|
|
cellvector * ocv = c->VectorValue ();
|
|
|
|
int s = cv->size ();
|
|
|
|
|
|
|
|
if (s != ocv->size ())
|
|
|
|
return false;
|
|
|
|
|
|
|
|
for (int ix = 0; ix < s; ++ix)
|
|
|
|
if (! cv->get (ix)->equal (ocv->get (ix)))
|
|
|
|
return false;
|
|
|
|
|
|
|
|
return true;
|
|
|
|
}
|
|
|
|
else if (t0 == String && t1 == String)
|
|
|
|
return !strcmp (StringValue (), c->StringValue ());
|
|
|
|
else if (t0 == Real && t1 == Real)
|
|
|
|
return RealValue () == c->RealValue ();
|
|
|
|
else
|
|
|
|
return eq (c);
|
|
|
|
}
|
|
|
|
|
|
|
|
//------------------------------------------------------------------------
|
|
|
|
//
|
|
|
|
// Access/Mutate Cons Cells. These are checked calls, in that they
|
|
|
|
// will verify that they are traversing a set of cons cells at each
|
|
|
|
// step, using "assert_cons", which throws a C++ exception if this is
|
|
|
|
// not found to be true.
|
|
|
|
|
|
|
|
Cell * Cell::caar (Cell * c) {return Cell::car (Cell::car (c));}
|
|
|
|
Cell * Cell::cadr (Cell * c) {return Cell::car (Cell::cdr (c));}
|
|
|
|
Cell * Cell::cdar (Cell * c) {return Cell::cdr (Cell::car (c));}
|
|
|
|
Cell * Cell::cddr (Cell * c) {return Cell::cdr (Cell::cdr (c));}
|
|
|
|
Cell * Cell::caaar (Cell * c) {return Cell::car (Cell::caar (c));}
|
|
|
|
Cell * Cell::caadr (Cell * c) {return Cell::car (Cell::cadr (c));}
|
|
|
|
Cell * Cell::cadar (Cell * c) {return Cell::car (Cell::cdar (c));}
|
|
|
|
Cell * Cell::caddr (Cell * c) {return Cell::car (Cell::cddr (c));}
|
|
|
|
Cell * Cell::cdaar (Cell * c) {return Cell::cdr (Cell::caar (c));}
|
|
|
|
Cell * Cell::cdadr (Cell * c) {return Cell::cdr (Cell::cadr (c));}
|
|
|
|
Cell * Cell::cddar (Cell * c) {return Cell::cdr (Cell::cdar (c));}
|
|
|
|
Cell * Cell::cdddr (Cell * c) {return Cell::cdr (Cell::cddr (c));}
|
|
|
|
Cell * Cell::caaaar (Cell * c) {return Cell::car (Cell::caaar (c));}
|
|
|
|
Cell * Cell::caaadr (Cell * c) {return Cell::car (Cell::caadr (c));}
|
|
|
|
Cell * Cell::caadar (Cell * c) {return Cell::car (Cell::cadar (c));}
|
|
|
|
Cell * Cell::caaddr (Cell * c) {return Cell::car (Cell::caddr (c));}
|
|
|
|
Cell * Cell::cadaar (Cell * c) {return Cell::car (Cell::cdaar (c));}
|
|
|
|
Cell * Cell::cadadr (Cell * c) {return Cell::car (Cell::cdadr (c));}
|
|
|
|
Cell * Cell::caddar (Cell * c) {return Cell::car (Cell::cddar (c));}
|
|
|
|
Cell * Cell::cadddr (Cell * c) {return Cell::car (Cell::cdddr (c));}
|
|
|
|
Cell * Cell::cdaaar (Cell * c) {return Cell::cdr (Cell::caaar (c));}
|
|
|
|
Cell * Cell::cdaadr (Cell * c) {return Cell::cdr (Cell::caadr (c));}
|
|
|
|
Cell * Cell::cdadar (Cell * c) {return Cell::cdr (Cell::cadar (c));}
|
|
|
|
Cell * Cell::cdaddr (Cell * c) {return Cell::cdr (Cell::caddr (c));}
|
|
|
|
Cell * Cell::cddaar (Cell * c) {return Cell::cdr (Cell::cdaar (c));}
|
|
|
|
Cell * Cell::cddadr (Cell * c) {return Cell::cdr (Cell::cdadr (c));}
|
|
|
|
Cell * Cell::cdddar (Cell * c) {return Cell::cdr (Cell::cddar (c));}
|
|
|
|
Cell * Cell::cddddr (Cell * c) {return Cell::cdr (Cell::cdddr (c));}
|
|
|
|
|
|
|
|
psymbol Cell::SymbolValue () const
|
|
|
|
{
|
|
|
|
typecheck (Symbol);
|
|
|
|
return cd.y;
|
|
|
|
}
|
|
|
|
|
|
|
|
void Cell::stats ()
|
|
|
|
{
|
|
|
|
for (int ix = 0; ix < NUM_TYPES; ++ix)
|
|
|
|
printf ("%s %d ", typeName [ix], typeCount [ix]);
|
|
|
|
|
|
|
|
printf ("\n");
|
|
|
|
}
|
|
|
|
|
|
|
|
//======================================================================
|
|
|
|
//
|
|
|
|
// Value Extractors
|
|
|
|
//
|
|
|
|
//======================================================================
|
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
intptr_t Cell::IntValue () const
|
2006-08-12 15:00:13 -04:00
|
|
|
{
|
|
|
|
if (short_atom (this))
|
2008-06-17 19:00:34 -04:00
|
|
|
return reinterpret_cast <intptr_t> (this) >> 8;
|
2006-08-12 15:00:13 -04:00
|
|
|
|
|
|
|
typecheck (Int); return cd.i;
|
|
|
|
}
|
|
|
|
|
|
|
|
char Cell::CharValue () const
|
|
|
|
{
|
|
|
|
typecheck (Char);
|
|
|
|
return cd.c;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell::SubrBox* Cell::SubrValue () const
|
|
|
|
{
|
|
|
|
typecheck (Subr);
|
|
|
|
return cd.f;
|
|
|
|
}
|
|
|
|
|
|
|
|
char * Cell::StringValue () const
|
|
|
|
{
|
|
|
|
typecheck (String);
|
|
|
|
return cd.s->s;
|
|
|
|
}
|
|
|
|
|
|
|
|
size_t Cell::StringLength () const
|
|
|
|
{
|
|
|
|
typecheck (String);
|
|
|
|
return cd.s->length;
|
|
|
|
}
|
|
|
|
|
|
|
|
FILE * Cell::IportValue () const
|
|
|
|
{
|
|
|
|
typecheck (Iport); return cd.ip;
|
|
|
|
}
|
|
|
|
|
|
|
|
FILE * Cell::OportValue () const
|
|
|
|
{
|
|
|
|
typecheck (Oport); return cd.op;
|
|
|
|
}
|
|
|
|
|
|
|
|
void * Cell::ContValue () const
|
|
|
|
{
|
|
|
|
typecheck (Cont); return cd.j;
|
|
|
|
}
|
|
|
|
|
|
|
|
cellvector * Cell::VectorValue () const
|
|
|
|
{
|
|
|
|
typecheck(Vec); return cd.cv;
|
|
|
|
}
|
|
|
|
|
|
|
|
cellvector * Cell::CProcValue () const
|
|
|
|
{
|
|
|
|
typecheck(Cproc); return cd.cv;
|
|
|
|
}
|
|
|
|
|
2006-09-05 03:56:51 -04:00
|
|
|
Cell* Cell::PromiseValue () const {
|
|
|
|
typecheck (Promise);
|
|
|
|
return cd.cv->get (0);
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell* Cell::CPromiseValue() const {
|
|
|
|
typecheck(Cpromise);
|
|
|
|
return cd.cv->get(0);
|
|
|
|
}
|
2006-08-12 15:00:13 -04:00
|
|
|
|
|
|
|
psymbol Cell::BuiltinValue () const
|
|
|
|
{
|
|
|
|
typecheck (Builtin); return cd.y;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell::Procedure Cell::LambdaValue () const
|
|
|
|
{
|
|
|
|
typecheck (Lambda);
|
|
|
|
return Procedure (cd.cv->get (0), cd.cv->get (1), cd.cv->get (2));
|
|
|
|
}
|
|
|
|
|
|
|
|
double Cell::RealValue () const
|
|
|
|
{
|
|
|
|
typecheck (Real);
|
|
|
|
return *(cd.d);
|
|
|
|
}
|
|
|
|
|
|
|
|
const char * Cell::name () const
|
|
|
|
{
|
|
|
|
return typeName [type ()];
|
|
|
|
}
|
|
|
|
|
|
|
|
void Cell::typefail (Type t1, Type t2) const
|
|
|
|
{
|
2008-06-17 19:00:34 -04:00
|
|
|
sprintf (OS::errbuf, "type check failure: wanted %s, got %s",
|
2006-08-12 15:00:13 -04:00
|
|
|
typeName [t2], typeName [t1]); /* XXX sprintf into fixed buf */
|
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
OS::exception();
|
2006-08-12 15:00:13 -04:00
|
|
|
}
|
|
|
|
|
|
|
|
void Cell::dump (FILE * out)
|
|
|
|
{
|
|
|
|
Type t = type ();
|
|
|
|
fprintf (out, "[%p ", this);
|
|
|
|
if (ca.i == (FREE|ATOM)) fputs ("free ", out);
|
|
|
|
else
|
|
|
|
{
|
|
|
|
if (ca.i & MARK) fputs ("mark ", out);
|
|
|
|
if (short_atom (ca.p))
|
|
|
|
{
|
2008-06-17 19:00:34 -04:00
|
|
|
printf ("short %" PRIdPTR " ", ca.p->IntValue ());
|
2006-08-12 15:00:13 -04:00
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
if (ca.i & ATOM)
|
|
|
|
{
|
2008-06-17 19:00:34 -04:00
|
|
|
printf ("atom %04" PRIxPTR " ", ca.i);
|
2006-08-12 15:00:13 -04:00
|
|
|
if (ca.i & FORCED) fputs ("forced ", out);
|
|
|
|
if (ca.i & QUICK) fputs ("quick ", out);
|
|
|
|
if (ca.i & MACRO) fputs ("macro ", out);
|
|
|
|
if (ca.i & VREF) fputs ("vref ", out);
|
|
|
|
}
|
|
|
|
|
|
|
|
fputs (typeName [t], out);
|
|
|
|
|
|
|
|
switch (t)
|
|
|
|
{
|
|
|
|
case Cons:
|
|
|
|
fputs (" ", out);
|
|
|
|
if (ca.p == nil)
|
|
|
|
fputs ("nil", out);
|
|
|
|
else
|
|
|
|
fprintf (out, "%p", ca.p);
|
|
|
|
fputs (" ", out);
|
|
|
|
if (cd.p == nil)
|
|
|
|
fputs ("nil", out);
|
|
|
|
else
|
|
|
|
fprintf (out, "%p", cd.p);
|
|
|
|
break;
|
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
case Int: fprintf (out, " %" PRIdPTR, cd.i); break;
|
2006-08-12 15:00:13 -04:00
|
|
|
case Real: fprintf (out, " %g", RealValue ()); break;
|
|
|
|
case Unique: fprintf (out, " %s", cd.u); break;
|
|
|
|
case Symbol: fprintf (out, " %s", SymbolValue ()->key);
|
|
|
|
default: break;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
fputc (']', out);
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
//======================================================================
|
|
|
|
//
|
|
|
|
// Cell Vectors
|
|
|
|
//
|
|
|
|
//======================================================================
|
|
|
|
|
|
|
|
cellvector::cellvector (int size /* = 0 */)
|
|
|
|
{
|
|
|
|
int allocate = (size == 0 ? 10 : size);
|
|
|
|
make_cv (size, allocate);
|
|
|
|
}
|
|
|
|
|
|
|
|
cellvector::cellvector (int size, int alloc)
|
|
|
|
{
|
|
|
|
make_cv (size, alloc);
|
|
|
|
}
|
|
|
|
|
|
|
|
void cellvector::make_cv (int size, int alloc)
|
|
|
|
{
|
|
|
|
v = (Cell **) malloc (alloc * sizeof (Cell *));
|
|
|
|
if (!v)
|
|
|
|
error (nomem_error);
|
|
|
|
allocated = alloc;
|
|
|
|
|
|
|
|
for (int ix = 0; ix < alloc; ++ix)
|
|
|
|
v [ix] = nil;
|
|
|
|
|
|
|
|
gc_index = 0;
|
|
|
|
gc_uplink = 0;
|
|
|
|
sz = size;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell *& cellvector::operator [] (int ix)
|
|
|
|
{
|
|
|
|
if (ix < 0 || ix >= sz)
|
|
|
|
vref_error ();
|
|
|
|
|
|
|
|
return v [ix];
|
|
|
|
}
|
|
|
|
|
|
|
|
void cellvector::set
|
|
|
|
(
|
|
|
|
int ix,
|
|
|
|
Cell * c
|
|
|
|
)
|
|
|
|
|
|
|
|
{
|
|
|
|
if (ix < 0 || ix >= sz)
|
|
|
|
vref_error ();
|
|
|
|
|
|
|
|
v [ix] = c;
|
|
|
|
}
|
|
|
|
|
|
|
|
void cellvector::expand ()
|
|
|
|
{
|
|
|
|
// Must expand vector: double size.
|
|
|
|
int new_alloc = 2 * allocated;
|
|
|
|
Cell ** v2 = (Cell **) malloc (new_alloc * sizeof (Cell *));
|
|
|
|
|
|
|
|
if (!v2)
|
|
|
|
error (nomem_error);
|
|
|
|
|
|
|
|
memcpy (v2, v, allocated * sizeof (Cell *));
|
|
|
|
::free (v);
|
|
|
|
v = v2;
|
|
|
|
allocated = new_alloc;
|
|
|
|
}
|
|
|
|
|
|
|
|
Cell * cellvector::shift ()
|
|
|
|
{
|
|
|
|
Cell * val = v[0];
|
|
|
|
for (int ix = 0; ix < sz - 1; ++ix)
|
|
|
|
v [ix] = v [ix+1];
|
|
|
|
pop ();
|
|
|
|
return val;
|
|
|
|
}
|
|
|
|
|
|
|
|
void cellvector::unshift (Cell * val)
|
|
|
|
{
|
|
|
|
push (nil);
|
|
|
|
for (int ix = sz-1; ix > 0; --ix)
|
|
|
|
v [ix] = v [ix-1];
|
|
|
|
v[0] = val;
|
|
|
|
}
|
|
|
|
|
|
|
|
void cellvector::vref_error ()
|
|
|
|
{
|
|
|
|
error ("vector reference out of bounds");
|
|
|
|
}
|
|
|
|
|
|
|
|
void cellvector::clear ()
|
|
|
|
{
|
|
|
|
sz = 0;
|
|
|
|
}
|
|
|
|
|
|
|
|
cellvector::~cellvector ()
|
|
|
|
{
|
|
|
|
::free (v);
|
|
|
|
sz = 0;
|
|
|
|
allocated = 0;
|
|
|
|
v = 0;
|
|
|
|
}
|
|
|
|
|
|
|
|
// Cellvector freelist management
|
|
|
|
|
|
|
|
cellvector* cellvector::freelist_head[cellvector::keep_size+1];
|
|
|
|
int cellvector::freelist_count[cellvector::keep_size+1];
|
|
|
|
|
|
|
|
cellvector* cellvector::alloc(int size) {
|
|
|
|
int allocate = size;
|
|
|
|
if (allocate == 0) allocate = 2;
|
|
|
|
return alloc(size, allocate);
|
|
|
|
}
|
|
|
|
|
|
|
|
cellvector* cellvector::alloc(int size, int allocate) {
|
|
|
|
cellvector* result;
|
|
|
|
if (allocate <= keep_size) {
|
|
|
|
if ((result = freelist_head[allocate])) {
|
|
|
|
freelist_head[allocate] = result->next_free;
|
|
|
|
for (int ix = 0; ix < allocate; ++ix)
|
|
|
|
result->v[ix] = nil;
|
|
|
|
result->sz = size;
|
|
|
|
result->next_free = 0;
|
|
|
|
--freelist_count[allocate];
|
|
|
|
return result;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
return new cellvector(size, allocate);
|
|
|
|
}
|
|
|
|
|
|
|
|
void cellvector::free() {
|
|
|
|
if (allocated <= keep_size && freelist_count[allocated] <= keep_count) {
|
|
|
|
next_free = freelist_head[allocated];
|
|
|
|
++freelist_count[allocated];
|
|
|
|
freelist_head[allocated] = this;
|
|
|
|
} else {
|
|
|
|
delete this;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
//======================================================================
|
|
|
|
//
|
|
|
|
// Memory Allocation and Garbage Collection
|
|
|
|
//
|
|
|
|
//======================================================================
|
|
|
|
|
|
|
|
class Slab
|
|
|
|
{
|
|
|
|
public:
|
|
|
|
|
|
|
|
Cell * alloc ()
|
|
|
|
{
|
|
|
|
if (next + 1 > end)
|
|
|
|
return 0;
|
|
|
|
|
|
|
|
Cell * r = next;
|
|
|
|
++next;
|
|
|
|
return r;
|
|
|
|
}
|
|
|
|
|
|
|
|
int remaining ()
|
|
|
|
{
|
|
|
|
return static_cast<int>(end - next);
|
|
|
|
}
|
|
|
|
|
|
|
|
void reset ()
|
|
|
|
{
|
|
|
|
next = start;
|
|
|
|
}
|
|
|
|
|
|
|
|
void sweep (Context *);
|
|
|
|
|
|
|
|
Slab (Context * ctx)
|
|
|
|
{
|
|
|
|
// We avoid the temptation to call new Cell [slabsize],
|
|
|
|
// since that would invoke the constructor on each cell,
|
|
|
|
// which we don't need (alloc will take care of preparing
|
|
|
|
// cells for use).
|
|
|
|
//
|
|
|
|
// It is essential that Cells be 8-aligned to preserve
|
|
|
|
// three bits for type and GC information. If new has
|
|
|
|
// stiffed us with 4-aligned memory, we "burn" 4 bytes
|
|
|
|
// of it.
|
|
|
|
|
|
|
|
int storage_size = slabsize * sizeof (Cell) + 4;
|
|
|
|
storage = (char *) malloc (storage_size);
|
|
|
|
|
|
|
|
if (!storage)
|
|
|
|
error ("out of memory");
|
|
|
|
|
|
|
|
// Supposedly the ANSI library guarantees that storage
|
|
|
|
// is 4-aligned!
|
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
if ((reinterpret_cast<intptr_t>(storage)) & 3)
|
2006-08-12 15:00:13 -04:00
|
|
|
abort ();
|
|
|
|
|
|
|
|
// But if it's not 8-aligned we can fix that using the
|
|
|
|
// extra 4 bytes we allocated.
|
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
if ((reinterpret_cast<intptr_t>(storage)) & 7)
|
2006-08-12 15:00:13 -04:00
|
|
|
start = reinterpret_cast <Cell *> (storage + 4);
|
|
|
|
else
|
|
|
|
start = reinterpret_cast <Cell *> (storage);
|
|
|
|
|
|
|
|
memset (storage, 0, storage_size);
|
|
|
|
|
|
|
|
ctx->cellsTotal += slabsize;
|
|
|
|
end = start + slabsize;
|
|
|
|
reset ();
|
|
|
|
}
|
|
|
|
|
|
|
|
~Slab ()
|
|
|
|
{
|
|
|
|
free (storage);
|
|
|
|
}
|
|
|
|
|
|
|
|
static int slabsize;
|
|
|
|
|
|
|
|
private:
|
|
|
|
|
|
|
|
Cell * start;
|
|
|
|
Cell * end;
|
|
|
|
Cell * next;
|
|
|
|
char * storage;
|
|
|
|
};
|
|
|
|
|
|
|
|
int Slab::slabsize = 10000;
|
|
|
|
|
|
|
|
Cell * Context::alloc (Cell::Type t)
|
|
|
|
{
|
|
|
|
Cell * a;
|
|
|
|
|
|
|
|
mem.last_alloc_gc = false;
|
|
|
|
// Select a cell from the free list if one is available.
|
|
|
|
|
|
|
|
TOP:
|
|
|
|
if ((a = mem.free))
|
|
|
|
{
|
|
|
|
++cellsAlloc;
|
|
|
|
mem.free = a->cd.p;
|
|
|
|
a->ca.i = a->cd.i = 0;
|
|
|
|
a->set_type (t);
|
|
|
|
--mem.c_free;
|
|
|
|
return a;
|
|
|
|
}
|
|
|
|
|
|
|
|
// IF there aren't any slabs in the active pool,
|
|
|
|
// we must never have allocated any slabs at all
|
|
|
|
// yet, so allocate the first one.
|
|
|
|
|
|
|
|
if (mem.active.size () == 0)
|
|
|
|
{
|
|
|
|
// Configurable slabsize
|
|
|
|
|
|
|
|
char * c;
|
|
|
|
if ((c = getenv ("SLABSIZE")) != NULL)
|
|
|
|
Slab::slabsize = atoi (c);
|
|
|
|
|
|
|
|
mem.active.push ((Cell *) new Slab (this));
|
|
|
|
mem.free = 0;
|
|
|
|
mem.low_water = false;
|
|
|
|
mem.no_inline_gc = OS::flag (DEBUG_NO_INLINE_GC);
|
|
|
|
}
|
|
|
|
|
|
|
|
// Check the "top" slab to see if there's any room
|
|
|
|
// left in it.
|
|
|
|
|
|
|
|
if ((a = mem.current ()->alloc ()))
|
|
|
|
{
|
|
|
|
++cellsAlloc;
|
|
|
|
a->cd.i = 0;
|
|
|
|
a->set_type (t);
|
|
|
|
return a;
|
|
|
|
}
|
|
|
|
|
|
|
|
// There wasn't any room in the top slab. We can try
|
|
|
|
// to GC. If we do, and still 80% of the allocated
|
|
|
|
// memory is occupied, we set a flag admitting that
|
|
|
|
// the last GC was "unproductive", and next time 'round
|
|
|
|
// we'll allocate a new slab.
|
|
|
|
|
|
|
|
if (mem.no_inline_gc || mem.last_alloc_gc || mem.low_water)
|
|
|
|
{
|
|
|
|
mem.active.push ((Cell *) new Slab (this)); // trip to the well
|
|
|
|
mem.low_water = false; // low_water is a one-shot
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
mem.last_alloc_gc = true;
|
|
|
|
gc ();
|
|
|
|
}
|
|
|
|
|
|
|
|
goto TOP;
|
|
|
|
}
|
|
|
|
|
|
|
|
//----------------------------------------------------------------------
|
|
|
|
// GARBAGE COLLECTION
|
|
|
|
//
|
|
|
|
|
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
inline Cell * Cell::untagged (Cell * c) {
|
|
|
|
static const uintptr_t not_tagmask = ~Cell::TAGMASK;
|
|
|
|
|
|
|
|
return reinterpret_cast <Cell *>
|
|
|
|
(reinterpret_cast <uintptr_t> (c) & not_tagmask);
|
|
|
|
}
|
2006-08-12 15:00:13 -04:00
|
|
|
|
|
|
|
inline void Cell::gc_set_car (Cell * src)
|
|
|
|
{
|
|
|
|
unsigned int tagbits = ca.i & TAGMASK;
|
|
|
|
ca.p = src;
|
|
|
|
ca.i |= tagbits;
|
|
|
|
}
|
|
|
|
|
|
|
|
inline void Cell::gc_set_cdr (Cell * src)
|
|
|
|
{
|
|
|
|
unsigned int tagbits = cd.i & TAGMASK;
|
|
|
|
setcdr (this, src);
|
|
|
|
cd.i |= tagbits;
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
|
|
//----------------------------------------------------------------------
|
|
|
|
// Marking for Garbage Collection
|
|
|
|
//
|
|
|
|
// This implementation is Knuth's Algorithm 2.3.5E (TAoCP 3ed. vol I
|
|
|
|
// p. 418) We follow Knuth's presentation carefully (using the same
|
|
|
|
// variable names and statement labels). Like the evaluator, this
|
|
|
|
// code has to take some care to avoid recursion: we want to be able
|
|
|
|
// to perform a GC mark wihtout allocating any additional space (not
|
|
|
|
// even C stack space). That accounts for some of the complexity in
|
|
|
|
// this routine. The other part is that, due to vectors, we have to
|
|
|
|
// support n-way marking instead of just 2-way marking.
|
|
|
|
|
|
|
|
void Context::mark (Cell * P)
|
|
|
|
{
|
|
|
|
bool traceall = OS::flag (TRACE_GC_ALL);
|
|
|
|
if (P == nil || P == 0 || Cell::short_atom(P) || P->ca.i & Cell::MARK)
|
|
|
|
return;
|
|
|
|
|
|
|
|
// In Knuth's presentation, a NODE contains two pointers
|
|
|
|
// (which he calls ALINK and BLINK, we car and cdr), and
|
|
|
|
// MARK and ATOM fields. In his layout, the MARK and
|
|
|
|
// ATOM fields can be manipulated easily without changing
|
|
|
|
// ALINK and BLINK, but in our case we store MARK and ATOM
|
|
|
|
// in the lower three bits of ALINK. We must therefore
|
|
|
|
// be cautious when transcribing the algorithm to avoid,
|
|
|
|
// e.g., clearing MARK and ATOM when copying a `car' pointer.
|
|
|
|
// We use "gc_set_car" and "gc_set_cdr" for this purpose.
|
|
|
|
|
|
|
|
// Secondly, Knuth occasionally sets the ATOM bit of a CONS
|
|
|
|
// to determine which of the pointers has been placed on
|
|
|
|
// the stack of deferred objects. But short atoms makes this
|
|
|
|
// difficult for us, as it's possible to have a cons of two
|
|
|
|
// short integers, say: then we need both ATOM fields of the
|
|
|
|
// CONS to contain that information. Instead of using the ATOM
|
|
|
|
// field, we use the MARK field of the cdr, which is not used
|
|
|
|
// for GC purposes.
|
|
|
|
|
|
|
|
//E1:
|
|
|
|
Cell * T = nil;
|
|
|
|
Cell * Q = nil;
|
|
|
|
|
|
|
|
E2: P->ca.i |= Cell::MARK;
|
|
|
|
if (traceall) { printf ("m "); P->dump (stdout); putchar ('\n'); }
|
|
|
|
|
|
|
|
// -- EXTENSION to Knuth's Step E2
|
|
|
|
//
|
|
|
|
// If the cell is a cons, Knuth's algorithm will take care of
|
|
|
|
// marking the things referenced as a result quite handily. But
|
|
|
|
// there are some atoms that can hold references too. Knuth's
|
|
|
|
// algorithm works for binary trees, but to deal with vectors et
|
|
|
|
// al. we need to make it work for n-way trees.
|
|
|
|
//
|
|
|
|
// When an atom can hold references to other cells, we organize
|
|
|
|
// these into a cellvector. In this way, we can treat all of them
|
|
|
|
// the same way.
|
|
|
|
//
|
|
|
|
// Whereas Knuth uses an atom bit to tell which side of a cons
|
|
|
|
// (car or cdr) he has stashed the pointer back to the
|
|
|
|
// as-yet-unmarked cells, when we traverse a vector we use an
|
|
|
|
// auxiliary integer field to tell us how many vector slots we
|
|
|
|
// have marked so far.
|
|
|
|
|
|
|
|
if (Cell::atomic (P))
|
|
|
|
{
|
|
|
|
if (P->flag (Cell::VREF))
|
|
|
|
{
|
|
|
|
// Getting "here" in the code means that we're seeing the
|
|
|
|
// vector of additional cell references for the first time
|
|
|
|
// (otherwise the mark bit will already be set). Our job is
|
|
|
|
// to kick off the iteration by stashing the back-link and
|
|
|
|
// starting the mark counter. The rest of the iteration will
|
|
|
|
// be handled in the "up" step below.
|
|
|
|
|
|
|
|
if (P->cd.cv->size () > 0)
|
|
|
|
{
|
|
|
|
P->cd.cv->gc_uplink = T;
|
|
|
|
P->cd.cv->gc_index = 0;
|
|
|
|
T = P;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
else if (P->type () == Cell::Symbol)
|
|
|
|
{
|
|
|
|
// Symbols have property-list vectors, and so receive
|
|
|
|
// similar treatment to the above. But don't do this
|
|
|
|
// if we've already started to mark the properties
|
|
|
|
// (gc_uplink will be non-NULL in that case).
|
|
|
|
|
|
|
|
psymbol ps = P->SymbolValue ();
|
|
|
|
if (ps->plist
|
|
|
|
&& ps->plist->gc_uplink == 0
|
|
|
|
&& ps->plist->size () > 0)
|
|
|
|
{
|
|
|
|
ps->plist->gc_uplink = T;
|
|
|
|
ps->plist->gc_index = 0;
|
|
|
|
T = P;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
goto E6; // E3
|
|
|
|
}
|
|
|
|
|
|
|
|
if (!Cell::short_atom(P->ca.p))
|
|
|
|
{
|
|
|
|
Q = Cell::untagged (P->ca.p); // E4
|
|
|
|
if (Q != nil && !(Q->ca.i & Cell::MARK))
|
|
|
|
{
|
|
|
|
//if (!Cell::short_atom(P->cd.p))
|
|
|
|
// {
|
|
|
|
// P->cd.i |= Cell::ATOM;
|
|
|
|
P->cd.i |= Cell::MARK;
|
|
|
|
// END
|
|
|
|
P->gc_set_car (T);
|
|
|
|
T = P;
|
|
|
|
// }
|
|
|
|
P = Q;
|
|
|
|
goto E2;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
E5: if (!Cell::short_atom(P->cd.p))
|
|
|
|
{
|
|
|
|
Q = Cell::untagged (P->cd.p);
|
|
|
|
if (Q != nil && !(Q->ca.i & Cell::MARK))
|
|
|
|
{
|
|
|
|
P->gc_set_cdr (T);
|
|
|
|
T = P;
|
|
|
|
P = Q;
|
|
|
|
|
|
|
|
goto E2;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
E6: if (T == nil)
|
|
|
|
return;
|
|
|
|
|
|
|
|
Q = T;
|
|
|
|
|
|
|
|
if (Q->flag (Cell::VREF))
|
|
|
|
{
|
|
|
|
// We are popping a vector cell from the GC stack.
|
|
|
|
// If there are more cells to mark within it, keep
|
|
|
|
// going.
|
|
|
|
|
|
|
|
next_element:
|
|
|
|
|
|
|
|
int i = Q->cd.cv->gc_index++;
|
|
|
|
|
|
|
|
if (i >= Q->cd.cv->size ()) // all done?
|
|
|
|
{
|
|
|
|
T = Q->cd.cv->gc_uplink;
|
|
|
|
Q->cd.cv->gc_index = 0; // reset for next time
|
|
|
|
P = Q;
|
|
|
|
goto E6;
|
|
|
|
}
|
|
|
|
else // resume iteration
|
|
|
|
{
|
|
|
|
P = Q->cd.cv->get (i); // with next element
|
|
|
|
|
|
|
|
// One wrinkle: captured continuations are implemented
|
|
|
|
// as vectors, and like the machine stack, these vectors
|
|
|
|
// can contain integer VM codes as well as cell pointers.
|
|
|
|
// These latter are marked with the ATOM flag.
|
|
|
|
|
2008-06-17 19:00:34 -04:00
|
|
|
if (reinterpret_cast <intptr_t> (P) & Cell::ATOM)
|
2006-08-12 15:00:13 -04:00
|
|
|
goto next_element;
|
|
|
|
|
|
|
|
// Otherwise we mark, if not marked already.
|
|
|
|
if (P->ca.i & Cell::MARK)
|
|
|
|
goto next_element;
|
|
|
|
|
|
|
|
P = Cell::untagged (P);
|
|
|
|
if (P == nil)
|
|
|
|
goto next_element;
|
|
|
|
|
|
|
|
goto E2;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
else if (Q->type () == Cell::Symbol)
|
|
|
|
{
|
|
|
|
// Continue iterating over the property list of a symbol.
|
|
|
|
psymbol ps = Q->SymbolValue ();
|
|
|
|
|
|
|
|
next_property:
|
|
|
|
int i = ps->plist->gc_index++;
|
|
|
|
if (i >= ps->plist->size ()) // all done?
|
|
|
|
{
|
|
|
|
T = ps->plist->gc_uplink;
|
|
|
|
ps->plist->gc_index = 0;
|
|
|
|
ps->plist->gc_uplink = 0;
|
|
|
|
P = Q;
|
|
|
|
goto E6;
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
P = ps->plist->get (i);
|
|
|
|
if (P->ca.i & Cell::MARK)
|
|
|
|
goto next_property;
|
|
|
|
P = Cell::untagged (P);
|
|
|
|
if (P == nil)
|
|
|
|
goto next_property;
|
|
|
|
goto E2;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
// if (Q->cd.i & Cell::ATOM)
|
|
|
|
if (Q->cd.i & Cell::MARK)
|
|
|
|
{
|
|
|
|
// Q->cd.i &= ~Cell::ATOM;
|
|
|
|
Q->cd.i &= ~Cell::MARK;
|
|
|
|
T = Cell::untagged (Q->ca.p);
|
|
|
|
Q->gc_set_car (P);
|
|
|
|
P = Q;
|
|
|
|
goto E5;
|
|
|
|
}
|
|
|
|
else
|
|
|
|
{
|
|
|
|
T = Cell::untagged (Q->cd.p);
|
|
|
|
Q->gc_set_cdr (P);
|
|
|
|
P = Q;
|
|
|
|
goto E6;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
void Slab::sweep (Context * ctx)
|
|
|
|
{
|
|
|
|
bool traceall = OS::flag (TRACE_GC_ALL);
|
|
|
|
|
|
|
|
for (Cell * p = start; p < next; ++p)
|
|
|
|
{
|
|
|
|
unsigned int word = p->ca.i;
|
|
|
|
|
|
|
|
if (word & Cell::MARK)
|
|
|
|
{
|
|
|
|
p->ca.i &= ~Cell::MARK;
|
|
|
|
}
|
|
|
|
else if (word != (Cell::FREE|Cell::ATOM))
|
|
|
|
{
|
|
|
|
// FINALIZATION
|
|
|
|
//
|
|
|
|
|
|
|
|
if (traceall) { printf ("s "); p->dump (stdout); putchar ('\n'); }
|
|
|
|
Cell::Type t = p->type ();
|
|
|
|
|
|
|
|
switch (t)
|
|
|
|
{
|
|
|
|
case Cell::Cont:
|
|
|
|
case Cell::Promise:
|
|
|
|
case Cell::Cproc:
|
|
|
|
case Cell::Cpromise:
|
|
|
|
case Cell::Lambda:
|
|
|
|
case Cell::Vec: // Free the vector of cell pointers.
|
|
|
|
p->cd.cv->free();
|
|
|
|
// XXX delete p->cd.cv;
|
|
|
|
p->cd.cv = 0;
|
|
|
|
break;
|
|
|
|
|
|
|
|
case Cell::Iport: // Ports hold streams
|
|
|
|
fclose (p->cd.ip);
|
|
|
|
break;
|
|
|
|
|
|
|
|
case Cell::Oport: // Ports hold streams
|
|
|
|
fclose (p->cd.op);
|
|
|
|
break;
|
|
|
|
|
|
|
|
case Cell::Real: // Reals hold a malloc'd double
|
|
|
|
free (p->cd.d);
|
|
|
|
break;
|
|
|
|
|
|
|
|
case Cell::Subr: // Subrs hold a SubrBox
|
|
|
|
free (p->cd.f);
|
|
|
|
break;
|
|
|
|
|
|
|
|
case Cell::Magic: // Magic cells hold a MagicBox
|
|
|
|
free (p->cd.m);
|
|
|
|
break;
|
|
|
|
|
|
|
|
case Cell::String: // Strings hold StringBoxes
|
|
|
|
free (p->cd.s);
|
|
|
|
break;
|
|
|
|
|
|
|
|
default: // Ordinarily cells hold no other storage.
|
|
|
|
;
|
|
|
|
}
|
|
|
|
|
|
|
|
--ctx->cellsAlloc;
|
|
|
|
p->ca.i = Cell::FREE | Cell::ATOM;
|
|
|
|
p->cd.p = ctx->mem.free;
|
|
|
|
ctx->mem.free = p;
|
|
|
|
++ctx->mem.c_free;
|
|
|
|
}
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
|
|
|
void Context::gc ()
|
|
|
|
{
|
|
|
|
bool gc_verbose = OS::flag (TRACE_GC);
|
|
|
|
Cell * p;
|
|
|
|
|
|
|
|
if (!ok_to_gc)
|
|
|
|
{
|
|
|
|
fprintf (stderr, "initial memory budget insufficient to set up VM\n"
|
|
|
|
"Try setting the environment variable SLABSIZE to\n"
|
|
|
|
"something greater than %d\n", Slab::slabsize);
|
|
|
|
exit (1);
|
|
|
|
}
|
|
|
|
if (gc_verbose)
|
|
|
|
printf ("; start gc: %d/%d\n", cellsAlloc, cellsTotal);
|
|
|
|
|
|
|
|
//
|
|
|
|
// MARK PHASE
|
|
|
|
//
|
|
|
|
// We have to mark everything reachable from the "register machine"
|
|
|
|
// registers.
|
|
|
|
|
|
|
|
mark (root_envt);
|
|
|
|
mark (r_env);
|
|
|
|
mark (Cell::car (&r_argl));
|
|
|
|
mark (Cell::cdr (&r_argl));
|
|
|
|
mark (Cell::car (&r_varl));
|
|
|
|
mark (Cell::cdr (&r_varl));
|
|
|
|
mark (r_proc);
|
|
|
|
mark (r_exp);
|
|
|
|
mark (r_unev);
|
|
|
|
mark (r_val);
|
|
|
|
mark (r_tmp);
|
|
|
|
mark (r_elt);
|
|
|
|
mark (r_nu);
|
|
|
|
mark (cc_procedure);
|
|
|
|
mark (empty_vector);
|
|
|
|
|
|
|
|
// Mark the things is the compiler VM.
|
|
|
|
//
|
|
|
|
|
|
|
|
mark (r_cproc);
|
|
|
|
mark (r_envt);
|
|
|
|
|
|
|
|
// Mark everything reachable from the machine stack. Watch out
|
|
|
|
// for integers hiding in the machine stack, though! They are
|
|
|
|
// marked with the ATOM flag.
|
|
|
|
|
|
|
|
for (int ix = 0; ix < m_stack.size (); ++ix)
|
2008-06-17 19:00:34 -04:00
|
|
|
if ((reinterpret_cast <intptr_t> ((p = m_stack [ix])) & Cell::ATOM) == 0)
|
2006-08-12 15:00:13 -04:00
|
|
|
mark (p);
|
|
|
|
|
|
|
|
// Mark the I/O ports referenced in this environment stack.
|
|
|
|
|
|
|
|
for (int ix = 0; ix < istack.size (); ++ix)
|
|
|
|
mark (istack [ix]);
|
|
|
|
for (int ix = 0; ix |