commit 50cfacec5d3c5b884250b7564af50f6e55652f01
parent 4b48845ccd73c103cc48798d39d4a8b99b89a8bf
Author: Andres Navarro <canavarro82@gmail.com>
Date: Thu, 14 Apr 2011 20:27:35 -0300
First code for the garbage collector. This is mostly from lua, the collector supports incremental marking but we'll let that for later. The freeing of the objects was moved to the gc, but there is still no code to mark the roots or trace any of the klisp objects. Also no code to check for when to do a garbage collection.
Diffstat:
23 files changed, 912 insertions(+), 154 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -15,7 +15,7 @@ CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \
kgenv_mut.o kgcombiners.o kgcontinuations.o kgencapsulations.o \
kgpromises.o kgkd_vars.o kgks_vars.o kgports.o kgchars.o kgnumbers.o \
- kgstrings.o imath.o
+ kgstrings.o imath.o kgc.o
KRN_T= klisp
KRN_O= klisp.o
@@ -42,15 +42,16 @@ clean:
klisp.o: klisp.c klisp.h kobject.h kread.h kwrite.h klimits.h kstate.h kmem.h \
kerror.h kauxlib.h koperative.h kenvironment.h kcontinuation.h \
kapplicative.h koperative.h keval.h krepl.h
-kobject.o: kobject.c kobject.h klisp.h
+kobject.o: kobject.c kobject.h klimits.h kconf.h
ktoken.o: ktoken.c ktoken.h kobject.h kstate.h kpair.h kstring.h ksymbol.h \
kerror.h klisp.h kinteger.h
-kinteger.o: kinteger.c kinteger.h kobject.h kstate.h kmem.h klisp.h imath.h
-kpair.o: kpair.c kpair.h kobject.h kstate.h kmem.h klisp.h
-kstring.o: kstring.c kstring.h kobject.h kstate.h kmem.h klisp.h
+kinteger.o: kinteger.c kinteger.h kobject.h kstate.h kmem.h klisp.h imath.h \
+ kgc.h
+kpair.o: kpair.c kpair.h kobject.h kstate.h kmem.h klisp.h kgc.h
+kstring.o: kstring.c kstring.h kobject.h kstate.h kmem.h klisp.h kgc.h
# XXX: kpair.h because of use of list as symbol table
ksymbol.o: ksymbol.c ksymbol.h kobject.h kpair.h kstring.h kstate.h kmem.h \
- klisp.h
+ klisp.h kgc.h
kread.o: kread.c kread.h kobject.h ktoken.h kpair.h kstate.h kerror.h klisp.h \
kport.h
kwrite.o: kwrite.c kwrite.h kobject.h kpair.h kstring.h kstate.h kerror.h \
@@ -58,23 +59,24 @@ kwrite.o: kwrite.c kwrite.h kobject.h kpair.h kstring.h kstate.h kerror.h \
kstate.o: kstate.c kstate.h klisp.h kobject.h kmem.h kstring.h klisp.h \
kground.h kenvironment.h kpair.h keval.h koperative.h kground.h \
krepl.h kcontinuation.h kapplicative.h kport.h ksymbol.h kport.h \
- kstring.h kinteger.h
+ kstring.h kinteger.h kgc.h
kmem.o: kmem.c kmem.h klisp.h kerror.h klisp.h kstate.h
kerror.o: kerror.c kerror.h klisp.h kstate.h klisp.h kmem.h kstring.h
kauxlib.o: kauxlib.c kauxlib.h klisp.h kstate.h klisp.h
kenvironment.o: kenvironment.c kenvironment.h kpair.h kobject.h kerror.h \
- kmem.h kstate.h klisp.h
+ kmem.h kstate.h klisp.h kgc.h
kcontinuation.o: kcontinuation.c kcontinuation.h kmem.h kstate.h kobject.h \
- klisp.h
+ klisp.h kgc.h
koperative.o: koperative.c koperative.h kmem.h kstate.h kobject.h \
- klisp.h
+ klisp.h kgc.h
kapplicative.o: kapplicative.c kapplicative.h kmem.h kstate.h kobject.h \
- klisp.h
+ klisp.h kgc.h
kencapsulation.o: kencapsulation.c kencapsulation.h kmem.h kstate.h kobject.h \
- klisp.h kpair.h
+ klisp.h kpair.h kgc.h
kpromise.o: kpromise.c kpromise.h kmem.h kstate.h kobject.h \
- klisp.h kpair.h
-kport.o: kport.c kport.h kmem.h kstate.h kobject.h klisp.h kerror.h kstring.h
+ klisp.h kpair.h kgc.h
+kport.o: kport.c kport.h kmem.h kstate.h kobject.h klisp.h kerror.h kstring.h \
+ kgc.h
keval.o: keval.c keval.h kcontinuation.h kenvironment.h kstate.h kobject.h \
kpair.h kerror.h klisp.h
krepl.o: krepl.c krepl.h kcontinuation.h kstate.h kobject.h keval.h klisp.h \
@@ -135,8 +137,9 @@ kgchars.o: kgchars.c kgchars.h kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kapplicative.h koperative.h kcontinuation.h
kgnumbers.o: kgnumbers.c kgnumbers.h kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kapplicative.h koperative.h kcontinuation.h \
- ksymbol.h kinteger.h
+ ksymbol.h kinteger.h
kgstrings.o: kgstrings.c kgstrings.h kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kapplicative.h koperative.h kcontinuation.h \
ksymbol.h kgnumbers.h
-imath.o: kobject.h kstate.h kmem.h kerror.h
-\ No newline at end of file
+imath.o: kobject.h kstate.h kmem.h kerror.h
+kgc.o: kgc.c kgc.h kobject.h kmem.h kstate.h kport.h imath.h
diff --git a/src/kapplicative.c b/src/kapplicative.c
@@ -8,6 +8,7 @@
#include "kstate.h"
#include "kapplicative.h"
#include "kmem.h"
+#include "kgc.h"
TValue kwrap(klisp_State *K, TValue underlying)
{
@@ -20,11 +21,7 @@ TValue kmake_applicative(klisp_State *K, TValue name, TValue si,
Applicative *new_app = klispM_new(K, Applicative);
/* header + gc_fields */
- new_app->next = K->root_gc;
- K->root_gc = (GCObject *)new_app;
- new_app->gct = 0;
- new_app->tt = K_TAPPLICATIVE;
- new_app->flags = 0;
+ klispC_link(K, (GCObject *) new_app, K_TAPPLICATIVE, 0);
/* applicative specific fields */
new_app->name = name;
diff --git a/src/kcontinuation.c b/src/kcontinuation.c
@@ -10,6 +10,7 @@
#include "kobject.h"
#include "kstate.h"
#include "kmem.h"
+#include "kgc.h"
TValue kmake_continuation(klisp_State *K, TValue parent, TValue name,
TValue si, klisp_Cfunc fn, int32_t xcount, ...)
@@ -19,11 +20,7 @@ TValue kmake_continuation(klisp_State *K, TValue parent, TValue name,
klispM_malloc(K, sizeof(Continuation) + sizeof(TValue) * xcount);
/* header + gc_fields */
- new_cont->next = K->root_gc;
- K->root_gc = (GCObject *)new_cont;
- new_cont->gct = 0;
- new_cont->tt = K_TCONTINUATION;
- new_cont->flags = 0;
+ klispC_link(K, (GCObject *) new_cont, K_TCONTINUATION, 0);
/* continuation specific fields */
new_cont->mark = KFALSE;
diff --git a/src/kencapsulation.c b/src/kencapsulation.c
@@ -9,6 +9,7 @@
#include "kstate.h"
#include "kencapsulation.h"
#include "kpair.h"
+#include "kgc.h"
TValue kmake_encapsulation(klisp_State *K, TValue name, TValue si,
TValue key, TValue val)
@@ -16,11 +17,7 @@ TValue kmake_encapsulation(klisp_State *K, TValue name, TValue si,
Encapsulation *new_enc = klispM_new(K, Encapsulation);
/* header + gc_fields */
- new_enc->next = K->root_gc;
- K->root_gc = (GCObject *)new_enc;
- new_enc->gct = 0;
- new_enc->tt = K_TENCAPSULATION;
- new_enc->flags = 0;
+ klispC_link(K, (GCObject *) new_enc, K_TENCAPSULATION, 0);
/* encapsulation specific fields */
new_enc->name = name;
diff --git a/src/kenvironment.c b/src/kenvironment.c
@@ -13,6 +13,7 @@
#include "kerror.h"
#include "kstate.h"
#include "kmem.h"
+#include "kgc.h"
/* keyed dynamic vars */
#define env_keyed_parents(env_) (tv2env(env_)->keyed_parents)
@@ -28,11 +29,7 @@ TValue kmake_environment(klisp_State *K, TValue parents)
Environment *new_env = klispM_new(K, Environment);
/* header + gc_fields */
- new_env->next = K->root_gc;
- K->root_gc = (GCObject *) new_env;
- new_env->gct = 0;
- new_env->tt = K_TENVIRONMENT;
- new_env->flags = 0;
+ klispC_link(K, (GCObject *) new_env, K_TENVIRONMENT, 0);
/* environment specific fields */
new_env->mark = KFALSE;
diff --git a/src/kgc.c b/src/kgc.c
@@ -0,0 +1,648 @@
+/*
+** kgc.c
+** Garbage Collector
+** See Copyright Notice in klisp.h
+*/
+
+/*
+** SOURCE NOTE: This is almost textually from lua.
+** Parts that don't apply, or don't apply yet to klisp are in comments.
+*/
+
+#include <string.h>
+
+#include "kgc.h"
+#include "kobject.h"
+#include "kstate.h"
+#include "kmem.h"
+#include "kport.h"
+#include "imath.h"
+
+#define GCSTEPSIZE 1024u
+#define GCSWEEPMAX 40
+#define GCSWEEPCOST 10
+#define GCFINALIZECOST 100 /* klisp: NOT USED YET */
+
+
+
+#define maskmarks cast(uint16_t, ~(bitmask(BLACKBIT)|WHITEBITS))
+
+#define makewhite(g,x) \
+ ((x)->gch.gct = cast(uint16_t, \
+ ((x)->gch.gct & maskmarks) | klispC_white(g)))
+
+#define white2gray(x) reset2bits((x)->gch.gct, WHITE0BIT, WHITE1BIT)
+#define black2gray(x) resetbit((x)->gch.gct, BLACKBIT)
+
+/* NOTE: klisp strings, unlike the lua counterparts are not values,
+ so they are marked as other objects */
+
+/* klisp: NOT USED YET */
+#define isfinalized(u) testbit((u)->gct, FINALIZEDBIT)
+#define markfinalized(u) l_setbit((u)->gct, FINALIZEDBIT)
+
+/* klisp: NOT USED YET */
+#define KEYWEAK bitmask(KEYWEAKBIT)
+#define VALUEWEAK bitmask(VALUEWEAKBIT)
+
+
+
+#define markvalue(k,o) { checkconsistency(o); \
+ if (iscollectable(o) && iswhite(gcvalue(o))) \
+ reallymarkobject(k,gcvalue(o)); }
+
+#define markobject(k,t) { if (iswhite(obj2gco(t))) \
+ reallymarkobject(k, obj2gco(t)); }
+
+
+#define setthreshold(g) (g->GCthreshold = (g->estimate/100) * g->gcpause)
+
+/* klisp no need for it yet */
+#if 0
+static void removeentry (Node *n) {
+ klisp_assert(ttisnil(gval(n)));
+ if (iscollectable(gkey(n)))
+ setttype(gkey(n), LUA_TDEADKEY); /* dead key; remove it */
+}
+#endif
+
+static void reallymarkobject (klisp_State *K, GCObject *o)
+{
+ klisp_assert(iswhite(o) && !isdead(K, o));
+ white2gray(o);
+ /* klisp: most of klisp have the same structure, but conserve the switch
+ just in case. */
+ uint8_t type = o->gch.tt;
+ switch (type) {
+/* klisp: keep this around just in case we add it later */
+#if 0
+ case LUA_TUSERDATA: {
+ Table *mt = gco2u(o)->metatable;
+ gray2black(o); /* udata are never gray */
+ if (mt) markobject(g, mt);
+ markobject(g, gco2u(o)->env);
+ return;
+ }
+#endif
+ case K_TBIGINT:
+ gray2black(o); /* bigint are never gray */
+ break;
+ case K_TPAIR:
+ case K_TSYMBOL:
+ case K_TSTRING:
+ case K_TENVIRONMENT:
+ case K_TCONTINUATION:
+ case K_TOPERATIVE:
+ case K_TAPPLICATIVE:
+ case K_TENCAPSULATION:
+ case K_TPROMISE:
+ case K_TPORT:
+ o->gch.gclist = K->gray;
+ K->gray = o;
+ break;
+ default:
+ /* shouldn't happen */
+ fprintf(stderr, "Unknown GCObject type (in GC mark): %d\n", type);
+ abort();
+ }
+}
+
+
+/* klisp: keep this around just in case we add it later */
+#if 0
+static void marktmu (global_State *g) {
+ GCObject *u = g->tmudata;
+ if (u) {
+ do {
+ u = u->gch.next;
+ makewhite(g, u); /* may be marked, if left from previous GC */
+ reallymarkobject(g, u);
+ } while (u != g->tmudata);
+ }
+}
+
+/* move `dead' udata that need finalization to list `tmudata' */
+size_t klispC_separateudata (lua_State *L, int all) {
+ global_State *g = G(L);
+ size_t deadmem = 0;
+ GCObject **p = &g->mainthread->next;
+ GCObject *curr;
+ while ((curr = *p) != NULL) {
+ if (!(iswhite(curr) || all) || isfinalized(gco2u(curr)))
+ p = &curr->gch.next; /* don't bother with them */
+ else if (fasttm(L, gco2u(curr)->metatable, TM_GC) == NULL) {
+ markfinalized(gco2u(curr)); /* don't need finalization */
+ p = &curr->gch.next;
+ }
+ else { /* must call its gc method */
+ deadmem += sizeudata(gco2u(curr));
+ markfinalized(gco2u(curr));
+ *p = curr->gch.next;
+ /* link `curr' at the end of `tmudata' list */
+ if (g->tmudata == NULL) /* list is empty? */
+ /* creates a circular list */
+ g->tmudata = curr->gch.next = curr;
+ else {
+ curr->gch.next = g->tmudata->gch.next;
+ g->tmudata->gch.next = curr;
+ g->tmudata = curr;
+ }
+ }
+ }
+ return deadmem;
+}
+
+
+static int traversetable (global_State *g, Table *h) {
+ int i;
+ int weakkey = 0;
+ int weakvalue = 0;
+ const TValue *mode;
+ if (h->metatable)
+ markobject(g, h->metatable);
+ mode = gfasttm(g, h->metatable, TM_MODE);
+ if (mode && ttisstring(mode)) { /* is there a weak mode? */
+ weakkey = (strchr(svalue(mode), 'k') != NULL);
+ weakvalue = (strchr(svalue(mode), 'v') != NULL);
+ if (weakkey || weakvalue) { /* is really weak? */
+ h->gct &= ~(KEYWEAK | VALUEWEAK); /* clear bits */
+ h->gct |= cast(uint16_t, (weakkey << KEYWEAKBIT) |
+ (weakvalue << VALUEWEAKBIT));
+ h->gclist = g->weak; /* must be cleared after GC, ... */
+ g->weak = obj2gco(h); /* ... so put in the appropriate list */
+ }
+ }
+ if (weakkey && weakvalue) return 1;
+ if (!weakvalue) {
+ i = h->sizearray;
+ while (i--)
+ markvalue(g, &h->array[i]);
+ }
+ i = sizenode(h);
+ while (i--) {
+ Node *n = gnode(h, i);
+ klisp_assert(ttype(gkey(n)) != LUA_TDEADKEY || ttisnil(gval(n)));
+ if (ttisnil(gval(n)))
+ removeentry(n); /* remove empty entries */
+ else {
+ klisp_assert(!ttisnil(gkey(n)));
+ if (!weakkey) markvalue(g, gkey(n));
+ if (!weakvalue) markvalue(g, gval(n));
+ }
+ }
+ return weakkey || weakvalue;
+}
+
+
+/*
+** All marks are conditional because a GC may happen while the
+** prototype is still being created
+*/
+static void traverseproto (global_State *g, Proto *f) {
+ int i;
+ if (f->source) stringmark(f->source);
+ for (i=0; i<f->sizek; i++) /* mark literals */
+ markvalue(g, &f->k[i]);
+ for (i=0; i<f->sizeupvalues; i++) { /* mark upvalue names */
+ if (f->upvalues[i])
+ stringmark(f->upvalues[i]);
+ }
+ for (i=0; i<f->sizep; i++) { /* mark nested protos */
+ if (f->p[i])
+ markobject(g, f->p[i]);
+ }
+ for (i=0; i<f->sizelocvars; i++) { /* mark local-variable names */
+ if (f->locvars[i].varname)
+ stringmark(f->locvars[i].varname);
+ }
+}
+
+#endif
+
+/*
+** traverse one gray object, turning it to black.
+** Returns `quantity' traversed.
+*/
+static int32_t propagatemark (klisp_State *K) {
+ GCObject *o = K->gray;
+ klisp_assert(isgray(o));
+ gray2black(o);
+ uint8_t type = o->gch.tt;
+
+ switch (type) {
+#if 0 /* klisp: keep around */
+ case LUA_TTABLE: {
+ Table *h = gco2h(o);
+ K->gray = h->gclist;
+ if (traversetable(K, h)) /* table is weak? */
+ black2gray(o); /* keep it gray */
+ return sizeof(Table) + sizeof(TValue) * h->sizearray +
+ sizeof(Node) * sizenode(h);
+ }
+#endif
+ /* TODO add klisp cases here */
+
+ default:
+ fprintf(stderr, "Unknown GCObject type (in GC propagate): %d\n",
+ type);
+ abort();
+ }
+}
+
+
+static size_t propagateall (klisp_State *K) {
+ size_t m = 0;
+ while (K->gray) m += propagatemark(K);
+ return m;
+}
+
+#if 0 /* klisp: keep around */
+/*
+** The next function tells whether a key or value can be cleared from
+** a weak table. Non-collectable objects are never removed from weak
+** tables. Strings behave as `values', so are never removed too. for
+** other objects: if really collected, cannot keep them; for userdata
+** being finalized, keep them in keys, but not in values
+*/
+static int iscleared (const TValue *o, int iskey) {
+ if (!iscollectable(o)) return 0;
+ if (ttisstring(o)) {
+ stringmark(rawtsvalue(o)); /* strings are `values', so are never weak */
+ return 0;
+ }
+ return iswhite(gcvalue(o)) ||
+ (ttisuserdata(o) && (!iskey && isfinalized(uvalue(o))));
+}
+
+
+/*
+** clear collected entries from weaktables
+*/
+static void cleartable (GCObject *l) {
+ while (l) {
+ Table *h = gco2h(l);
+ int i = h->sizearray;
+ klisp_assert(testbit(h->gct, VALUEWEAKBIT) ||
+ testbit(h->gct, KEYWEAKBIT));
+ if (testbit(h->gct, VALUEWEAKBIT)) {
+ while (i--) {
+ TValue *o = &h->array[i];
+ if (iscleared(o, 0)) /* value was collected? */
+ setnilvalue(o); /* remove value */
+ }
+ }
+ i = sizenode(h);
+ while (i--) {
+ Node *n = gnode(h, i);
+ if (!ttisnil(gval(n)) && /* non-empty entry? */
+ (iscleared(key2tval(n), 1) || iscleared(gval(n), 0))) {
+ setnilvalue(gval(n)); /* remove value ... */
+ removeentry(n); /* remove entry from table */
+ }
+ }
+ l = h->gclist;
+ }
+}
+#endif
+
+static void freeobj (klisp_State *K, GCObject *o) {
+ /* TODO use specific functions like in bigint & lua */
+ uint8_t type = o->gch.tt;
+ switch (type) {
+ /* case LUA_TTABLE: luaH_free(L, gco2h(o)); break; */
+ case K_TBIGINT: {
+ mp_int_free(K, (Bigint *)o);
+ break;
+ }
+ case K_TPAIR:
+ klispM_free(K, (Pair *)o);
+ break;
+ case K_TSYMBOL:
+ /* The string will be freed before/after */
+ klispM_free(K, (Symbol *)o);
+ break;
+ case K_TSTRING:
+ klispM_freemem(K, o, sizeof(String)+o->str.size+1);
+ break;
+ case K_TENVIRONMENT:
+ klispM_free(K, (Environment *)o);
+ break;
+ case K_TCONTINUATION:
+ klispM_freemem(K, o, sizeof(Continuation) +
+ o->cont.extra_size * sizeof(TValue));
+ break;
+ case K_TOPERATIVE:
+ klispM_freemem(K, o, sizeof(Operative) +
+ o->op.extra_size * sizeof(TValue));
+ break;
+ case K_TAPPLICATIVE:
+ klispM_free(K, (Applicative *)o);
+ break;
+ case K_TENCAPSULATION:
+ klispM_free(K, (Encapsulation *)o);
+ break;
+ case K_TPROMISE:
+ klispM_free(K, (Promise *)o);
+ break;
+ case K_TPORT:
+ /* first close the port to free the FILE structure.
+ This works even if the port was already closed,
+ it is important that this don't throw errors, because
+ the mechanism used in error handling would crash at this
+ point */
+ kclose_port(K, gc2port(o));
+ klispM_free(K, (Port *)o);
+ break;
+ default:
+ /* shouldn't happen */
+ fprintf(stderr, "Unknown GCObject type (in GC free): %d\n",
+ type);
+ abort();
+ }
+}
+
+
+/* klisp can't have more than 4gb */
+#define sweepwholelist(K,p) sweeplist(K,p,UINT32_MAX)
+
+
+static GCObject **sweeplist (klisp_State *K, GCObject **p, uint32_t count)
+{
+ GCObject *curr;
+ int deadmask = otherwhite(K);
+ while ((curr = *p) != NULL && count-- > 0) {
+ if ((curr->gch.gct ^ WHITEBITS) & deadmask) { /* not dead? */
+ klisp_assert(!isdead(K, curr) || testbit(curr->gch.gct, FIXEDBIT));
+ makewhite(K, curr); /* make it white (for next cycle) */
+ p = &curr->gch.next;
+ } else { /* must erase `curr' */
+ klisp_assert(isdead(K, curr) || deadmask == bitmask(SFIXEDBIT));
+ *p = curr->gch.next;
+ if (curr == K->rootgc) /* is the first element of the list? */
+ K->rootgc = curr->gch.next; /* adjust first */
+ freeobj(K, curr);
+ }
+ }
+ return p;
+}
+
+#if 0 /* klisp: keep this around */
+static void checkSizes (lua_State *L) {
+ global_State *g = G(L);
+ /* check size of string hash */
+ if (g->strt.nuse < cast(lu_int32, g->strt.size/4) &&
+ g->strt.size > MINSTRTABSIZE*2)
+ luaS_resize(L, g->strt.size/2); /* table is too big */
+ /* check size of buffer */
+ if (luaZ_sizebuffer(&g->buff) > LUA_MINBUFFER*2) { /* buffer too big? */
+ size_t newsize = luaZ_sizebuffer(&g->buff) / 2;
+ luaZ_resizebuffer(L, &g->buff, newsize);
+ }
+}
+#endif
+
+#if 0 /* klisp: keep this around */
+static void GCTM (lua_State *L) {
+ global_State *g = G(L);
+ GCObject *o = g->tmudata->gch.next; /* get first element */
+ Udata *udata = rawgco2u(o);
+ const TValue *tm;
+ /* remove udata from `tmudata' */
+ if (o == g->tmudata) /* last element? */
+ g->tmudata = NULL;
+ else
+ g->tmudata->gch.next = udata->uv.next;
+ udata->uv.next = g->mainthread->next; /* return it to `root' list */
+ g->mainthread->next = o;
+ makewhite(g, o);
+ tm = fasttm(L, udata->uv.metatable, TM_GC);
+ if (tm != NULL) {
+ lu_byte oldah = L->allowhook;
+ lu_mem oldt = g->GCthreshold;
+ L->allowhook = 0; /* stop debug hooks during GC tag method */
+ g->GCthreshold = 2*g->totalbytes; /* avoid GC steps */
+ setobj2s(L, L->top, tm);
+ setuvalue(L, L->top+1, udata);
+ L->top += 2;
+ luaD_call(L, L->top - 2, 0);
+ L->allowhook = oldah; /* restore hooks */
+ g->GCthreshold = oldt; /* restore threshold */
+ }
+}
+
+
+/*
+** Call all GC tag methods
+*/
+void klispC_callGCTM (lua_State *L) {
+ while (G(L)->tmudata)
+ GCTM(L);
+}
+#endif
+
+/* This still leaves allocated objs in K, namely the
+ arrays that aren't TValues */
+void klispC_freeall (klisp_State *K) {
+ /* mask to collect all elements */
+ K->currentwhite = WHITEBITS | bitmask(SFIXEDBIT); /* in klisp this may not be
+ necessary */
+ sweepwholelist(K, &K->rootgc);
+}
+
+
+#if 0 /* klisp: keep this around */
+static void markmt (global_State *g) {
+ int i;
+ for (i=0; i<NUM_TAGS; i++)
+ if (g->mt[i]) markobject(g, g->mt[i]);
+}
+#endif
+
+/* mark root set */
+static void markroot (klisp_State *K) {
+ K->gray = NULL;
+ K->grayagain = NULL; /* for now in klisp this isn't used */
+ K->weak = NULL; /* for now in klisp this isn't used */
+
+ /* TODO add klisp root set */
+/* markmt(g); */
+ K->gcstate = GCSpropagate;
+}
+
+static void atomic (klisp_State *K) {
+ size_t udsize; /* total size of userdata to be finalized */
+ /* traverse objects caught by write barrier */
+ propagateall(K);
+
+ /* klisp: for now in klisp this isn't used */
+ /* remark weak tables */
+ K->gray = K->weak;
+ K->weak = NULL;
+#if 0 /* keep around */
+ markmt(g); /* mark basic metatables (again) */
+ propagateall(g);
+#endif
+ /* klisp: for now in klisp this isn't used */
+ /* remark gray again */
+ K->gray = K->grayagain;
+ K->grayagain = NULL;
+ propagateall(K);
+
+ udsize = 0; /* to init var 'till we add user data */
+#if 0 /* keep around */
+ udsize = klispC_separateudata(L, 0); /* separate userdata to be finalized */
+ marktmu(g); /* mark `preserved' userdata */
+ udsize += propagateall(g); /* remark, to propagate `preserveness' */
+ cleartable(g->weak); /* remove collected objects from weak tables */
+#endif
+ /* flip current white */
+ K->currentwhite = cast(uint16_t, otherwhite(K));
+ K->sweepgc = &K->rootgc;
+ K->gcstate = GCSsweepstring;
+ K->estimate = K->totalbytes - udsize; /* first estimate */
+}
+
+
+static int32_t singlestep (klisp_State *K) {
+ switch (K->gcstate) {
+ case GCSpause: {
+ markroot(K); /* start a new collection */
+ return 0;
+ }
+ case GCSpropagate: {
+ if (K->gray)
+ return propagatemark(K);
+ else { /* no more `gray' objects */
+ atomic(K); /* finish mark phase */
+ return 0;
+ }
+ }
+ case GCSsweepstring: {
+ /* No need to do anything in klisp, we just kept it
+ to avoid eliminating a state in the GC */
+ K->gcstate = GCSsweep; /* end sweep-string phase */
+ return 0;
+ }
+ case GCSsweep: {
+ uint32_t old = K->totalbytes;
+ K->sweepgc = sweeplist(K, K->sweepgc, GCSWEEPMAX);
+ if (*K->sweepgc == NULL) { /* nothing more to sweep? */
+ /* checkSizes(K); */ /* klisp: keep this around */
+ K->gcstate = GCSfinalize; /* end sweep phase */
+ }
+ klisp_assert(old >= K->totalbytes);
+ K->estimate -= old - K->totalbytes;
+ return GCSWEEPMAX*GCSWEEPCOST;
+ }
+ case GCSfinalize: {
+#if 0 /* keep around */
+ if (g->tmudata) {
+ GCTM(L);
+ if (g->estimate > GCFINALIZECOST)
+ g->estimate -= GCFINALIZECOST;
+ return GCFINALIZECOST;
+ }
+ else {
+#endif
+ K->gcstate = GCSpause; /* end collection */
+ K->gcdept = 0;
+ return 0;
+#if 0
+ }
+#endif
+ }
+ default: klisp_assert(0); return 0;
+ }
+}
+
+
+void klispC_step (klisp_State *K) {
+ int32_t lim = (GCSTEPSIZE/100) * K->gcstepmul;
+
+ if (lim == 0)
+ lim = (UINT32_MAX-1)/2; /* no limit */
+
+ K->gcdept += K->totalbytes - K->GCthreshold;
+
+ do {
+ lim -= singlestep(K);
+ if (K->gcstate == GCSpause)
+ break;
+ } while (lim > 0);
+
+ if (K->gcstate != GCSpause) {
+ if (K->gcdept < GCSTEPSIZE) {
+ /* - lim/g->gcstepmul;*/
+ K->GCthreshold = K->totalbytes + GCSTEPSIZE;
+ } else {
+ K->gcdept -= GCSTEPSIZE;
+ K->GCthreshold = K->totalbytes;
+ }
+ } else {
+ klisp_assert(K->totalbytes >= K->estimate);
+ setthreshold(K);
+ }
+}
+
+
+void klispC_fullgc (klisp_State *K) {
+ if (K->gcstate <= GCSpropagate) {
+ /* reset sweep marks to sweep all elements (returning them to white) */
+ K->sweepgc = &K->rootgc;
+ /* reset other collector lists */
+ K->gray = NULL;
+ K->grayagain = NULL;
+ K->weak = NULL;
+ K->gcstate = GCSsweepstring;
+ }
+ klisp_assert(K->gcstate != GCSpause && K->gcstate != GCSpropagate);
+ /* finish any pending sweep phase */
+ while (K->gcstate != GCSfinalize) {
+ klisp_assert(K->gcstate == GCSsweepstring || K->gcstate == GCSsweep);
+ singlestep(K);
+ }
+ markroot(K);
+ while (K->gcstate != GCSpause) {
+ singlestep(K);
+ }
+ setthreshold(K);
+}
+
+/* TODO: make all code using mutation to call these,
+ this is actually the only thing that is missing for an incremental
+ garbage collector!
+ IMPORTANT: a call to maybe a different but similar function should be
+ made before assigning to a GC guarded variable, or pushed in a GC
+guarded stack! */
+void klispC_barrierf (klisp_State *K, GCObject *o, GCObject *v) {
+ klisp_assert(isblack(o) && iswhite(v) && !isdead(K, v) && !isdead(K, o));
+ klisp_assert(K->gcstate != GCSfinalize && K->gcstate != GCSpause);
+/* klisp_assert(ttype(&o->gch) != LUA_TTABLE); */
+ /* must keep invariant? */
+ if (K->gcstate == GCSpropagate)
+ reallymarkobject(K, v); /* restore invariant */
+ else /* don't mind */
+ makewhite(K, o); /* mark as white just to avoid other barriers */
+}
+
+#if 0 /* keep around */
+void klispC_barrierback (lua_State *L, Table *t) {
+ GCObject *o = obj2gco(t);
+ klisp_assert(isblack(o) && !isdead(g, o));
+ klisp_assert(g->gcstate != GCSfinalize && g->gcstate != GCSpause);
+ black2gray(o); /* make table gray (again) */
+ t->gclist = g->grayagain;
+ g->grayagain = o;
+}
+#endif
+
+/* NOTE: flags is added for klisp */
+void klispC_link (klisp_State *K, GCObject *o, uint8_t tt, uint8_t flags) {
+ o->gch.next = K->rootgc;
+ K->rootgc = o;
+ o->gch.gct = klispC_white(K);
+ o->gch.tt = tt;
+ o->gch.flags = tt;
+ /* NOTE that o->gch.gclist doesn't need to be setted */
+}
+
diff --git a/src/kgc.h b/src/kgc.h
@@ -0,0 +1,115 @@
+/*
+** kgc.h
+** Garbage Collector
+** See Copyright Notice in klisp.h
+*/
+
+/*
+** SOURCE NOTE: This is almost textually from lua.
+** Parts that don't apply, or don't apply yet to klisp are in comments.
+*/
+
+#ifndef kgc_h
+#define kgc_h
+
+#include "kobject.h"
+#include "kstate.h"
+
+/*
+** Possible states of the Garbage Collector
+*/
+#define GCSpause 0
+#define GCSpropagate 1
+#define GCSsweepstring 2
+#define GCSsweep 3
+#define GCSfinalize 4
+
+/* NOTE: unlike in lua the gc flags have 16 bits in klisp,
+ so resetbits is slightly different */
+
+/*
+** some useful bit tricks
+*/
+#define resetbits(x,m) ((x) &= cast(uint16_t, ~(m)))
+#define setbits(x,m) ((x) |= (m))
+#define testbits(x,m) ((x) & (m))
+#define bitmask(b) (1<<(b))
+#define bit2mask(b1,b2) (bitmask(b1) | bitmask(b2))
+#define l_setbit(x,b) setbits(x, bitmask(b))
+#define resetbit(x,b) resetbits(x, bitmask(b))
+#define testbit(x,b) testbits(x, bitmask(b))
+#define set2bits(x,b1,b2) setbits(x, (bit2mask(b1, b2)))
+#define reset2bits(x,b1,b2) resetbits(x, (bit2mask(b1, b2)))
+#define test2bits(x,b1,b2) testbits(x, (bit2mask(b1, b2)))
+
+/* NOTE: in klisp there is still no tables, userdata, threads, weak keys,
+ or finalization. Also the field is called gct instead of marked */
+
+/*
+** Layout for bit use in `gct' field:
+** bit 0 - object is white (type 0)
+** bit 1 - object is white (type 1)
+** bit 2 - object is black
+** bit 3 - for userdata: has been finalized
+** bit 3 - for tables: has weak keys
+** bit 4 - for tables: has weak values
+** bit 5 - object is fixed (should not be collected)
+** bit 6 - object is "super" fixed (only the main thread)
+*/
+
+
+#define WHITE0BIT 0
+#define WHITE1BIT 1
+#define BLACKBIT 2
+#define FINALIZEDBIT 3
+#define KEYWEAKBIT 3
+#define VALUEWEAKBIT 4
+#define FIXEDBIT 5
+#define SFIXEDBIT 6
+#define WHITEBITS bit2mask(WHITE0BIT, WHITE1BIT)
+
+
+#define iswhite(x) test2bits((x)->gch.gct, WHITE0BIT, WHITE1BIT)
+#define isblack(x) testbit((x)->gch.gct, BLACKBIT)
+
+#define isgray(x) (!isblack(x) && !iswhite(x))
+
+#define otherwhite(K) (K->currentwhite ^ WHITEBITS)
+#define isdead(K,v) ((v)->gch.gct & otherwhite(K) & WHITEBITS)
+
+#define changewhite(x) ((x)->gch.gct ^= WHITEBITS)
+#define gray2black(x) l_setbit((x)->gch.gct, BLACKBIT)
+
+#define valiswhite(x) (iscollectable(x) && iswhite(gcvalue(x)))
+
+#define klispC_white(K) cast(uint16_t, (K)->currentwhite & WHITEBITS)
+
+
+#define klispC_checkGC(K) { \
+ if (K->totalbytes >= K->GCthreshold) \
+ klispC_step(K); }
+
+
+#define klispC_barrier(K,p,v) { if (valiswhite(v) && isblack(obj2gco(p))) \
+ klispC_barrierf(K,obj2gco(p),gcvalue(v)); }
+
+#define klispC_barriert(K,t,v) { if (valiswhite(v) && isblack(obj2gco(t))) \
+ klispC_barrierback(K,t); }
+
+#define klispC_objbarrier(K,p,o) \
+ { if (iswhite(obj2gco(o)) && isblack(obj2gco(p))) \
+ klispC_barrierf(K,obj2gco(p),obj2gco(o)); }
+
+#define klispC_objbarriert(K,t,o) \
+ { if (iswhite(obj2gco(o)) && isblack(obj2gco(t))) klispC_barrierback(K,t); }
+
+/* size_t klispC_separateudata (klisp_State *K, int all); */
+/* void klispC_callGCTM (klisp_State *K); */
+void klispC_freeall (klisp_State *K);
+void klispC_step (klisp_State *K);
+void klispC_fullgc (klisp_State *K);
+void klispC_link (klisp_State *K, GCObject *o, uint8_t tt, uint8_t flags);
+void klispC_barrierf (klisp_State *K, GCObject *o, GCObject *v);
+/* void klispC_barrierback (klisp_State *K, Table *t); */
+
+#endif
diff --git a/src/kinteger.c b/src/kinteger.c
@@ -13,6 +13,7 @@
#include "kobject.h"
#include "kstate.h"
#include "kmem.h"
+#include "kgc.h"
/* This tries to convert a bigint to a fixint */
inline TValue kbigint_try_fixint(klisp_State *K, TValue n)
@@ -38,11 +39,7 @@ TValue kbigint_new(klisp_State *K, bool sign, uint32_t digit)
Bigint *new_bigint = klispM_new(K, Bigint);
/* header + gc_fields */
- new_bigint->next = K->root_gc;
- K->root_gc = (GCObject *)new_bigint;
- new_bigint->gct = 0;
- new_bigint->tt = K_TBIGINT;
- new_bigint->flags = 0;
+ klispC_link(K, (GCObject *) new_bigint, K_TBIGINT, 0);
/* bigint specific fields */
/* If later changed to alloc obj:
diff --git a/src/klimits.h b/src/klimits.h
@@ -14,6 +14,11 @@
#include <limits.h>
#include <stddef.h>
+/* this should be done outside of here, but for now */
+#include <assert.h>
+/* turn on assertions for internal checking */
+#define klisp_assert(c) (assert(c))
+
#include "klisp.h"
/* internal assertions for in-house debugging */
diff --git a/src/klisp.c b/src/klisp.c
@@ -10,8 +10,6 @@
#include <setjmp.h>
-/* turn on assertions for internal checking */
-#define klisp_assert (assert)
#include "klimits.h"
#include "klisp.h"
diff --git a/src/klisp.h b/src/klisp.h
@@ -9,6 +9,7 @@
#include <stdlib.h>
+/* NOTE: this inclusion is reversed in lua */
#include "kobject.h"
/*
diff --git a/src/klispconf.h b/src/klispconf.h
@@ -0,0 +1,44 @@
+/*
+** klispconf.h
+** This is a basic configuration file for klisp
+** See Copyright Notice in klisp.h
+*/
+
+/*
+** SOURCE NOTE: this is from lua (greatly reduced)
+*/
+
+#include <limits.h>
+#include <stddef.h>
+#include <stdint.h>
+#include <stdbool.h>
+
+
+/*
+#define KTRACK_MARKS (true)
+*/
+
+/* These are unused for now, but will be once incremental collection is
+ activated */
+/* TEMP: for now the threshold is set manually at the start and then
+ manually adjusted after every collection to override the intenal
+ calculation done with KLISPI_GCPAUSE */
+/*
+@@ KLISPI_GCPAUSE defines the default pause between garbage-collector cycles
+@* as a percentage.
+** CHANGE it if you want the GC to run faster or slower (higher values
+** mean larger pauses which mean slower collection.) You can also change
+** this value dynamically.
+*/
+#define KLISPI_GCPAUSE 200 /* 200% (wait memory to double before next GC) */
+
+
+/*
+@@ KLISPI_GCMUL defines the default speed of garbage collection relative to
+@* memory allocation as a percentage.
+** CHANGE it if you want to change the granularity of the garbage
+** collection. (Higher values mean coarser collections. 0 represents
+** infinity, where each step performs a full collection.) You can also
+** change this value dynamically.
+*/
+#define KLISPI_GCMUL 200 /* GC runs 'twice the speed' of memory allocation */
diff --git a/src/kmem.c b/src/kmem.c
@@ -46,6 +46,7 @@ void *klispM_realloc_ (klisp_State *K, void *block, size_t osize, size_t nsize)
block = (*K->frealloc)(K->ud, block, osize, nsize);
if (block == NULL && nsize > 0) {
+ /* TEMP: try GC if there is no more mem */
/* TODO: make this a catchable error */
fprintf(stderr, MEMERRMSG);
abort();
diff --git a/src/kobject.c b/src/kobject.c
@@ -45,9 +45,18 @@ char *ktv_names[] = {
[K_TBOOLEAN] = "boolean",
[K_TCHAR] = "char",
+ [K_TUSER] = "user pointer",
+
[K_TPAIR] = "pair",
[K_TSTRING] = "string",
- [K_TSYMBOL] = "symbol"
+ [K_TSYMBOL] = "symbol",
+ [K_TENVIRONMENT] = "environment",
+ [K_TCONTINUATION] = "continuation",
+ [K_TOPERATIVE] = "operative",
+ [K_TAPPLICATIVE] = "applicative",
+ [K_TENCAPSULATION] = "encapsulation",
+ [K_TPROMISE] = "promise",
+ [K_TPORT] = "port"
};
bool kis_input_port(TValue o)
diff --git a/src/kobject.h b/src/kobject.h
@@ -30,13 +30,10 @@
#include <stdbool.h>
#include <stdint.h>
+#include <stdio.h>
#include "klimits.h"
-
-/* This should be in a configuration .h */
-/*
-#define KTRACK_MARKS (true)
-*/
+#include "klispconf.h"
/*
** Union of all collectible objects
diff --git a/src/koperative.c b/src/koperative.c
@@ -10,6 +10,7 @@
#include "kobject.h"
#include "kstate.h"
#include "kmem.h"
+#include "kgc.h"
TValue kmake_operative(klisp_State *K, TValue name, TValue si,
klisp_Ofunc fn, int32_t xcount, ...)
@@ -19,11 +20,7 @@ TValue kmake_operative(klisp_State *K, TValue name, TValue si,
klispM_malloc(K, sizeof(Operative) + sizeof(TValue) * xcount);
/* header + gc_fields */
- new_op->next = K->root_gc;
- K->root_gc = (GCObject *)new_op;
- new_op->gct = 0;
- new_op->tt = K_TOPERATIVE;
- new_op->flags = 0;
+ klispC_link(K, (GCObject *) new_op, K_TOPERATIVE, 0);
/* operative specific fields */
new_op->name = name;
diff --git a/src/kpair.c b/src/kpair.c
@@ -8,17 +8,14 @@
#include "kobject.h"
#include "kstate.h"
#include "kmem.h"
+#include "kgc.h"
TValue kcons_g(klisp_State *K, bool m, TValue car, TValue cdr)
{
Pair *new_pair = klispM_new(K, Pair);
/* header + gc_fields */
- new_pair->next = K->root_gc;
- K->root_gc = (GCObject *)new_pair;
- new_pair->gct = 0;
- new_pair->tt = K_TPAIR;
- new_pair->flags = (m? 0 : K_FLAG_IMMUTABLE);
+ klispC_link(K, (GCObject *) new_pair, K_TPAIR, (m? 0 : K_FLAG_IMMUTABLE));
/* pair specific fields */
new_pair->si = KNIL;
diff --git a/src/kport.c b/src/kport.c
@@ -13,6 +13,7 @@
#include "kmem.h"
#include "kerror.h"
#include "kstring.h"
+#include "kgc.h"
/* XXX: per the c spec, this truncates the file if it extists! */
/* Ask John: what would be best? Probably should also include delete,
@@ -40,13 +41,10 @@ TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
Port *new_port = klispM_new(K, Port);
/* header + gc_fields */
- new_port->next = K->root_gc;
- K->root_gc = (GCObject *)new_port;
- new_port->gct = 0;
- new_port->tt = K_TPORT;
- new_port->flags = writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT;
+ klispC_link(K, (GCObject *) new_port, K_TPORT,
+ writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT);
- /* portinuation specific fields */
+ /* port specific fields */
new_port->name = name;
new_port->si = si;
new_port->filename = filename;
diff --git a/src/kpromise.c b/src/kpromise.c
@@ -9,6 +9,7 @@
#include "kpromise.h"
#include "kpair.h"
#include "kmem.h"
+#include "kgc.h"
TValue kmake_promise(klisp_State *K, TValue name, TValue si,
TValue exp, TValue maybe_env)
@@ -16,11 +17,7 @@ TValue kmake_promise(klisp_State *K, TValue name, TValue si,
Promise *new_prom = klispM_new(K, Promise);
/* header + gc_fields */
- new_prom->next = K->root_gc;
- K->root_gc = (GCObject *)new_prom;
- new_prom->gct = 0;
- new_prom->tt = K_TPROMISE;
- new_prom->flags = 0;
+ klispC_link(K, (GCObject *) new_prom, K_TPROMISE, 0);
/* promise specific fields */
new_prom->name = name;
diff --git a/src/kstate.c b/src/kstate.c
@@ -35,7 +35,8 @@
#include "kgpairs_lists.h" /* for creating list_app */
-#include "imath.h" /* for memory freeing */
+#include "kgc.h" /* for memory freeing & gc init */
+
/*
** State creation and destruction
@@ -89,10 +90,27 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->kd_in_port_key = KINERT;
K->kd_out_port_key = KINERT;
- /* TODO: more gc info */
+ /* GC */
+ K->currentwhite = bit2mask(WHITE0BIT, FIXEDBIT);
+ K->gcstate = GCSpause;
+ K->rootgc = NULL;
+ K->sweepgc = &(K->rootgc);
+ K->gray = NULL;
+ K->grayagain = NULL;
+ K->weak = NULL;
+ K->tmudata = NULL;
+ /* how to init other gc values ?? */
K->totalbytes = state_size() + KS_ISSIZE * sizeof(TValue) +
KS_ITBSIZE;
- K->root_gc = NULL;
+ /* CHECK this when implementing incremental collector */
+ K->GCthreshold = 4*K->totalbytes; /* this is from lua, but we
+ still have a lot of allocation
+ to do... */
+
+ K->estimate = 0; /* doesn't matter, it is set by gc later */
+ K->gcdept = 0;
+ K->gcpause = KLISPI_GCPAUSE;
+ K->gcstepmul = KLISPI_GCMUL;
/* TEMP: err */
/* do nothing for now */
@@ -449,69 +467,14 @@ void klispS_run(klisp_State *K)
void klisp_close (klisp_State *K)
{
/* free all collectable objects */
- GCObject *next = K->root_gc;
-
- while(next) {
- GCObject *obj = next;
- next = obj->gch.next;
- int type = gch_get_type(obj);
+ klispC_freeall(K);
- switch(type) {
- case K_TBIGINT: {
- mp_int_free(K, (Bigint *)obj);
- break;
- }
- case K_TPAIR:
- klispM_free(K, (Pair *)obj);
- break;
- case K_TSYMBOL:
- /* The string will be freed before/after */
- klispM_free(K, (Symbol *)obj);
- break;
- case K_TSTRING:
- klispM_freemem(K, obj, sizeof(String)+obj->str.size+1);
- break;
- case K_TENVIRONMENT:
- klispM_free(K, (Environment *)obj);
- break;
- case K_TCONTINUATION:
- klispM_freemem(K, obj, sizeof(Continuation) +
- obj->cont.extra_size * sizeof(TValue));
- break;
- case K_TOPERATIVE:
- klispM_freemem(K, obj, sizeof(Operative) +
- obj->op.extra_size * sizeof(TValue));
- break;
- case K_TAPPLICATIVE:
- klispM_free(K, (Applicative *)obj);
- break;
- case K_TENCAPSULATION:
- klispM_free(K, (Encapsulation *)obj);
- break;
- case K_TPROMISE:
- klispM_free(K, (Promise *)obj);
- break;
- case K_TPORT:
- /* first close the port to free the FILE structure.
- This works even if the port was already closed,
- it is important that this don't throw errors, because
- the mechanism used in error handling would crash at this
- point */
- kclose_port(K, gc2port(obj));
- klispM_free(K, (Port *)obj);
- break;
- default:
- /* shouldn't happen */
- fprintf(stderr, "Unknown GCObject type: %d\n", type);
- abort();
- }
- }
/* free helper buffers */
klispM_freemem(K, ks_sbuf(K), ks_ssize(K) * sizeof(TValue));
klispM_freemem(K, ks_tbuf(K), ks_tbsize(K));
/* only remaining mem should be of the state struct */
- assert(K->totalbytes == state_size());
+ klisp_assert(K->totalbytes == state_size());
/* NOTE: this needs to be done "by hand" */
(*(K->frealloc))(K->ud, K, state_size(), 0);
diff --git a/src/kstate.h b/src/kstate.h
@@ -12,14 +12,11 @@
#ifndef kstate_h
#define kstate_h
-/* TEMP: for error signaling */
-#include <assert.h>
-
#include <stdio.h>
#include <setjmp.h>
-#include "kobject.h"
#include "klimits.h"
+#include "kobject.h"
#include "klisp.h"
#include "ktoken.h"
#include "kmem.h"
@@ -64,9 +61,22 @@ struct klisp_State {
klisp_Alloc frealloc; /* function to reallocate memory */
void *ud; /* auxiliary data to `frealloc' */
- /* TODO: gc info */
- GCObject *root_gc; /* list of all collectable objects */
- int32_t totalbytes;
+ /* GC */
+ uint16_t currentwhite; /* the one of the two whites that is in use in
+ this collection cycle */
+ uint8_t gcstate; /* state of garbage collector */
+ GCObject *rootgc; /* list of all collectable objects */
+ GCObject **sweepgc; /* position of sweep in `rootgc' */
+ GCObject *gray; /* list of gray objects */
+ GCObject *grayagain; /* list of objects to be traversed atomically */
+ GCObject *weak; /* list of weak tables (to be cleared) */
+ GCObject *tmudata; /* last element of list of userdata to be GC */
+ uint32_t GCthreshold;
+ uint32_t totalbytes; /* number of bytes currently allocated */
+ uint32_t estimate; /* an estimate of number of bytes actually in use */
+ uint32_t gcdept; /* how much GC is `behind schedule' */
+ int32_t gcpause; /* size of pause between successive GCs */
+ int32_t gcstepmul; /* GC `granularity' */
/* TEMP: error handling */
jmp_buf error_jb;
@@ -239,7 +249,7 @@ inline char ks_tbpop(klisp_State *K)
inline char *ks_tbget_buffer(klisp_State *K)
{
- assert(ks_tbelem(K, ks_tbidx(K) - 1) == '\0');
+ klisp_assert(ks_tbelem(K, ks_tbidx(K) - 1) == '\0');
return ks_tbuf(K);
}
diff --git a/src/kstring.c b/src/kstring.c
@@ -11,6 +11,7 @@
#include "kobject.h"
#include "kstate.h"
#include "kmem.h"
+#include "kgc.h"
/* TEMP: this is for initializing the above value, for now, from ktoken.h */
TValue kstring_new_empty(klisp_State *K)
@@ -20,11 +21,7 @@ TValue kstring_new_empty(klisp_State *K)
new_str = klispM_malloc(K, sizeof(String) + 1);
/* header + gc_fields */
- new_str->next = K->root_gc;
- K->root_gc = (GCObject *)new_str;
- new_str->gct = 0;
- new_str->tt = K_TSTRING;
- new_str->flags = 0;
+ klispC_link(K, (GCObject *) new_str, K_TSTRING, 0);
/* string specific fields */
new_str->mark = KFALSE;
@@ -46,11 +43,7 @@ TValue kstring_new_g(klisp_State *K, uint32_t size)
new_str = klispM_malloc(K, sizeof(String) + size + 1);
/* header + gc_fields */
- new_str->next = K->root_gc;
- K->root_gc = (GCObject *)new_str;
- new_str->gct = 0;
- new_str->tt = K_TSTRING;
- new_str->flags = 0;
+ klispC_link(K, (GCObject *) new_str, K_TSTRING, 0);
/* string specific fields */
new_str->mark = KFALSE;
diff --git a/src/ksymbol.c b/src/ksymbol.c
@@ -13,6 +13,7 @@
#include "kpair.h"
#include "kstate.h"
#include "kmem.h"
+#include "kgc.h"
TValue ksymbol_new_g(klisp_State *K, const char *buf, int32_t size,
bool identifierp)
@@ -39,11 +40,8 @@ TValue ksymbol_new_g(klisp_State *K, const char *buf, int32_t size,
Symbol *new_sym = klispM_new(K, Symbol);
/* header + gc_fields */
- new_sym->next = K->root_gc;
- K->root_gc = (GCObject *)new_sym;
- new_sym->gct = 0;
- new_sym->tt = K_TSYMBOL;
- new_sym->flags = identifierp? K_FLAG_EXT_REP : 0;
+ klispC_link(K, (GCObject *) new_sym, K_TSYMBOL,
+ identifierp? K_FLAG_EXT_REP : 0);
/* symbol specific fields */
new_sym->mark = KFALSE;
