commit 5c14a3ecf31143f514741fd9fce317fc21fde3cb
parent c3b0290830bfa29735f712d150571b07775042c8
Author: Andres Navarro <canavarro82@gmail.com>
Date: Wed, 20 Apr 2011 03:00:02 -0300
Merged hashtables branch
Diffstat:
37 files changed, 1434 insertions(+), 322 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -10,7 +10,7 @@ MYLIBS=
CORE_O= kobject.o ktoken.o kpair.o kstring.o ksymbol.o kread.o \
kwrite.o kstate.o kmem.o kerror.o kauxlib.o kenvironment.o \
kcontinuation.o koperative.o kapplicative.o keval.o krepl.o \
- kencapsulation.o kpromise.o kport.o kinteger.o \
+ kencapsulation.o kpromise.o kport.o kinteger.o ktable.o \
kground.o kghelpers.o kgbooleans.o kgeqp.o kgequalp.o \
kgsymbols.o kgcontrol.o kgpairs_lists.o kgpair_mut.o kgenvironments.o \
kgenv_mut.o kgcombiners.o kgcontinuations.o kgencapsulations.o \
@@ -41,7 +41,7 @@ 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
+ kapplicative.h koperative.h keval.h krepl.h kground.h
kobject.o: kobject.c kobject.h klimits.h klispconf.h
ktoken.o: ktoken.c ktoken.h kobject.h kstate.h kpair.h kstring.h ksymbol.h \
kerror.h klisp.h kinteger.h
@@ -57,14 +57,14 @@ kread.o: kread.c kread.h kobject.h ktoken.h kpair.h kstate.h kerror.h klisp.h \
kwrite.o: kwrite.c kwrite.h kobject.h kpair.h kstring.h kstate.h kerror.h \
klisp.h kport.h kinteger.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 \
+ 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 kgc.h
+ kstring.h kinteger.h kgc.h klimits.h
kmem.o: kmem.c kmem.h klisp.h kerror.h klisp.h kstate.h kgc.h klispconf.h
kerror.o: kerror.c kerror.h klisp.h kstate.h klisp.h kmem.h kstring.h kpair.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 kgc.h
+ kmem.h kstate.h klisp.h kgc.h ktable.h
kcontinuation.o: kcontinuation.c kcontinuation.h kmem.h kstate.h kobject.h \
klisp.h kgc.h
koperative.o: koperative.c koperative.h kmem.h kstate.h kobject.h \
@@ -77,6 +77,8 @@ kpromise.o: kpromise.c kpromise.h kmem.h kstate.h kobject.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
+ktable.o: ktable.c ktable.h kobject.h kstate.h kmem.h klisp.h kgc.h \
+ kapplicative.h kgeqp.h kstring.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 \
@@ -93,7 +95,8 @@ kghelpers.o: kghelpers.c kghelpers.h kstate.h kstate.h klisp.h kpair.h \
kgbooleans.o: kgbooleans.c kgbooleans.c kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h kcontinuation.h ksymbol.h
kgeqp.o: kgeqp.c kgeqp.c kghelpers.h kstate.h klisp.h \
- kobject.h kerror.h kpair.h kcontinuation.h
+ kobject.h kerror.h kpair.h kcontinuation.h kapplicative.h \
+ kinteger.h
kgequalp.o: kgequalp.c kgequalp.c kghelpers.h kstate.h klisp.h \
kobject.h kerror.h kpair.h kcontinuation.h kgeqp.h kstring.h
kgsymbols.o: kgsymbols.c kgsymbols.c kghelpers.h kstate.h klisp.h \
@@ -140,6 +143,7 @@ kgnumbers.o: kgnumbers.c kgnumbers.h kghelpers.h kstate.h klisp.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
+ kstring.h ksymbol.h kgnumbers.h
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
+kgc.o: kgc.c kgc.h kobject.h kmem.h kstate.h kport.h imath.h ktable.h \
+ kstring.h
diff --git a/src/kapplicative.c b/src/kapplicative.c
@@ -19,8 +19,6 @@ TValue kwrap(klisp_State *K, TValue underlying)
klispC_link(K, (GCObject *) new_app, K_TAPPLICATIVE, 0);
/* applicative specific fields */
- new_app->name = KNIL;
- new_app->si = KNIL;
new_app->underlying = underlying;
return gc2app(new_app);
}
diff --git a/src/kcontinuation.c b/src/kcontinuation.c
@@ -25,8 +25,6 @@ TValue kmake_continuation(klisp_State *K, TValue parent, klisp_Cfunc fn,
/* continuation specific fields */
new_cont->mark = KFALSE;
- new_cont->name = KNIL;
- new_cont->si = KNIL;
new_cont->parent = parent;
new_cont->fn = fn;
new_cont->extra_size = xcount;
diff --git a/src/kencapsulation.c b/src/kencapsulation.c
@@ -20,8 +20,6 @@ TValue kmake_encapsulation(klisp_State *K, TValue key, TValue val)
klispC_link(K, (GCObject *) new_enc, K_TENCAPSULATION, 0);
/* encapsulation specific fields */
- new_enc->name = KNIL;
- new_enc->si = KNIL;
new_enc->key = key;
new_enc->value = val;
diff --git a/src/kenvironment.c b/src/kenvironment.c
@@ -13,6 +13,7 @@
#include "kerror.h"
#include "kstate.h"
#include "kmem.h"
+#include "ktable.h"
#include "kgc.h"
/* keyed dynamic vars */
@@ -84,11 +85,13 @@ TValue kmake_environment(klisp_State *K, TValue parents)
/*
** Helper function for kadd_binding and kget_binding,
+** Only for list environments, table environments are handled elsewhere
** returns KNIL or a pair with sym as car.
*/
TValue kfind_local_binding(klisp_State *K, TValue bindings, TValue sym)
{
- (void) K;
+ UNUSED(K);
+
while(!ttisnil(bindings)) {
TValue first = kcar(bindings);
TValue first_sym = kcar(first);
@@ -109,13 +112,22 @@ TValue kfind_local_binding(klisp_State *K, TValue bindings, TValue sym)
right now, but that could change */
void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val)
{
- TValue oldb = kfind_local_binding(K, kenv_bindings(K, env), sym);
+ klisp_assert(ttisenvironment(env));
+ klisp_assert(ttissymbol(sym));
- if (ttisnil(oldb)) {
- TValue new_pair = kcons(K, sym, val);
- kenv_bindings(K, env) = kcons(K, new_pair, kenv_bindings(K, env));
+ TValue bindings = kenv_bindings(K, env);
+ if (ttistable(bindings)) {
+ TValue *cell = klispH_setsym(K, tv2table(bindings), tv2sym(sym));
+ *cell = val;
} else {
- kset_cdr(oldb, val);
+ TValue oldb = kfind_local_binding(K, bindings, sym);
+
+ if (ttisnil(oldb)) {
+ TValue new_pair = kcons(K, sym, val);
+ kenv_bindings(K, env) = kcons(K, new_pair, bindings);
+ } else {
+ kset_cdr(oldb, val);
+ }
}
}
@@ -134,12 +146,24 @@ inline bool try_get_binding(klisp_State *K, TValue env, TValue sym,
if (ttisnil(obj)) {
continue;
} else if (ttisenvironment(obj)) {
- TValue oldb = kfind_local_binding(K, kenv_bindings(K, obj), sym);
- if (!ttisnil(oldb)) {
- /* remember to leave the stack as it was */
- ks_sdiscardn(K, pushed);
- *value = kcdr(oldb);
- return true;
+ TValue bindings = kenv_bindings(K, obj);
+ if (ttistable(bindings)) {
+ const TValue *cell = klispH_getsym(tv2table(bindings),
+ tv2sym(sym));
+ if (cell != &kfree) {
+ /* remember to leave the stack as it was */
+ ks_sdiscardn(K, pushed);
+ *value = *cell;
+ return true;
+ }
+ } else {
+ TValue oldb = kfind_local_binding(K, bindings, sym);
+ if (!ttisnil(oldb)) {
+ /* remember to leave the stack as it was */
+ ks_sdiscardn(K, pushed);
+ *value = kcdr(oldb);
+ return true;
+ }
}
TValue parents = kenv_parents(K, obj);
ks_spush(K, parents);
@@ -157,6 +181,8 @@ inline bool try_get_binding(klisp_State *K, TValue env, TValue sym,
TValue kget_binding(klisp_State *K, TValue env, TValue sym)
{
+ klisp_assert(ttisenvironment(env));
+ klisp_assert(ttissymbol(sym));
TValue value;
if (try_get_binding(K, env, sym, &value)) {
return value;
@@ -237,3 +263,15 @@ TValue kget_keyed_static_var(klisp_State *K, TValue env, TValue key)
return KINERT;
}
}
+
+/* environments with hashtable bindings */
+/* TEMP: for now only for ground environment */
+TValue kmake_table_environment(klisp_State *K, TValue parents)
+{
+ TValue new_env = kmake_environment(K, parents);
+ krooted_tvs_push(K, new_env);
+ TValue new_table = klispH_new(K, 0, ENVTABSIZE, K_FLAG_WEAK_NOTHING);
+ tv2env(new_env)->bindings = new_table;
+ krooted_tvs_pop(K);
+ return new_env;
+}
diff --git a/src/kenvironment.h b/src/kenvironment.h
@@ -22,4 +22,12 @@ TValue kmake_keyed_static_env(klisp_State *K, TValue parent, TValue key,
TValue val);
TValue kget_keyed_static_var(klisp_State *K, TValue env, TValue key);
+/* environments with hashtable bindings */
+/* TEMP: for now only for ground environment
+ TODO: Should profile too see when it makes sense & should add code
+ to all operatives creating environments to see when it's appropiate
+ or should add code to add binding to at certain point move over to
+ hashtable */
+TValue kmake_table_environment(klisp_State *K, TValue parents);
+
#endif
diff --git a/src/kerror.c b/src/kerror.c
@@ -33,10 +33,9 @@ void clear_buffers(klisp_State *K)
void klispE_throw(klisp_State *K, char *msg)
{
- TValue error_msg = kstring_new(K, msg, strlen(msg));
+ TValue error_msg = kstring_new_b_imm(K, msg);
/* TEMP */
clear_buffers(K);
-
kcall_cont(K, K->error_cont, error_msg);
}
@@ -46,15 +45,16 @@ void klispE_throw_extra(klisp_State *K, char *msg, char *extra_msg) {
int32_t l1 = strlen(msg);
int32_t l2 = strlen(extra_msg);
- int32_t tl = l1+l2+1;
+ int32_t tl = l1+l2;
- char *msg_buf = klispM_malloc(K, tl);
+ char *msg_buf = klispM_malloc(K, tl+1);
strcpy(msg_buf, msg);
strcpy(msg_buf+l1, extra_msg);
+ msg_buf[tl] = '\0';
/* if the mem allocator could throw errors, this
could potentially leak msg_buf */
- TValue error_msg = kstring_new(K, msg_buf, tl);
- klispM_freemem(K, msg_buf, tl);
+ TValue error_msg = kstring_new_bs_imm(K, msg_buf, tl);
+ klispM_freemem(K, msg_buf, tl+1);
clear_buffers(K);
diff --git a/src/kgc.c b/src/kgc.c
@@ -17,10 +17,8 @@
#include "kmem.h"
#include "kport.h"
#include "imath.h"
-
-/* XXX */
-#include "kwrite.h"
-/* XXX */
+#include "ktable.h"
+#include "kstring.h"
#define GCSTEPSIZE 1024u
#define GCSWEEPMAX 40
@@ -68,14 +66,11 @@
#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 */
+ klisp_assert(ttisfree(gval(n)));
+ if (iscollectable(gkey(n)->this))/* dead key; remove it */
+ gkey(n)->this = gc2deadkey(gcvalue(gkey(n)->this));
}
-#endif
static void reallymarkobject (klisp_State *K, GCObject *o)
{
@@ -108,6 +103,7 @@ static void reallymarkobject (klisp_State *K, GCObject *o)
case K_TENCAPSULATION:
case K_TPROMISE:
case K_TPORT:
+ case K_TTABLE:
o->gch.gclist = K->gray;
K->gray = o;
break;
@@ -163,48 +159,44 @@ size_t klispC_separateudata (lua_State *L, int all) {
return deadmem;
}
+#endif
-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 */
- }
+static int32_t traversetable (klisp_State *K, Table *h) {
+ int32_t i;
+ TValue tv = gc2table(h);
+ int32_t weakkey = ktable_has_weak_keys(tv)? 1 : 0;
+ int32_t weakvalue = ktable_has_weak_values(tv)? 1 : 0;
+
+ if (weakkey || weakvalue) { /* is really weak? */
+ h->gct &= ~(KEYWEAK | VALUEWEAK); /* clear bits */
+ h->gct |= cast(uint16_t, (weakkey << KEYWEAKBIT) |
+ (weakvalue << VALUEWEAKBIT));
+ h->gclist = K->weak; /* must be cleared after GC, ... */
+ K->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]);
+ markvalue(K, 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)))
+ klisp_assert(ttype(gkey(n)->this) != K_TDEADKEY ||
+ ttisfree(gval(n)));
+ if (ttisfree(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));
+ klisp_assert(!ttisfree(gkey(n)->this));
+ if (!weakkey) markvalue(K, gkey(n)->this);
+ if (!weakvalue) markvalue(K, gval(n));
}
}
return weakkey || weakvalue;
}
-
+#if 0
/*
** All marks are conditional because a GC may happen while the
** prototype is still being created
@@ -242,23 +234,12 @@ static int32_t propagatemark (klisp_State *K) {
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
/* case K_TBIGINT: bigints are never gray */
case K_TPAIR: {
Pair *p = cast(Pair *, o);
markvalue(K, p->mark);
markvalue(K, p->car);
markvalue(K, p->cdr);
- markvalue(K, p->si);
return sizeof(Pair);
}
case K_TSYMBOL: {
@@ -284,48 +265,43 @@ static int32_t propagatemark (klisp_State *K) {
case K_TCONTINUATION: {
Continuation *c = cast(Continuation *, o);
markvalue(K, c->mark);
- markvalue(K, c->name);
- markvalue(K, c->si);
markvalue(K, c->parent);
markvaluearray(K, c->extra, c->extra_size);
return sizeof(Continuation) + sizeof(TValue) * c->extra_size;
}
case K_TOPERATIVE: {
Operative *op = cast(Operative *, o);
- markvalue(K, op->name);
- markvalue(K, op->si);
markvaluearray(K, op->extra, op->extra_size);
return sizeof(Operative) + sizeof(TValue) * op->extra_size;
}
case K_TAPPLICATIVE: {
Applicative *a = cast(Applicative *, o);
- markvalue(K, a->name);
- markvalue(K, a->si);
markvalue(K, a->underlying);
return sizeof(Applicative);
}
case K_TENCAPSULATION: {
Encapsulation *e = cast(Encapsulation *, o);
- markvalue(K, e->name);
- markvalue(K, e->si);
markvalue(K, e->key);
markvalue(K, e->value);
return sizeof(Encapsulation);
}
case K_TPROMISE: {
Promise *p = cast(Promise *, o);
- markvalue(K, p->name);
- markvalue(K, p->si);
markvalue(K, p->node);
return sizeof(Promise);
}
case K_TPORT: {
Port *p = cast(Port *, o);
- markvalue(K, p->name);
- markvalue(K, p->si);
markvalue(K, p->filename);
return sizeof(Port);
}
+ case K_TTABLE: {
+ Table *h = cast(Table *, o);
+ if (traversetable(K, h)) /* table is weak? */
+ black2gray(o); /* keep it gray */
+ return sizeof(Table) + sizeof(TValue) * h->sizearray +
+ sizeof(Node) * sizenode(h);
+ }
default:
fprintf(stderr, "Unknown GCObject type (in GC propagate): %d\n",
type);
@@ -340,7 +316,6 @@ static size_t propagateall (klisp_State *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
@@ -348,14 +323,19 @@ static size_t propagateall (klisp_State *K) {
** 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) {
+static int32_t iscleared (TValue o, int iskey) {
if (!iscollectable(o)) return 0;
+#if 0 /* klisp: strings may be mutable... */
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))));
+#endif
+ return iswhite(gcvalue(o));
+
+/* klisp: keep around for later
+ || (ttisuserdata(o) && (!iskey && isfinalized(uvalue(o))));
+*/
}
@@ -364,36 +344,34 @@ static int iscleared (const TValue *o, int iskey) {
*/
static void cleartable (GCObject *l) {
while (l) {
- Table *h = gco2h(l);
- int i = h->sizearray;
+ Table *h = (Table *) (l);
+ int32_t 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 */
+ if (iscleared(*o, 0)) /* value was collected? */
+ *o = KFREE; /* remove value */
}
}
i = sizenode(h);
while (i--) {
Node *n = gnode(h, i);
- if (!ttisnil(gval(n)) && /* non-empty entry? */
+ if (!ttisfree(gval(n)) && /* non-empty entry? */
(iscleared(key2tval(n), 1) || iscleared(gval(n), 0))) {
- setnilvalue(gval(n)); /* remove value ... */
+ gval(n) = KFREE; /* 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 */
+ /* TODO use specific functions like in bigint & table */
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;
@@ -402,10 +380,15 @@ static void freeobj (klisp_State *K, GCObject *o) {
klispM_free(K, (Pair *)o);
break;
case K_TSYMBOL:
+ /* symbols are in the string/symbol table */
/* The string will be freed before/after */
+ K->strt.nuse--;
klispM_free(K, (Symbol *)o);
break;
case K_TSTRING:
+ /* immutable strings are in the string/symbol table */
+ if (kstring_immutablep(gc2str(o)))
+ K->strt.nuse--;
klispM_freemem(K, o, sizeof(String)+o->str.size+1);
break;
case K_TENVIRONMENT:
@@ -437,6 +420,9 @@ static void freeobj (klisp_State *K, GCObject *o) {
kclose_port(K, gc2port(o));
klispM_free(K, (Port *)o);
break;
+ case K_TTABLE:
+ klispH_free(K, (Table *)o);
+ break;
default:
/* shouldn't happen */
fprintf(stderr, "Unknown GCObject type (in GC free): %d\n",
@@ -470,20 +456,19 @@ static GCObject **sweeplist (klisp_State *K, GCObject **p, uint32_t count)
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 */
+static void checkSizes (klisp_State *K) {
+ /* check size of string/symbol hash */
+ if (K->strt.nuse < cast(uint32_t , K->strt.size/4) &&
+ K->strt.size > MINSTRTABSIZE*2)
+ klispS_resize(K, K->strt.size/2); /* table is too big */
+#if 0 /* not used in klisp */
/* 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) {
@@ -531,26 +516,20 @@ void klispC_freeall (klisp_State *K) {
K->currentwhite = WHITEBITS | bitmask(SFIXEDBIT); /* in klisp this may not be
necessary */
sweepwholelist(K, &K->rootgc);
+ /* free all symbol/string lists */
+ for (int32_t i = 0; i < K->strt.size; i++)
+ sweepwholelist(K, &K->strt.hash[i]);
}
-#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 */
+ K->grayagain = NULL;
+ K->weak = NULL;
/* TEMP: this is quite awfull, think of other way to do this */
/* MAYBE: some of these could be FIXED */
- markvalue(K, K->symbol_table);
markvalue(K, K->curr_cont);
markvalue(K, K->next_obj);
markvalue(K, K->next_value);
@@ -586,7 +565,6 @@ static void markroot (klisp_State *K) {
markvalue(K, K->dummy_pair1);
markvalue(K, K->dummy_pair2);
markvalue(K, K->dummy_pair3);
-/* markmt(g); */
K->gcstate = GCSpropagate;
}
@@ -599,11 +577,7 @@ static void atomic (klisp_State *K) {
/* 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;
@@ -614,10 +588,12 @@ static void atomic (klisp_State *K) {
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
+ cleartable(K->weak); /* remove collected objects from weak tables */
+
/* flip current white */
K->currentwhite = cast(uint16_t, otherwhite(K));
+ K->sweepstrgc = 0;
K->sweepgc = &K->rootgc;
K->gcstate = GCSsweepstring;
K->estimate = K->totalbytes - udsize; /* first estimate */
@@ -639,16 +615,19 @@ static int32_t singlestep (klisp_State *K) {
}
}
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;
+ uint32_t old = K->totalbytes;
+ sweepwholelist(K, &K->strt.hash[K->sweepstrgc++]);
+ if (K->sweepstrgc >= K->strt.size) /* nothing more to sweep? */
+ K->gcstate = GCSsweep; /* end sweep-string phase */
+ klisp_assert(old >= K->totalbytes);
+ K->estimate -= old - K->totalbytes;
+ return GCSWEEPCOST;
}
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 */
+ checkSizes(K);
K->gcstate = GCSfinalize; /* end sweep phase */
}
klisp_assert(old >= K->totalbytes);
@@ -693,8 +672,8 @@ void klispC_step (klisp_State *K) {
if (K->gcstate != GCSpause) {
if (K->gcdept < GCSTEPSIZE) {
- /* - lim/g->gcstepmul;*/
K->GCthreshold = K->totalbytes + GCSTEPSIZE;
+ /* - lim/g->gcstepmul;*/
} else {
K->gcdept -= GCSTEPSIZE;
K->GCthreshold = K->totalbytes;
@@ -707,25 +686,26 @@ void klispC_step (klisp_State *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);
+ /* reset sweep marks to sweep all elements (returning them to white) */
+ K->sweepstrgc = 0;
+ 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,
@@ -737,7 +717,7 @@ 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); */
+ klisp_assert(o->gch.tt != K_TTABLE);
/* must keep invariant? */
if (K->gcstate == GCSpropagate)
reallymarkobject(K, v); /* restore invariant */
@@ -745,24 +725,22 @@ void klispC_barrierf (klisp_State *K, GCObject *o, GCObject *v) {
makewhite(K, o); /* mark as white just to avoid other barriers */
}
-#if 0 /* keep around */
-void klispC_barrierback (lua_State *L, Table *t) {
+void klispC_barrierback (klisp_State *K, Table *t) {
GCObject *o = obj2gco(t);
- klisp_assert(isblack(o) && !isdead(g, o));
- klisp_assert(g->gcstate != GCSfinalize && g->gcstate != GCSpause);
+ klisp_assert(isblack(o) && !isdead(K, o));
+ klisp_assert(K->gcstate != GCSfinalize && K->gcstate != GCSpause);
black2gray(o); /* make table gray (again) */
- t->gclist = g->grayagain;
- g->grayagain = o;
+ t->gclist = K->grayagain;
+ K->grayagain = o;
}
-#endif
-/* NOTE: flags is added for klisp */
-void klispC_link (klisp_State *K, GCObject *o, uint8_t tt, uint8_t flags) {
+/* NOTE: kflags is added for klisp */
+void klispC_link (klisp_State *K, GCObject *o, uint8_t tt, uint8_t kflags) {
o->gch.next = K->rootgc;
K->rootgc = o;
o->gch.gct = klispC_white(K);
o->gch.tt = tt;
- o->gch.flags = flags;
+ o->gch.kflags = kflags;
/* NOTE that o->gch.gclist doesn't need to be setted */
}
diff --git a/src/kgc.h b/src/kgc.h
@@ -42,8 +42,8 @@
#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 */
+/* NOTE: in klisp there is still no userdata, threads or finalization.
+ Also the field is called gct instead of marked */
/*
** Layout for bit use in `gct' field:
@@ -110,6 +110,6 @@ 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); */
+void klispC_barrierback (klisp_State *K, Table *t);
#endif
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -81,7 +81,8 @@ void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv)
/* TODO use name from operative */
match(K, "[user-operative]", env, ptree, obj);
- kadd_binding(K, env, penv, denv);
+ if (!ttisignore(penv))
+ kadd_binding(K, env, penv, denv);
/* keep env in stack in case a cont has to be constructed */
diff --git a/src/kgeqp.h b/src/kgeqp.h
@@ -15,6 +15,8 @@
#include "kstate.h"
#include "kobject.h"
+#include "kapplicative.h" /* for unwrap */
+#include "kinteger.h" /* for kbigint_eqp */
#include "klisp.h"
#include "kghelpers.h"
@@ -23,11 +25,25 @@
void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* Helper (also used in equal?) */
-/* TEMP: for now this is the same as tv_equal,
- later it will change with numbers and immutable objects */
+/* TEMP: this will change with immutable strings */
inline bool eq2p(klisp_State *K, TValue obj1, TValue obj2)
{
- return (tv_equal(obj1, obj2));
+ bool res = (tv_equal(obj1, obj2));
+ if (!res && (ttype(obj1) == ttype(obj2))) {
+ if (ttisapplicative(obj1)) {
+ while(ttisapplicative(obj1) && ttisapplicative(obj2)) {
+ obj1 = kunwrap(obj1);
+ obj2 = kunwrap(obj2);
+ }
+ res = (tv_equal(obj1, obj2));
+ } else if (ttisbigint(obj1)) {
+ /* it's important to know that it can't be the case
+ that obj1 is bigint and obj is some other type and
+ (eq? obj1 obj2) */
+ res = kbigint_eqp(obj1, obj2);
+ }
+ }
+ return res;
}
#endif
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -181,7 +181,7 @@ bool equal2p(klisp_State *K, TValue obj1, TValue obj2)
while(!ks_sisempty(K)) {
obj2 = ks_spop(K);
obj1 = ks_spop(K);
-
+/* REFACTOR these ifs: compare both types first, then switch on type */
if (!eq2p(K, obj1, obj2)) {
if (ttispair(obj1) && ttispair(obj2)) {
/* if they were already compaired, consider equal for now
diff --git a/src/kground.c b/src/kground.c
@@ -807,7 +807,13 @@ void kinit_ground_env(klisp_State *K)
/* 13.2.8? string-copy */
add_applicative(K, ground_env, "string-copy", string_copy, 0);
- /* 13.2.9? string-fill! */
+ /* 13.2.9? string->immutable-string */
+ add_applicative(K, ground_env, "string->immutable-string",
+ string_to_immutable_string, 0);
+
+ /* TODO: add string-immutable? or general immutable? */
+
+ /* 13.2.10? string-fill! */
add_applicative(K, ground_env, "string-fill!", string_fillS, 0);
/*
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -49,7 +49,7 @@ void make_string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
return;
}
- TValue new_str = kstring_new_sc(K, ivalue(tv_s), fill);
+ TValue new_str = kstring_new_sf(K, ivalue(tv_s), fill);
kapply_cc(K, new_str);
}
@@ -102,6 +102,9 @@ void string_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* TODO show index */
klispE_throw(K, "string-set!: index out of bounds");
return;
+ } else if (kstring_immutablep(str)) {
+ klispE_throw(K, "string-set!: immutable string");
+ return;
}
int32_t i = ivalue(tv_i);
@@ -130,7 +133,7 @@ inline TValue list_to_string_h(klisp_State *K, char *name, TValue ls)
if (pairs == 0) {
return K->empty_string;
} else {
- new_str = kstring_new_g(K, pairs);
+ new_str = kstring_new_s(K, pairs);
char *buf = kstring_buf(new_str);
TValue tail = ls;
while(pairs--) {
@@ -162,14 +165,9 @@ void string(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* Helpers for binary predicates */
/* XXX: this should probably be in file kstring.h */
-bool kstring_eqp(TValue str1, TValue str2)
-{
- int32_t size = kstring_size(str1);
- if (kstring_size(str2) != size)
- return false;
- else
- return ((size == 0) ||
- memcmp(kstring_buf(str1), kstring_buf(str2), size) == 0);
+
+bool kstring_eqp(TValue str1, TValue str2) {
+ return tv_equal(str1, str2) || kstring_equalp(str1, str2);
}
bool kstring_ci_eqp(TValue str1, TValue str2)
@@ -241,6 +239,7 @@ bool kstring_ci_gep(TValue str1, TValue str2)
}
/* 13.2.5? substring */
+/* TEMP: at least for now this always returns mutable strings */
void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
@@ -278,12 +277,13 @@ void substring(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
if (size == 0) {
new_str = K->empty_string;
} else {
- new_str = kstring_new(K, kstring_buf(str)+start, size);
+ new_str = kstring_new_bs(K, kstring_buf(str)+start, size);
}
kapply_cc(K, new_str);
}
/* 13.2.6? string-append */
+/* TEMP: at least for now this always returns mutable strings */
/* TEMP: this does 3 passes over the list */
void string_append(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
@@ -314,7 +314,7 @@ void string_append(klisp_State *K, TValue *xparams, TValue ptree,
if (size == 0) {
new_str = K->empty_string;
} else {
- new_str = kstring_new_g(K, size);
+ new_str = kstring_new_s(K, size);
char *buf = kstring_buf(new_str);
/* loop again to copy the chars of each string */
tail = ptree;
@@ -369,6 +369,7 @@ void list_to_string(klisp_State *K, TValue *xparams, TValue ptree,
}
/* 13.2.8? string-copy */
+/* TEMP: at least for now this always returns mutable strings */
void string_copy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
@@ -380,12 +381,29 @@ void string_copy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
if (tv_equal(str, K->empty_string)) {
new_str = str;
} else {
- new_str = kstring_new(K, kstring_buf(str), kstring_size(str));
+ new_str = kstring_new_bs(K, kstring_buf(str), kstring_size(str));
}
kapply_cc(K, new_str);
}
-/* 13.2.9? string-fill! */
+/* 13.2.9? string->immutable-string */
+void string_to_immutable_string(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv)
+{
+ UNUSED(xparams);
+ UNUSED(denv);
+ bind_1tp(K, "string->immutable-string", ptree, "string", ttisstring, str);
+
+ TValue res_str;
+ if (kstring_immutablep(str)) {/* this includes the empty list */
+ res_str = str;
+ } else {
+ res_str = kstring_new_bs_imm(K, kstring_buf(str), kstring_size(str));
+ }
+ kapply_cc(K, res_str);
+}
+
+/* 13.2.10? string-fill! */
void string_fillS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
@@ -393,22 +411,26 @@ void string_fillS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_2tp(K, "string-fill!", ptree, "string", ttisstring, str,
"char", ttischar, tv_ch);
+ if (kstring_immutablep(str)) {
+ klispE_throw(K, "string-fill!: immutable string");
+ return;
+ }
+
memset(kstring_buf(str), chvalue(tv_ch), kstring_size(str));
kapply_cc(K, KINERT);
}
/* 13.3.1? symbol->string */
-/* TEMP: for now all strings are mutable, this returns a new object
- each time */
+/* The strings in symbols are immutable so we can just return that */
void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
{
UNUSED(xparams);
UNUSED(denv);
bind_1tp(K, "symbol->string", ptree, "symbol", ttissymbol, sym);
- TValue new_str = kstring_new(K, ksymbol_buf(sym), ksymbol_size(sym));
- kapply_cc(K, new_str);
+ TValue str = ksymbol_str(sym);
+ kapply_cc(K, str);
}
/* 13.3.2? string->symbol */
@@ -421,6 +443,7 @@ void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
because the report only says that read objects when written and read
again must be equal? which happens here
*/
+/* If the string is mutable it is copied */
void string_to_symbol(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
{
diff --git a/src/kgstrings.h b/src/kgstrings.h
@@ -78,12 +78,14 @@ void string_to_list(klisp_State *K, TValue *xparams, TValue ptree,
/* 13.2.8? string-copy */
void string_copy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
-/* 13.2.9? string-fill! */
+/* 13.2.9? string->immutable-string */
+void string_to_immutable_string(klisp_State *K, TValue *xparams,
+ TValue ptree, TValue denv);
+
+/* 13.2.10? string-fill! */
void string_fillS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
/* 13.3.1? symbol->string */
-/* TEMP: for now all strings are mutable, this returns a new object
- each time */
void symbol_to_string(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv);
diff --git a/src/klimits.h b/src/klimits.h
@@ -42,4 +42,20 @@
#define cast(t, exp) ((t)(exp))
#endif
+/*
+** conversion of pointer to integer
+** this is for hashing only; there is no problem if the integer
+** cannot hold the whole pointer value
+*/
+#define IntPoint(p) ((uint32_t)(p))
+
+/* minimum size for the string table (must be power of 2) */
+#ifndef MINSTRTABSIZE
+#define MINSTRTABSIZE 32
+#endif
+
+/* starting size for ground environment hashtable */
+/* at last count, there were about 200 bindings in ground env */
+#define ENVTABSIZE 512
+
#endif
diff --git a/src/klispconf.h b/src/klispconf.h
@@ -16,7 +16,7 @@
/* temp defines till gc is stabilized */
#define KUSE_GC 1
/* Print msgs when starting and ending gc */
-/* #define KDEBUG_GC 1 */
+#define KDEBUG_GC 1
/*
#define KTRACK_MARKS (true)
diff --git a/src/kmem.c b/src/kmem.c
@@ -20,6 +20,8 @@
#include "kerror.h"
#include "kgc.h"
+#define MINSIZEARRAY 4
+
/*
** About the realloc function:
** void * frealloc (void *ud, void *ptr, size_t osize, size_t nsize);
@@ -38,6 +40,31 @@
** (any reallocation to an equal or smaller size cannot fail!)
*/
+void *klispM_growaux_ (klisp_State *K, void *block, int *size, size_t size_elems,
+ int32_t limit, const char *errormsg) {
+ void *newblock;
+ int32_t newsize;
+ if (*size >= limit/2) { /* cannot double it? */
+ if (*size >= limit) /* cannot grow even a little? */
+ klispE_throw(K, (char *) errormsg); /* XXX */
+ newsize = limit; /* still have at least one free place */
+ }
+ else {
+ newsize = (*size)*2;
+ if (newsize < MINSIZEARRAY)
+ newsize = MINSIZEARRAY; /* minimum size */
+ }
+ newblock = klispM_reallocv(K, block, *size, newsize, size_elems);
+ *size = newsize; /* update only when everything else is OK */
+ return newblock;
+}
+
+
+void *klispM_toobig (klisp_State *K) {
+ klispE_throw(K, "memory allocation error: block too big");
+ return NULL; /* to avoid warnings */
+}
+
/*
** generic allocation routine.
diff --git a/src/kmem.h b/src/kmem.h
@@ -8,7 +8,7 @@
#define kmem_h
/*
-** SOURCE NOTE: This is from Lua, but greatly shortened
+** SOURCE NOTE: This is from Lua
*/
#include <stddef.h>
@@ -17,13 +17,32 @@
#define MEMERRMSG "not enough memory"
+#define klispM_reallocv(L,b,on,n,e) \
+ ((cast(size_t, (n)+1) <= SIZE_MAX/(e)) ? /* +1 to avoid warnings */ \
+ klispM_realloc_(L, (b), (on)*(e), (n)*(e)) : \
+ klispM_toobig(L))
+
#define klispM_freemem(K, b, s) klispM_realloc_(K, (b), (s), 0)
#define klispM_free(K, b) klispM_realloc_(K, (b), sizeof(*(b)), 0)
+#define klispM_freearray(L, b, n, t) klispM_reallocv(L, (b), n, 0, sizeof(t))
#define klispM_malloc(K,t) klispM_realloc_(K, NULL, 0, (t))
#define klispM_new(K,t) cast(t *, klispM_malloc(K, sizeof(t)))
+#define klispM_newvector(L,n,t) \
+ cast(t *, klispM_reallocv(L, NULL, 0, n, sizeof(t)))
+
+#define klispM_growvector(L,v,nelems,size,t,limit,e) \
+ if ((nelems)+1 > (size)) \
+ ((v)=cast(t *, klispM_growaux_(L,v,&(size),sizeof(t),limit,e)))
+
+#define klispM_reallocvector(L, v,oldn,n,t) \
+ ((v)=cast(t *, klispM_reallocv(L, v, oldn, n, sizeof(t))))
void *klispM_realloc_ (klisp_State *K, void *block, size_t oldsize,
size_t size);
+void *klispM_toobig (klisp_State *K);
+void *klispM_growaux_ (klisp_State *K, void *block, int *size,
+ size_t size_elem, int limit,
+ const char *errormsg);
#endif
diff --git a/src/kobject.c b/src/kobject.c
@@ -22,6 +22,7 @@ const TValue kepinf = KEPINF_;
const TValue keminf = KEMINF_;
const TValue kspace = KSPACE_;
const TValue knewline = KNEWLINE_;
+const TValue kfree = KFREE_;
/*
** The name strings for all TValue types
@@ -44,6 +45,8 @@ char *ktv_names[] = {
[K_TEOF] = "eof",
[K_TBOOLEAN] = "boolean",
[K_TCHAR] = "char",
+ [K_TCHAR] = "free entry",
+ [K_TDEADKEY] = "dead key",
[K_TUSER] = "user pointer",
@@ -69,3 +72,18 @@ bool kis_output_port(TValue o)
return ttisport(o) && kport_is_output(o);
}
+int32_t klispO_log2 (uint32_t x) {
+ static const uint8_t log_2[256] = {
+ 0,1,2,2,3,3,3,3,4,4,4,4,4,4,4,4,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,5,
+ 6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,6,
+ 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
+ 7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,7,
+ 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
+ 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
+ 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,
+ 8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8,8
+ };
+ int32_t l = -1;
+ while (x >= 256) { l += 8; x >>= 8; }
+ return l + log_2[x];
+}
diff --git a/src/kobject.h b/src/kobject.h
@@ -44,11 +44,11 @@ typedef union GCObject GCObject;
** Common Header for all collectible objects (in macro form, to be
** included in other objects)
*/
-#define CommonHeader GCObject *next; uint8_t tt; uint8_t flags; \
+#define CommonHeader GCObject *next; uint8_t tt; uint8_t kflags; \
uint16_t gct; uint32_t padding; GCObject *gclist;
/* NOTE: the gc flags are called marked in lua, but we reserve that them
- for marks used in cycle traversal. The field flags is also missing
+ for marks used in cycle traversal. The field kflags is also missing
from lua, they serve as compact bool fields for certain types */
/*
@@ -147,6 +147,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TEOF 23
#define K_TBOOLEAN 24
#define K_TCHAR 25
+#define K_TFREE 26 /* this is used instead of lua nil in tables */
/* user pointer */
#define K_TUSER 29
@@ -160,6 +161,10 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TENCAPSULATION 37
#define K_TPROMISE 38
#define K_TPORT 39
+#define K_TTABLE 40
+
+/* for tables */
+#define K_TDEADKEY 60
/* this is used to test for numbers, as returned by ttype */
#define K_LAST_NUMBER_TYPE K_TCOMPLEX
@@ -187,6 +192,8 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TAG_EOF K_MAKE_VTAG(K_TEOF)
#define K_TAG_BOOLEAN K_MAKE_VTAG(K_TBOOLEAN)
#define K_TAG_CHAR K_MAKE_VTAG(K_TCHAR)
+#define K_TAG_FREE K_MAKE_VTAG(K_TDEADKEY)
+#define K_TAG_DEADKEY K_MAKE_VTAG(K_TDEADKEY)
#define K_TAG_USER K_MAKE_VTAG(K_TUSER)
@@ -202,6 +209,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define K_TAG_ENCAPSULATION K_MAKE_VTAG(K_TENCAPSULATION)
#define K_TAG_PROMISE K_MAKE_VTAG(K_TPROMISE)
#define K_TAG_PORT K_MAKE_VTAG(K_TPORT)
+#define K_TAG_TABLE K_MAKE_VTAG(K_TTABLE)
/*
@@ -221,7 +229,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
/* Simple types (value in TValue struct) */
#define ttisfixint(o) (tbasetype_(o) == K_TAG_FIXINT)
-#define ttisbigint(o) (tbasetype_(o) == K_TAG_FIXINT)
+#define ttisbigint(o) (tbasetype_(o) == K_TAG_BIGINT)
#define ttisinteger(o_) ({ int32_t t_ = tbasetype_(o_); \
t_ == K_TAG_FIXINT || t_ == K_TAG_BIGINT;})
#define ttisnumber(o) (ttype(o) <= K_LAST_NUMBER_TYPE); })
@@ -233,6 +241,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttiseof(o) (tbasetype_(o) == K_TAG_EOF)
#define ttisboolean(o) (tbasetype_(o) == K_TAG_BOOLEAN)
#define ttischar(o) (tbasetype_(o) == K_TAG_CHAR)
+#define ttisfree(o) (tbasetype_(o) == K_TAG_FREE)
#define ttisdouble(o) ((ttag(o) & K_TAG_BASE_MASK) != K_TAG_TAGGED)
/* Complex types (value in heap),
@@ -254,6 +263,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttisencapsulation(o) (tbasetype_(o) == K_TAG_ENCAPSULATION)
#define ttispromise(o) (tbasetype_(o) == K_TAG_PROMISE)
#define ttisport(o) (tbasetype_(o) == K_TAG_PORT)
+#define ttistable(o) (tbasetype_(o) == K_TAG_TABLE)
/* macros to easily check boolean values */
#define kis_true(o_) (tv_equal((o_), KTRUE))
@@ -316,20 +326,22 @@ typedef struct __attribute__ ((__packed__)) {
TValue mark; /* for cycle/sharing aware algorithms */
TValue car;
TValue cdr;
- TValue si; /* source code info (either () or (filename line col) */
} Pair;
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
TValue mark; /* for cycle/sharing aware algorithms */
TValue str; /* could use String * here, but for now... */
+ uint32_t hash; /* this is different from the str hash to
+ avoid having both the string and the symbol
+ from always falling in the same bucket */
} Symbol;
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
TValue mark; /* for cycle/sharing aware algorithms */
TValue parents; /* may be (), a list, or a single env */
- TValue bindings; /* TEMP: for now alist of (binding . value) */
+ TValue bindings; /* alist of (binding . value) or table */
/* for keyed static vars */
TValue keyed_node; /* (key . value) pair or KNIL */
/* this is a different field from parents to jump over non keyed
@@ -340,8 +352,6 @@ typedef struct __attribute__ ((__packed__)) {
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
TValue mark; /* for guarding continuation */
- TValue name; /* cont name/type */
- TValue si; /* source code info (either () or (filename line col) */
TValue parent; /* may be () for root continuation */
void *fn; /* the function that does the work */
int32_t extra_size;
@@ -350,8 +360,6 @@ typedef struct __attribute__ ((__packed__)) {
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
- TValue name;
- TValue si; /* source code info (either () or (filename line col) */
void *fn; /* the function that does the work */
int32_t extra_size;
TValue extra[];
@@ -359,23 +367,17 @@ typedef struct __attribute__ ((__packed__)) {
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
- TValue name;
- TValue si; /* source code info (either () or (filename line col) */
TValue underlying; /* underlying operative/applicative */
} Applicative;
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
- TValue name;
- TValue si; /* source code info (either () or (filename line col) */
TValue key; /* unique pair identifying this type of encapsulation */
TValue value; /* encapsulated object */
} Encapsulation;
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
- TValue name;
- TValue si; /* source code info (either () or (filename line col) */
TValue node; /* pair (exp . maybe-env) */
/* if maybe-env is nil, then the promise has determined exp,
otherwise the promise should eval exp in maybe-env when forced
@@ -384,15 +386,59 @@ typedef struct __attribute__ ((__packed__)) {
sharing the pair */
} Promise;
-/* input/output direction and open/close status are in flags */
+/* input/output direction and open/close status are in kflags */
typedef struct __attribute__ ((__packed__)) {
CommonHeader;
- TValue name;
- TValue si; /* source code info (either () or (filename line col) */
TValue filename;
FILE *file;
} Port;
+/* input/output direction and open/close status are in kflags */
+
+/*
+** Hashtables
+*/
+
+typedef union TKey {
+ struct {
+ TValue this; /* different from lua because of the tagging scheme */
+ struct Node *next; /* for chaining */
+ } nk;
+ TValue tvk;
+} TKey;
+
+typedef struct Node {
+ TValue i_val;
+ TKey i_key;
+} Node;
+
+typedef struct __attribute__ ((__packed__)) {
+ CommonHeader;
+ uint8_t lsizenode; /* log2 of size of `node' array */
+ uint8_t t1padding;
+ uint16_t t2padding; /* to avoid disturbing the alignment */
+ TValue *array; /* array part */
+ Node *node;
+ Node *lastfree; /* any free position is before this position */
+ int32_t sizearray; /* size of `array' array */
+} Table;
+
+/* The weak flags are in kflags */
+
+/*
+** `module' operation for hashing (size is always a power of 2)
+*/
+#define lmod(s,size) \
+ (check_exp((size&(size-1))==0, (cast(int32_t, (s) & ((size)-1)))))
+
+
+#define twoto(x) (1<<(x))
+#define sizenode(t) (twoto((t)->lsizenode))
+
+#define ceillog2(x) (klispO_log2((x)-1) + 1)
+
+int32_t klispO_log2 (uint32_t x);
+
/*
** RATIONALE:
**
@@ -405,9 +451,12 @@ typedef struct __attribute__ ((__packed__)) {
CommonHeader;
TValue mark; /* for cycle/sharing aware algorithms */
uint32_t size;
+ uint32_t hash; /* only used for immutable strings */
char b[]; // buffer
} String;
+/* MAYBE: mark fields could be replaced by a hashtable or a bit + a hashtable */
+
/*
** Common header for markable objects
*/
@@ -433,6 +482,7 @@ union GCObject {
Encapsulation enc;
Promise prom;
Port port;
+ Table table;
};
@@ -449,6 +499,7 @@ union GCObject {
#define KEMINF_ {.tv = {.t = K_TAG_EINF, .v = { .i = -1 }}}
#define KSPACE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = ' ' }}}
#define KNEWLINE_ {.tv = {.t = K_TAG_CHAR, .v = { .ch = '\n' }}}
+#define KFREE_ {.tv = {.t = K_TAG_FREE, .v = { .i = 0 }}}
/* RATIONALE: the ones above can be used in initializers */
@@ -462,6 +513,7 @@ union GCObject {
#define KEMINF ((TValue) KEMINF_)
#define KSPACE ((TValue) KSPACE_)
#define KNEWLINE ((TValue) KNEWLINE_)
+#define KFREE ((TValue) KFREE_)
/* The same constants as global const variables */
const TValue knil;
@@ -474,6 +526,7 @@ const TValue kepinf;
const TValue keminf;
const TValue kspace;
const TValue knewline;
+const TValue kfree;
/* Macros to create TValues of non-heap allocated types (for initializers) */
#define ch2tv_(ch_) {.tv = {.t = K_TAG_CHAR, .v = { .ch = (ch_) }}}
@@ -504,6 +557,8 @@ const TValue knewline;
#define gc2enc(o_) (gc2tv(K_TAG_ENCAPSULATION, o_))
#define gc2prom(o_) (gc2tv(K_TAG_PROMISE, o_))
#define gc2port(o_) (gc2tv(K_TAG_PORT, o_))
+#define gc2table(o_) (gc2tv(K_TAG_TABLE, o_))
+#define gc2deadkey(o_) (gc2tv(K_TAG_DEADKEY, o_))
/* Macro to convert a TValue into a specific heap allocated object */
#define tv2bigint(v_) ((Bigint *) gcvalue(v_))
@@ -517,6 +572,7 @@ const TValue knewline;
#define tv2enc(v_) ((Encapsulation *) gcvalue(v_))
#define tv2prom(v_) ((Promise *) gcvalue(v_))
#define tv2port(v_) ((Port *) gcvalue(v_))
+#define tv2table(v_) ((Table *) gcvalue(v_))
#define tv2gch(v_) ((GCheader *) gcvalue(v_))
#define tv2mgch(v_) ((MGCheader *) gcvalue(v_))
@@ -568,48 +624,61 @@ int32_t kmark_count;
#define kis_marked(p_) (!kis_unmarked(p_))
#define kis_unmarked(p_) (tv_equal(kget_mark(p_), KFALSE))
-/* Macros to access flags & type in GCHeader */
+/* Macros to access kflags & type in GCHeader */
+/* TODO: 1 should always be reserved for mutability flag */
#define gch_get_type(o_) (obj2gch(o_)->tt)
-#define gch_get_flags(o_) (obj2gch(o_)->flags)
-#define tv_get_flags(o_) (gch_get_flags(tv2gch(o_)))
+#define gch_get_kflags(o_) (obj2gch(o_)->kflags)
+#define tv_get_kflags(o_) (gch_get_kflags(tv2gch(o_)))
-/* Flags for symbols */
+/* KFlags for symbols */
/* has external representation (identifiers) */
#define K_FLAG_EXT_REP 0x01
-#define khas_ext_rep(s_) ((tv_get_flags(s_) & K_FLAG_EXT_REP) != 0)
+#define khas_ext_rep(s_) ((tv_get_kflags(s_) & K_FLAG_EXT_REP) != 0)
-/* Flags for marking continuations */
+/* KFlags for marking continuations */
#define K_FLAG_OUTER 0x01
#define K_FLAG_INNER 0x02
#define K_FLAG_DYNAMIC 0x04
#define K_FLAG_BOOL_CHECK 0x08
/* evaluate c_ more than once */
-#define kset_inner_cont(c_) (tv_get_flags(c_) |= K_FLAG_INNER)
-#define kset_outer_cont(c_) (tv_get_flags(c_) |= K_FLAG_OUTER)
-#define kset_dyn_cont(c_) (tv_get_flags(c_) |= K_FLAG_DYNAMIC)
-#define kset_bool_check_cont(c_) (tv_get_flags(c_) |= K_FLAG_BOOL_CHECK)
+#define kset_inner_cont(c_) (tv_get_kflags(c_) |= K_FLAG_INNER)
+#define kset_outer_cont(c_) (tv_get_kflags(c_) |= K_FLAG_OUTER)
+#define kset_dyn_cont(c_) (tv_get_kflags(c_) |= K_FLAG_DYNAMIC)
+#define kset_bool_check_cont(c_) (tv_get_kflags(c_) |= K_FLAG_BOOL_CHECK)
-#define kis_inner_cont(c_) ((tv_get_flags(c_) & K_FLAG_INNER) != 0)
-#define kis_outer_cont(c_) ((tv_get_flags(c_) & K_FLAG_OUTER) != 0)
-#define kis_dyn_cont(c_) ((tv_get_flags(c_) & K_FLAG_DYNAMIC) != 0)
-#define kis_bool_check_cont(c_) ((tv_get_flags(c_) & K_FLAG_BOOL_CHECK) != 0)
+#define kis_inner_cont(c_) ((tv_get_kflags(c_) & K_FLAG_INNER) != 0)
+#define kis_outer_cont(c_) ((tv_get_kflags(c_) & K_FLAG_OUTER) != 0)
+#define kis_dyn_cont(c_) ((tv_get_kflags(c_) & K_FLAG_DYNAMIC) != 0)
+#define kis_bool_check_cont(c_) ((tv_get_kflags(c_) & K_FLAG_BOOL_CHECK) != 0)
+/* for now only used in pairs and strings */
#define K_FLAG_IMMUTABLE 0x01
-#define kis_mutable(o_) ((tv_get_flags(o_) & K_FLAG_IMMUTABLE) == 0)
+#define kis_mutable(o_) ((tv_get_kflags(o_) & K_FLAG_IMMUTABLE) == 0)
#define kis_immutable(o_) (!kis_mutable(o_))
#define K_FLAG_OUTPUT_PORT 0x01
#define K_FLAG_INPUT_PORT 0x02
#define K_FLAG_CLOSED_PORT 0x04
-#define kport_set_input(o_) (tv_get_flags(o_) |= K_FLAG_INPUT_PORT)
-#define kport_set_output(o_) (tv_get_flags(o_) |= K_FLAG_INPUT_PORT)
-#define kport_set_closed(o_) (tv_get_flags(o_) |= K_FLAG_CLOSED_PORT)
+#define kport_set_input(o_) (tv_get_kflags(o_) |= K_FLAG_INPUT_PORT)
+#define kport_set_output(o_) (tv_get_kflags(o_) |= K_FLAG_INPUT_PORT)
+#define kport_set_closed(o_) (tv_get_kflags(o_) |= K_FLAG_CLOSED_PORT)
+
+#define kport_is_input(o_) ((tv_get_kflags(o_) & K_FLAG_INPUT_PORT) != 0)
+#define kport_is_output(o_) ((tv_get_kflags(o_) & K_FLAG_OUTPUT_PORT) != 0)
+#define kport_is_closed(o_) ((tv_get_kflags(o_) & K_FLAG_CLOSED_PORT) != 0)
+
+#define K_FLAG_WEAK_KEYS 0x01
+#define K_FLAG_WEAK_VALUES 0x02
+#define K_FLAG_WEAK_NOTHING 0x00
+
+#define ktable_has_weak_keys(o_) \
+ ((tv_get_kflags(o_) & K_FLAG_WEAK_KEYS) != 0)
+#define ktable_has_weak_values(o_) \
+ ((tv_get_kflags(o_) & K_FLAG_WEAK_VALUES) != 0)
+
-#define kport_is_input(o_) ((tv_get_flags(o_) & K_FLAG_INPUT_PORT) != 0)
-#define kport_is_output(o_) ((tv_get_flags(o_) & K_FLAG_OUTPUT_PORT) != 0)
-#define kport_is_closed(o_) ((tv_get_flags(o_) & K_FLAG_CLOSED_PORT) != 0)
/* can't be inline because we also use pointers to them,
(at least gcc doesn't bother to create them and the linker fails) */
diff --git a/src/koperative.c b/src/koperative.c
@@ -24,8 +24,6 @@ TValue kmake_operative(klisp_State *K, klisp_Ofunc fn, int32_t xcount, ...)
klispC_link(K, (GCObject *) new_op, K_TOPERATIVE, 0);
/* operative specific fields */
- new_op->name = KNIL;
- new_op->si = KNIL;
new_op->fn = fn;
new_op->extra_size = xcount;
diff --git a/src/kpair.c b/src/kpair.c
@@ -21,7 +21,6 @@ TValue kcons_g(klisp_State *K, bool m, TValue car, TValue cdr)
klispC_link(K, (GCObject *) new_pair, K_TPAIR, (m? 0 : K_FLAG_IMMUTABLE));
/* pair specific fields */
- new_pair->si = KNIL;
new_pair->mark = KFALSE;
new_pair->car = car;
new_pair->cdr = cdr;
diff --git a/src/kpair.h b/src/kpair.h
@@ -62,8 +62,9 @@ TValue klist_g(klisp_State *K, bool m, int32_t n, ...);
#define klist(K_, n_, ...) (klist_g(K_, true, n_, __VA_ARGS__))
#define kimm_list(K_, n_, ...) (klist_g(K_, false, n_, __VA_ARGS__))
-#define kget_source_info(p_) (tv2pair(p_)->si)
-#define kset_source_info(p_, si_) (kget_source_info(p_) = (si_))
+/* TODO use a source info table */
+#define kget_source_info(p_) (UNUSED(p_), KNIL)
+#define kset_source_info(K_, p_, si_) (UNUSED(K_), UNUSED(p_), UNUSED(si_))
bool kpairp(TValue obj);
diff --git a/src/kport.c b/src/kport.c
@@ -48,8 +48,6 @@ TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
writep? K_FLAG_OUTPUT_PORT : K_FLAG_INPUT_PORT);
/* port specific fields */
- new_port->name = name;
- new_port->si = si;
new_port->filename = filename;
new_port->file = file;
diff --git a/src/kpromise.c b/src/kpromise.c
@@ -20,8 +20,6 @@ TValue kmake_promise(klisp_State *K, TValue exp, TValue maybe_env)
klispC_link(K, (GCObject *) new_prom, K_TPROMISE, 0);
/* promise specific fields */
- new_prom->name = KNIL;
- new_prom->si = KNIL;
new_prom->node = KNIL; /* temp in case of GC */
krooted_tvs_push(K, gc2prom(new_prom));
new_prom->node = kcons(K, exp, maybe_env);
diff --git a/src/kread.c b/src/kread.c
@@ -4,15 +4,6 @@
** See Copyright Notice in klisp.h
*/
-
-/*
-** TODO:
-**
-** - Read mutable/immutable objects (cons function should be a parameter)
-** this is needed because some functions (like load) return immutable objs
-**
-*/
-
#include <stdio.h>
#include <stdlib.h>
#include <assert.h>
@@ -184,7 +175,7 @@ TValue kread_fsm(klisp_State *K)
** in np (later it will be replace by the source info
** of the car of the list
*/
- kset_source_info(np, ktok_get_source_info(K));
+ kset_source_info(K, np, ktok_get_source_info(K));
/* update the shared def to point to the new list */
/* NOTE: this is necessary for self referencing lists */
@@ -400,7 +391,7 @@ TValue kread_fsm(klisp_State *K)
/* GC: the way things are done here fp is rooted at all
times */
TValue fp_old_si = kget_source_info(fp);
- kset_source_info(fp, obj_si);
+ kset_source_info(K, fp, obj_si);
kset_car(fp, obj);
/* continue reading objects of list */
@@ -420,7 +411,7 @@ TValue kread_fsm(klisp_State *K)
/* GC: np is rooted by push_data */
TValue np = kcons_g(K, K->read_mconsp, obj, KNIL);
krooted_tvs_push(K, np);
- kset_source_info(np, obj_si);
+ kset_source_info(K, np, obj_si);
kset_cdr(get_data(K), np);
/* replace last pair of the (still incomplete) read next obj */
pop_data(K);
diff --git a/src/kstate.c b/src/kstate.c
@@ -17,6 +17,7 @@
#include <setjmp.h>
#include "klisp.h"
+#include "klimits.h"
#include "kstate.h"
#include "kobject.h"
#include "kstring.h"
@@ -59,8 +60,6 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K = (klisp_State *) k;
- K->symbol_table = KNIL;
- /* TODO: create a continuation */
K->curr_cont = KNIL;
K->next_obj = KINERT;
@@ -94,6 +93,7 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* GC */
K->currentwhite = bit2mask(WHITE0BIT, FIXEDBIT);
K->gcstate = GCSpause;
+ K->sweepstrgc = 0;
K->rootgc = NULL;
K->sweepgc = &(K->rootgc);
K->gray = NULL;
@@ -124,9 +124,16 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->dummy_pair3 = kcons(K, KINERT, KNIL);
/* initialize strings */
+
+ /* initial size of string/symbol table */
+ K->strt.size = 0;
+ K->strt.nuse = 0;
+ K->strt.hash = NULL;
+ klispS_resize(K, MINSTRTABSIZE);
+
/* Empty string */
- /* TODO: make it uncollectible */
- K->empty_string = kstring_new_empty(K);
+ /* MAYBE: fix it so we can remove empty_string from roots */
+ K->empty_string = kstring_new_b_imm(K, "");
/* initialize tokenizer */
@@ -161,9 +168,9 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->sbuf = (TValue *)s;
/* the dynamic ports and the keys for the dynamic ports */
- TValue in_port = kmake_std_port(K, kstring_new_ns(K, "*STDIN*"),
+ TValue in_port = kmake_std_port(K, kstring_new_b_imm(K, "*STDIN*"),
false, KNIL, KNIL, stdin);
- TValue out_port = kmake_std_port(K, kstring_new_ns(K, "*STDOUT*"),
+ TValue out_port = kmake_std_port(K, kstring_new_b_imm(K, "*STDOUT*"),
true, KNIL, KNIL, stdout);
K->kd_in_port_key = kcons(K, KTRUE, in_port);
K->kd_out_port_key = kcons(K, KTRUE, out_port);
@@ -171,7 +178,10 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* create the ground environment and the eval operative */
K->eval_op = kmake_operative(K, keval_ofn, 0);
K->list_app = kmake_applicative(K, list, 0);
- K->ground_env = kmake_empty_environment(K);
+ /* ground environment has a hashtable for bindings */
+ K->ground_env = kmake_table_environment(K, KNIL);
+
+ /* MAYBE: fix it so we can remove module_params_sym from roots */
K->module_params_sym = ksymbol_new(K, "module-parameters");
kinit_ground_env(K);
@@ -495,6 +505,12 @@ void klisp_close (klisp_State *K)
klispM_freemem(K, ks_sbuf(K), ks_ssize(K) * sizeof(TValue));
klispM_freemem(K, ks_tbuf(K), ks_tbsize(K));
+ /* there should be no pending strings */
+ klisp_assert(K->strt.nuse == 0);
+
+ /* free string/symbol table */
+ klispM_freearray(K, K->strt.hash, K->strt.size, GCObject *);
+
/* only remaining mem should be of the state struct */
klisp_assert(K->totalbytes == state_size());
diff --git a/src/kstate.h b/src/kstate.h
@@ -34,12 +34,19 @@ typedef struct {
int32_t saved_col;
} ksource_info_t;
+/* in klisp this has both the immutable strings & the symbols */
+typedef struct stringtable {
+ GCObject **hash;
+ uint32_t nuse; /* number of elements */
+ int32_t size;
+} stringtable;
+
#define GC_PROTECT_SIZE 32
/* NOTE: when adding TValues here, remember to add them to
markroot in kgc.c!! */
struct klisp_State {
- TValue symbol_table;
+ stringtable strt; /* hash table for immutable strings & symbols */
TValue curr_cont;
/*
@@ -71,6 +78,7 @@ struct klisp_State {
uint16_t currentwhite; /* the one of the two whites that is in use in
this collection cycle */
uint8_t gcstate; /* state of garbage collector */
+ int32_t sweepstrgc; /* position of sweep in `strt' */
GCObject *rootgc; /* list of all collectable objects */
GCObject **sweepgc; /* position of sweep in `rootgc' */
GCObject *gray; /* list of gray objects */
diff --git a/src/kstring.c b/src/kstring.c
@@ -4,6 +4,8 @@
** See Copyright Notice in klisp.h
*/
+/* SOURCE NOTE: the string table & hashing code is from lua */
+
#include <string.h>
#include <stdbool.h>
@@ -13,26 +15,142 @@
#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)
+/* for immutable string/symbols table */
+void klispS_resize (klisp_State *K, int32_t newsize)
+{
+ GCObject **newhash;
+ stringtable *tb;
+ int32_t i;
+ if (K->gcstate == GCSsweepstring)
+ return; /* cannot resize during GC traverse */
+ newhash = klispM_newvector(K, newsize, GCObject *);
+ tb = &K->strt;
+ for (i = 0; i < newsize; i++) newhash[i] = NULL;
+ /* rehash */
+ for (i = 0; i < tb->size; i++) {
+ GCObject *p = tb->hash[i];
+ while (p) { /* for each node in the list */
+ /* imm string & symbols aren't chained with all other
+ objs, but with each other in strt */
+ GCObject *next = p->gch.next; /* save next */
+
+ uint32_t h = 0;
+
+ if (p->gch.tt == K_TSYMBOL) {
+ h = ((Symbol *) p)->hash;
+ } else if (p->gch.tt == K_TSTRING) {
+ h = ((String *) p)->hash;
+ } else {
+ klisp_assert(0);
+ }
+
+ int32_t h1 = lmod(h, newsize); /* new position */
+ klisp_assert((int32_t) (h%newsize) == lmod(h, newsize));
+ p->gch.next = newhash[h1]; /* chain it */
+ newhash[h1] = p;
+ p = next;
+ }
+ }
+ klispM_freearray(K, tb->hash, tb->size, GCObject *);
+ tb->size = newsize;
+ tb->hash = newhash;
+}
+
+/* General constructor for strings */
+TValue kstring_new_bs_g(klisp_State *K, bool m, const char *buf,
+ uint32_t size)
{
+ return m? kstring_new_bs(K, buf, size) :
+ kstring_new_bs_imm(K, buf, size);
+}
+
+/*
+** Constructors for immutable strings
+*/
+
+/* main constructor for immutable strings */
+TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size)
+{
+ /* first check to see if it's in the stringtable */
+ GCObject *o;
+ uint32_t h = size; /* seed */
+ size_t step = (size>>5)+1; /* if string is too long, don't hash all
+ its chars */
+ size_t size1;
+ for (size1 = size; size1 >= step; size1 -= step) /* compute hash */
+ h = h ^ ((h<<5)+(h>>2)+ ((unsigned char) buf[size1-1]));
+
+ for (o = K->strt.hash[lmod(h, K->strt.size)];
+ o != NULL; o = o->gch.next) {
+ String *ts = NULL;
+ if (o->gch.tt == K_TSTRING) {
+ ts = (String *) o;
+ } else if (o->gch.tt == K_TSYMBOL) {
+ continue;
+ } else {
+ klisp_assert(0); /* only symbols and immutable strings */
+ }
+ if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
+ /* string may be dead */
+ if (isdead(K, o)) changewhite(o);
+ return gc2str(o);
+ }
+ }
+
+ /* If it exits the loop, it means it wasn't found, hash is still in h */
+ /* REFACTOR: move all of these to a new function */
String *new_str;
- new_str = klispM_malloc(K, sizeof(String) + 1);
+ if (size+1 > (SIZE_MAX - sizeof(String)))
+ klispM_toobig(K);
- /* header + gc_fields */
- klispC_link(K, (GCObject *) new_str, K_TSTRING, 0);
+ new_str = (String *) klispM_malloc(K, sizeof(String) + size + 1);
+ /* header + gc_fields */
+ /* can't use klispC_link, because strings use the next pointer
+ differently */
+ new_str->gct = klispC_white(K);
+ new_str->tt = K_TSTRING;
+ new_str->kflags = K_FLAG_IMMUTABLE;
/* string specific fields */
+ new_str->hash = h;
new_str->mark = KFALSE;
- new_str->size = 0;
- new_str->b[0] = '\0';
+ new_str->size = size;
+ if (size != 0) {
+ memcpy(new_str->b, buf, size);
+ }
+ new_str->b[size] = '\0'; /* final 0 for printing */
+
+ /* add to the string/symbol table (and link it) */
+ stringtable *tb;
+ tb = &K->strt;
+ h = lmod(h, tb->size);
+ new_str->next = tb->hash[h]; /* chain new entry */
+ tb->hash[h] = (GCObject *)(new_str);
+ tb->nuse++;
+ TValue ret_tv = gc2str(new_str);
+ if (tb->nuse > ((uint32_t) tb->size) && tb->size <= INT32_MAX / 2) {
+ krooted_tvs_push(K, ret_tv); /* save in case of gc */
+ klispS_resize(K, tb->size*2); /* too crowded */
+ krooted_tvs_pop(K);
+ }
+
+ return ret_tv;
+}
- return gc2str(new_str);
+/* with just buffer, no embedded '\0's */
+TValue kstring_new_b_imm(klisp_State *K, const char *buf)
+{
+ return (kstring_new_bs_imm(K, buf, strlen(buf)));
}
-/* TEMP: for now all strings are mutable */
-TValue kstring_new_g(klisp_State *K, uint32_t size)
+/*
+** Constructors for mutable strings
+*/
+
+/* main constructor for mutable strings */
+/* with just size */
+TValue kstring_new_s(klisp_State *K, uint32_t size)
{
String *new_str;
@@ -46,6 +164,7 @@ TValue kstring_new_g(klisp_State *K, uint32_t size)
klispC_link(K, (GCObject *) new_str, K_TSTRING, 0);
/* string specific fields */
+ new_str->hash = 0; /* unimportant for mutable strings */
new_str->mark = KFALSE;
new_str->size = size;
@@ -58,34 +177,39 @@ TValue kstring_new_g(klisp_State *K, uint32_t size)
return gc2str(new_str);
}
-TValue kstring_new(klisp_State *K, const char *buf, uint32_t size)
+/* with buffer & size */
+TValue kstring_new_bs(klisp_State *K, const char *buf, uint32_t size)
{
- TValue new_str = kstring_new_g(K, size);
+ TValue new_str = kstring_new_s(K, size);
memcpy(kstring_buf(new_str), buf, size);
return new_str;
}
-/* with no size, no embedded '\0's */
-TValue kstring_new_ns(klisp_State *K, const char *buf)
+/* with buffer but no size, no embedded '\0's */
+TValue kstring_new_b(klisp_State *K, const char *buf)
{
- return (kstring_new(K, buf, strlen(buf)));
+ return (kstring_new_bs(K, buf, strlen(buf)));
}
-TValue kstring_new_sc(klisp_State *K, uint32_t size, char fill)
+/* with size and fill char */
+TValue kstring_new_sf(klisp_State *K, uint32_t size, char fill)
{
- TValue new_str = kstring_new_g(K, size);
+ TValue new_str = kstring_new_s(K, size);
memset(kstring_buf(new_str), fill, size);
return new_str;
}
-/* both obj1 and obj2 should be strings! */
+/* both obj1 and obj2 should be strings */
bool kstring_equalp(TValue obj1, TValue obj2)
{
+ klisp_assert(ttisstring(obj1) && ttisstring(obj2));
+
String *str1 = tv2str(obj1);
String *str2 = tv2str(obj2);
if (str1->size == str2->size) {
- return (memcmp(str1->b, str2->b, str1->size) == 0);
+ return (str1->size == 0) ||
+ (memcmp(str1->b, str2->b, str1->size) == 0);
} else {
return false;
}
diff --git a/src/kstring.h b/src/kstring.h
@@ -4,6 +4,8 @@
** See Copyright Notice in klisp.h
*/
+/* SOURCE NOTE: the string table & hashing code is from lua */
+
#ifndef kstring_h
#define kstring_h
@@ -12,21 +14,68 @@
#include "kobject.h"
#include "kstate.h"
-/* TEMP: for now all strings are mutable */
+/* for immutable string table */
+void klispS_resize (klisp_State *K, int32_t newsize);
+
+/*
+** Constructors for immutable strings
+*/
+
+/* General constructor for strings */
+TValue kstring_new_bs_g(klisp_State *K, bool m, const char *buf,
+ uint32_t size);
+
+/* main immutable string constructor */
+/* with buffer & size */
+TValue kstring_new_bs_imm(klisp_State *K, const char *buf, uint32_t size);
-TValue kstring_new_empty(klisp_State *K);
-TValue kstring_new(klisp_State *K, const char *buf, uint32_t size);
-/* with no size, no embedded '\0's */
-TValue kstring_new_ns(klisp_State *K, const char *buf);
-TValue kstring_new_g(klisp_State *K, uint32_t size);
-TValue kstring_new_sc(klisp_State *K, uint32_t size, char fill);
+/* with just buffer, no embedded '\0's */
+TValue kstring_new_b_imm(klisp_State *K, const char *buf);
+/*
+** Constructors for mutable strings
+*/
+
+/* main mutable string constructor */
+/* with just size */
+TValue kstring_new_s(klisp_State *K, uint32_t size);
+/* with buffer & size */
+TValue kstring_new_bs(klisp_State *K, const char *buf, uint32_t size);
+/* with just buffer, no embedded '\0's */
+TValue kstring_new_b(klisp_State *K, const char *buf);
+/* with size & fill char */
+TValue kstring_new_sf(klisp_State *K, uint32_t size, char fill);
+
+/* macros for mutable & immutable versions of the above */
+#if 0
+#define kstring_new_s(K_, size_) \
+ kstring_new_s_g(K_, true, size_)
+#define kstring_new_bs(K_, buf_, size_) \
+ kstring_new_bs_g(K_, true, buf_, size_)
+#define kstring_new_b(K_, buf_) \
+ kstring_new_b_g(K_, true, buf_)
+#define kstring_new_sf(K_, size_, fill_) \
+ kstring_new_sf_g(K_, true, size_, fill_)
+
+#define kstring_new_s_imm(K_, size_) \
+ kstring_new_s_g(K_, false, size_)
+#define kstring_new_bs_imm(K_, buf_, size_) \
+ kstring_new_bs_g(K_, false, buf_, size_)
+#define kstring_new_b_imm(K_, buf_) \
+ kstring_new_b_g(K_, false, buf_)
+#define kstring_new_sf_imm(K_, size_, fill_) \
+ kstring_new_sf_g(K_, false, size_, fill_)
+#endif
+/* some macros to access the parts of the string */
#define kstring_buf(tv_) (tv2str(tv_)->b)
#define kstring_size(tv_) (tv2str(tv_)->size)
-#define kstring_is_empty(tv_) (kstring_size(tv_) == 0)
+#define kstring_emptyp(tv_) (kstring_size(tv_) == 0)
+#define kstring_mutablep(tv_) (kis_mutable(tv_))
+#define kstring_immutablep(tv_) (kis_immutable(tv_))
-/* both obj1 and obj2 should be strings! */
+/* both obj1 and obj2 should be strings, this compares char by char
+ but differentiates immutable from mutable strings */
bool kstring_equalp(TValue obj1, TValue obj2);
#endif
diff --git a/src/ksymbol.c b/src/ksymbol.c
@@ -18,42 +18,69 @@
TValue ksymbol_new_g(klisp_State *K, const char *buf, int32_t size,
bool identifierp)
{
- /* TODO: replace symbol list with hashtable */
/* First look for it in the symbol table */
- TValue tbl = K->symbol_table;
+ GCObject *o;
+ uint32_t h = size; /* seed */
+ size_t step = (size>>5)+1; /* if string is too long, don't hash all
+ its chars */
+ size_t size1;
+ for (size1 = size; size1 >= step; size1 -= step) /* compute hash */
+ h = h ^ ((h<<5)+(h>>2)+ ((unsigned char) buf[size1-1]));
- while (!ttisnil(tbl)) {
- TValue first = kcar(tbl);
- /* NOTE: there are no embedded '\0's in identifiers but
- they could be in other symbols */
- if (size == ksymbol_size(first) &&
- memcmp(buf, ksymbol_buf(first), size) == 0) {
- return first;
- } else
- tbl = kcdr(tbl);
- }
+ h = ~h; /* symbol hash should be different from string hash
+ otherwise symbols and their respective immutable string
+ would always fall in the same bucket */
- /* Didn't find it, alloc new string and save in symbol table */
- /* NOTE: there are no embedded '\0's in symbols */
- /* GC: root new_str */
- TValue new_str = kstring_new(K, buf, size); /* this copies the buf */
+ for (o = K->strt.hash[lmod(h, K->strt.size)];
+ o != NULL; o = o->gch.next) {
+ String *ts = NULL;
+ if (o->gch.tt == K_TSTRING) {
+ continue;
+ } else if (o->gch.tt == K_TSYMBOL) {
+ ts = tv2str(((Symbol *) o)->str);
+ } else {
+ klisp_assert(0); /* only symbols and immutable strings */
+ }
+ if (ts->size == size && (memcmp(buf, ts->b, size) == 0)) {
+ /* symbol may be dead */
+ if (isdead(K, o)) changewhite(o);
+ return gc2sym(o);
+ }
+ }
+ /* REFACTOR: move this to a new function */
+ /* Didn't find it, alloc new immutable string and save in symbol table,
+ note that the hash value remained in h */
+ TValue new_str = kstring_new_bs_imm(K, buf, size);
krooted_tvs_push(K, new_str);
Symbol *new_sym = klispM_new(K, Symbol);
krooted_tvs_pop(K);
/* header + gc_fields */
- klispC_link(K, (GCObject *) new_sym, K_TSYMBOL,
- identifierp? K_FLAG_EXT_REP : 0);
+ /* can't use klispC_link, because strings use the next pointer
+ differently */
+ new_sym->gct = klispC_white(K);
+ new_sym->tt = K_TSYMBOL;
+ new_sym->kflags = identifierp? K_FLAG_EXT_REP : 0;
/* symbol specific fields */
new_sym->mark = KFALSE;
new_sym->str = new_str;
+ new_sym->hash = h;
- TValue new_symv = gc2sym(new_sym);
- krooted_tvs_push(K, new_symv);
- K->symbol_table = kcons(K, new_symv, K->symbol_table);
- krooted_tvs_pop(K);
- return new_symv;
+ /* add to the string/symbol table (and link it) */
+ stringtable *tb;
+ tb = &K->strt;
+ h = lmod(h, tb->size);
+ new_sym->next = tb->hash[h]; /* chain new entry */
+ tb->hash[h] = (GCObject *)(new_sym);
+ tb->nuse++;
+ TValue ret_tv = gc2sym(new_sym);
+ if (tb->nuse > ((uint32_t) tb->size) && tb->size <= INT32_MAX / 2) {
+ krooted_tvs_push(K, ret_tv); /* save in case of gc */
+ klispS_resize(K, tb->size*2); /* too crowded */
+ krooted_tvs_pop(K);
+ }
+ return ret_tv;
}
/* for indentifiers */
diff --git a/src/ksymbol.h b/src/ksymbol.h
@@ -17,9 +17,10 @@
TValue ksymbol_new_i(klisp_State *K, const char *buf, int32_t size);
/* For identifiers, simplified for unknown size */
TValue ksymbol_new(klisp_State *K, const char *buf);
-/* For general strings */
+/* For general strings, copies str if not immutable */
TValue ksymbol_new_check_i(klisp_State *K, TValue str);
+#define ksymbol_str(tv_) (tv2sym(tv_)->str)
#define ksymbol_buf(tv_) (kstring_buf(tv2sym(tv_)->str))
#define ksymbol_size(tv_) (kstring_size(tv2sym(tv_)->str))
diff --git a/src/ktable.c b/src/ktable.c
@@ -0,0 +1,641 @@
+/*
+** ktable.c
+** Kernel Hashtables
+** 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.
+** In klisp arrays are indexed from 0, (while in Lua they are indexed from
+** one). So watch out for off by one errors! Andres Navarro
+** To indicate a missing entry, klisp uses 'free' instead of 'nil'.
+** 'free' is a special type that is unavailable to Kernel programs.
+*/
+
+/*
+** Implementation of tables (aka arrays, objects, or hash tables).
+** Tables keep its elements in two parts: an array part and a hash part.
+** Non-negative integer keys are all candidates to be kept in the array
+** part. The actual size of the array is the largest `n' such that at
+** least half the slots between 0 and n are in use.
+** Hash uses a mix of chained scatter table with Brent's variation.
+** A main invariant of these tables is that, if an element is not
+** in its main position (i.e. the `original' position that its hash gives
+** to it), then the colliding element is in its own main position.
+** Hence even when the load factor reaches 100%, performance remains good.
+*/
+
+#include <math.h>
+#include <string.h>
+
+#include "klisp.h"
+#include "kgc.h"
+#include "kmem.h"
+#include "kobject.h"
+#include "kstate.h"
+#include "ktable.h"
+#include "kapplicative.h"
+#include "kgeqp.h"
+#include "kstring.h"
+
+/*
+** max size of array part is 2^MAXBITS
+*/
+#define MAXBITS 26
+#define MAXASIZE (1 << MAXBITS)
+
+
+#define hashpow2(t,n) (gnode(t, lmod((n), sizenode(t))))
+
+#define hashstr(t,str) hashpow2(t, (str)->hash)
+#define hashsym(t,sym) hashpow2(t, (sym)->hash)
+#define hashboolean(t,p) hashpow2(t, p? 1 : 0)
+
+
+/*
+** for some types, it is better to avoid modulus by power of 2, as
+** they tend to have many 2 factors.
+*/
+#define hashmod(t,n) (gnode(t, ((n) % ((sizenode(t)-1)|1))))
+
+
+#define hashpointer(t,p) hashmod(t, IntPoint(p))
+
+#define dummynode (&dummynode_)
+
+static const Node dummynode_ = {
+ .i_val = KFREE_,
+ .i_key = { .nk = { .this = KFREE_, .next = NULL}}
+};
+
+
+/*
+** hash for klisp numbers
+*/
+inline static Node *hashfixint (const Table *t, int32_t n) {
+ return hashmod(t, (uint32_t) n);
+}
+
+/* XXX: this accesses the internal representation of bigints...
+ maybe it should be in kbigint.c.
+ This may also not be the best hashing for bigints, I just
+ made it up...
+*/
+static Node *hashbigint (const Table *t, Bigint *b) {
+ uint32_t n = (b->sign == 0)? 0 : 1;
+ for (uint32_t i = 0; i < b->used; i++)
+ n += b->digits[i];
+
+ return hashmod(t, n);
+}
+
+/*
+** returns the `main' position of an element in a table (that is, the index
+** of its hash value)
+*/
+static Node *mainposition (const Table *t, TValue key) {
+ switch (ttype(key)) {
+ case K_TNIL:
+ case K_TIGNORE:
+ case K_TINERT:
+ case K_TEOF:
+ case K_TFIXINT:
+ case K_TEINF: /* infinites have -1 or 1 as ivalues */
+ return hashfixint(t, ivalue(key));
+ case K_TCHAR:
+ return hashfixint(t, chvalue(key));
+ case K_TBIGINT:
+ return hashbigint(t, tv2bigint(key));
+ case K_TBOOLEAN:
+ return hashboolean(t, bvalue(key));
+ case K_TSTRING:
+ if (kstring_immutablep(key))
+ return hashstr(t, tv2str(key));
+ else /* mutable strings are eq iff they are the same object */
+ return hashpointer(t, gcvalue(key));
+ case K_TSYMBOL:
+ return hashsym(t, tv2sym(key));
+ case K_TUSER:
+ return hashpointer(t, pvalue(key));
+ case K_TAPPLICATIVE:
+ /* applicatives are eq if wrapping the same number of times the
+ same applicative, just in case make the hash of an applicative
+ the same as the hash of the operative is ultimately wraps */
+ while(ttisapplicative(key)) {
+ key = kunwrap(key);
+ }
+ /* fall through */
+ default:
+ return hashpointer(t, gcvalue(key));
+ }
+}
+
+
+/*
+** returns the index for `key' if `key' is an appropriate key to live in
+** the array part of the table, -1 otherwise.
+*/
+static int32_t arrayindex (const TValue key) {
+ return (ttisfixint(key) && ivalue(key) >= 0)? ivalue(key) : -1;
+}
+
+
+/*
+** returns the index of a `key' for table traversals. First goes all
+** elements in the array part, then elements in the hash part. The
+** beginning of a traversal is signalled by -1.
+*/
+static int32_t findindex (klisp_State *K, Table *t, TValue key)
+{
+ int32_t i;
+ if (ttisfree(key)) return -1; /* first iteration */
+ i = arrayindex(key);
+ if (0 <= i && i < t->sizearray) /* is `key' inside array part? */
+ return i; /* yes; that's the index */
+ else {
+ Node *n = mainposition(t, key);
+ do { /* check whether `key' is somewhere in the chain */
+ /* key may be dead already, but it is ok to use it in `next' */
+/* klisp: i'm not so sure about this... */
+ if (eq2p(K, key2tval(n), key) ||
+ (ttype(gkey(n)->this) == K_TDEADKEY && iscollectable(key) &&
+ gcvalue(gkey(n)->this) == gcvalue(key))) {
+ i = (int32_t) (n - gnode(t, 0)); /* key index in hash table */
+ /* hash elements are numbered after array ones */
+ return i + t->sizearray;
+ }
+ else n = gnext(n);
+ } while (n);
+ klispE_throw(K, "invalid key to next"); /* key not found */
+ return 0; /* to avoid warnings */
+ }
+}
+
+int32_t klispH_next (klisp_State *K, Table *t, TValue *key, TValue *data)
+{
+ int32_t i = findindex(K, t, *key); /* find original element */
+ for (i++; i < t->sizearray; i++) { /* try first array part */
+ if (!ttisfree(t->array[i])) { /* a non-nil value? */
+ *key = i2tv(i);
+ *data = t->array[i];
+ return 1;
+ }
+ }
+ for (i -= t->sizearray; i < sizenode(t); i++) { /* then hash part */
+ if (!ttisfree(gval(gnode(t, i)))) { /* a non-nil value? */
+ *key = key2tval(gnode(t, i));
+ *data = gval(gnode(t, i));
+ return 1;
+ }
+ }
+ return 0; /* no more elements */
+}
+
+
+/*
+** {=============================================================
+** Rehash
+** ==============================================================
+*/
+
+
+static int32_t computesizes (int32_t nums[], int32_t *narray)
+{
+ int32_t i;
+ int32_t twotoi; /* 2^i */
+ int32_t a = 0; /* number of elements smaller than 2^i */
+ int32_t na = 0; /* number of elements to go to array part */
+ int32_t n = 0; /* optimal size for array part */
+ for (i = 0, twotoi = 1; twotoi/2 < *narray; i++, twotoi *= 2) {
+ if (nums[i] > 0) {
+ a += nums[i];
+ if (a > twotoi/2) { /* more than half elements present? */
+ n = twotoi; /* optimal size (till now) */
+ na = a; /* all elements smaller than n will go to array part */
+ }
+ }
+ if (a == *narray) break; /* all elements already counted */
+ }
+ *narray = n;
+ klisp_assert(*narray/2 <= na && na <= *narray);
+ return na;
+}
+
+
+static int32_t countint (const TValue key, int32_t *nums)
+{
+ int32_t k = arrayindex(key);
+ if (0 < k && k <= MAXASIZE) { /* is `key' an appropriate array index? */
+ nums[ceillog2(k)]++; /* count as such */
+ return 1;
+ }
+ else
+ return 0;
+}
+
+
+static int32_t numusearray (const Table *t, int32_t *nums)
+{
+ int32_t lg;
+ int32_t ttlg; /* 2^lg */
+ int32_t ause = 0; /* summation of `nums' */
+ int32_t i = 1; /* count to traverse all array keys */
+ for (lg=0, ttlg=1; lg<=MAXBITS; lg++, ttlg*=2) { /* for each slice */
+ int32_t lc = 0; /* counter */
+ int32_t lim = ttlg;
+ if (lim > t->sizearray) {
+ lim = t->sizearray; /* adjust upper limit */
+ if (i > lim)
+ break; /* no more elements to count */
+ }
+ /* count elements in range (2^(lg-1), 2^lg] */
+ for (; i <= lim; i++) {
+ if (!ttisfree(t->array[i-1]))
+ lc++;
+ }
+ nums[lg] += lc;
+ ause += lc;
+ }
+ return ause;
+}
+
+
+static int32_t numusehash (const Table *t, int32_t *nums, int32_t *pnasize)
+{
+ int32_t totaluse = 0; /* total number of elements */
+ int32_t ause = 0; /* summation of `nums' */
+ int32_t i = sizenode(t);
+ while (i--) {
+ Node *n = &t->node[i];
+ if (!ttisfree(gval(n))) {
+ ause += countint(key2tval(n), nums);
+ totaluse++;
+ }
+ }
+ *pnasize += ause;
+ return totaluse;
+}
+
+
+static void setarrayvector (klisp_State *K, Table *t, int32_t size)
+{
+ int32_t i;
+ klispM_reallocvector(K, t->array, t->sizearray, size, TValue);
+ for (i=t->sizearray; i<size; i++)
+ t->array[i] = KFREE;
+ t->sizearray = size;
+}
+
+
+static void setnodevector (klisp_State *K, Table *t, int32_t size)
+{
+ int32_t lsize;
+ if (size == 0) { /* no elements to hash part? */
+ t->node = cast(Node *, dummynode); /* use common `dummynode' */
+ lsize = 0;
+ }
+ else {
+ int32_t i;
+ lsize = ceillog2(size);
+ if (lsize > MAXBITS)
+ klispE_throw(K, "table overflow");
+ size = twoto(lsize);
+ t->node = klispM_newvector(K, size, Node);
+ for (i=0; i<size; i++) {
+ Node *n = gnode(t, i);
+ gnext(n) = NULL;
+ gkey(n)->this = KFREE;
+ gval(n) = KFREE;
+ }
+ }
+ t->lsizenode = (uint8_t) (lsize);
+ t->lastfree = gnode(t, size); /* all positions are free */
+}
+
+
+static void resize (klisp_State *K, Table *t, int32_t nasize, int32_t nhsize)
+{
+ int32_t i;
+ int32_t oldasize = t->sizearray;
+ int32_t oldhsize = t->lsizenode;
+ Node *nold = t->node; /* save old hash ... */
+ if (nasize > oldasize) /* array part must grow? */
+ setarrayvector(K, t, nasize);
+ /* create new hash part with appropriate size */
+ setnodevector(K, t, nhsize);
+ if (nasize < oldasize) { /* array part must shrink? */
+ t->sizearray = nasize;
+ /* re-insert elements from vanishing slice */
+ for (i=nasize; i<oldasize; i++) {
+ if (!ttisfree(t->array[i])) {
+ TValue v = t->array[i];
+ *klispH_setfixint(K, t, i) = v;
+ checkliveness(K, v);
+ }
+ }
+ /* shrink array */
+ klispM_reallocvector(K, t->array, oldasize, nasize, TValue);
+ }
+ /* re-insert elements from hash part */
+ for (i = twoto(oldhsize) - 1; i >= 0; i--) {
+ Node *old = nold+i;
+ if (!ttisfree(gval(old))) {
+ TValue v = gval(old);
+ *klispH_set(K, t, key2tval(old)) = v;
+ checkliveness(K, v);
+ }
+ }
+ if (nold != dummynode)
+ klispM_freearray(K, nold, twoto(oldhsize), Node); /* free old array */
+}
+
+
+void klispH_resizearray (klisp_State *K, Table *t, int32_t nasize)
+{
+ int32_t nsize = (t->node == dummynode) ? 0 : sizenode(t);
+ resize(K, t, nasize, nsize);
+}
+
+
+static void rehash (klisp_State *K, Table *t, const TValue ek) {
+ int32_t nasize, na;
+ int32_t nums[MAXBITS+1]; /* nums[i] = number of keys between 2^(i-1) and 2^i */
+ int32_t i;
+ int32_t totaluse;
+ for (i=0; i<=MAXBITS; i++) nums[i] = 0; /* reset counts */
+ nasize = numusearray(t, nums); /* count keys in array part */
+ totaluse = nasize; /* all those keys are integer keys */
+ totaluse += numusehash(t, nums, &nasize); /* count keys in hash part */
+ /* count extra key */
+ nasize += countint(ek, nums);
+ totaluse++;
+ /* compute new size for array part */
+ na = computesizes(nums, &nasize);
+ /* resize the table to new computed sizes */
+ resize(K, t, nasize, totaluse - na);
+}
+
+
+
+/*
+** }=============================================================
+*/
+
+/* wflags should be either or both of K_FLAG_WEAK_KEYS or K_FLAG_WEAK VALUES */
+TValue klispH_new (klisp_State *K, int32_t narray, int32_t nhash,
+ int32_t wflags)
+{
+ klisp_assert((wflags & (K_FLAG_WEAK_KEYS | K_FLAG_WEAK_VALUES)) ==
+ wflags);
+ Table *t = klispM_new(K, Table);
+ klispC_link(K, (GCObject *) t, K_TTABLE, wflags);
+ /* temporary values (kept only if some malloc fails) */
+ t->array = NULL;
+ t->sizearray = 0;
+ t->lsizenode = 0;
+ t->node = cast(Node *, dummynode);
+ /* root in case gc is run while allocating array or nodes */
+ TValue tv_t = gc2table(t);
+ krooted_tvs_push(K, tv_t);
+
+ setarrayvector(K, t, narray);
+ setnodevector(K, t, nhash);
+ krooted_tvs_pop(K);
+ return tv_t;
+}
+
+
+void klispH_free (klisp_State *K, Table *t)
+{
+ if (t->node != dummynode)
+ klispM_freearray(K, t->node, sizenode(t), Node);
+ klispM_freearray(K, t->array, t->sizearray, TValue);
+ klispM_free(K, t);
+}
+
+
+static Node *getfreepos (Table *t)
+{
+ while (t->lastfree-- > t->node) {
+ if (ttisfree(gkey(t->lastfree)->this))
+ return t->lastfree;
+ }
+ return NULL; /* could not find a free place */
+}
+
+
+/*
+** inserts a new key into a hash table; first, check whether key's main
+** position is free. If not, check whether colliding node is in its main
+** position or not: if it is not, move colliding node to an empty place and
+** put new key in its main position; otherwise (colliding node is in its main
+** position), new key goes to an empty position.
+*/
+static TValue *newkey (klisp_State *K, Table *t, TValue key)
+{
+ Node *mp = mainposition(t, key);
+ if (!ttisfree(gval(mp)) || mp == dummynode) {
+ Node *othern;
+ Node *n = getfreepos(t); /* get a free place */
+ if (n == NULL) { /* cannot find a free place? */
+ rehash(K, t, key); /* grow table */
+ return klispH_set(K, t, key); /* re-insert key into grown table */
+ }
+ klisp_assert(n != dummynode);
+ othern = mainposition(t, key2tval(mp));
+ if (othern != mp) { /* is colliding node out of its main position? */
+ /* yes; move colliding node into free position */
+ while (gnext(othern) != mp) othern = gnext(othern); /* find previous */
+ gnext(othern) = n; /* redo the chain with `n' in place of `mp' */
+ *n = *mp; /* copy colliding node into free pos. (mp->next also goes) */
+ gnext(mp) = NULL; /* now `mp' is free */
+ gval(mp) = KFREE;
+ } else { /* colliding node is in its own main position */
+ /* new node will go into free position */
+ gnext(n) = gnext(mp); /* chain new position */
+ gnext(mp) = n;
+ mp = n;
+ }
+ }
+ gkey(mp)->this = key;
+ klispC_barriert(K, t, key);
+ klisp_assert(ttisfree(gval(mp)));
+ return &gval(mp);
+}
+
+
+/*
+** search function for integers
+*/
+const TValue *klispH_getfixint (Table *t, int32_t key)
+{
+ if (key >= 0 && key < t->sizearray)
+ return &t->array[key];
+ else {
+ Node *n = hashfixint(t, key);
+ do { /* check whether `key' is somewhere in the chain */
+ if (ttisfixint(gkey(n)->this) && ivalue(gkey(n)->this) == key)
+ return &gval(n); /* that's it */
+ else n = gnext(n);
+ } while (n);
+ return &kfree;
+ }
+}
+
+
+/*
+** search function for immutable strings
+*/
+const TValue *klispH_getstr (Table *t, String *key) {
+ klisp_assert(kstring_immutablep(gc2str(key)));
+ Node *n = hashstr(t, key);
+ do { /* check whether `key' is somewhere in the chain */
+ if (ttisstring(gkey(n)->this) && tv2str(gkey(n)->this) == key)
+ return &gval(n); /* that's it */
+ else n = gnext(n);
+ } while (n);
+ return &kfree;
+}
+
+/*
+** search function for symbol
+*/
+const TValue *klispH_getsym (Table *t, Symbol *key) {
+ Node *n = hashsym(t, key);
+ do { /* check whether `key' is somewhere in the chain */
+ if (ttissymbol(gkey(n)->this) && tv2sym(gkey(n)->this) == key)
+ return &gval(n); /* that's it */
+ else n = gnext(n);
+ } while (n);
+ return &kfree;
+}
+
+
+/*
+** main search function
+*/
+const TValue *klispH_get (Table *t, TValue key)
+{
+ switch (ttype(key)) {
+ case K_TFREE: return &kfree;
+ case K_TSYMBOL: return klispH_getsym(t, tv2sym(key));
+ case K_TFIXINT: return klispH_getfixint(t, ivalue(key));
+ case K_TSTRING:
+ if (kstring_immutablep(key))
+ return klispH_getstr(t, tv2str(key));
+ /* else fall through */
+ default: {
+ Node *n = mainposition(t, key);
+ do { /* check whether `key' is somewhere in the chain */
+ /* XXX: for some reason eq2p takes klisp_State but
+ doesn't use it */
+ if (eq2p((klisp_State *)NULL, key2tval(n), key))
+ return &gval(n); /* that's it */
+ else n = gnext(n);
+ } while (n);
+ return &kfree;
+ }
+ }
+}
+
+
+TValue *klispH_set (klisp_State *K, Table *t, TValue key)
+{
+ const TValue *p = klispH_get(t, key);
+ if (p != &kfree)
+ return cast(TValue *, p);
+ else {
+ if (ttisfree(key))
+ klispE_throw(K, "table index is free");
+/*
+ else if (ttisnumber(key) && luai_numisnan(nvalue(key)))
+ luaG_runerror(L, "table index is NaN");
+*/
+ return newkey(K, t, key);
+ }
+}
+
+
+TValue *klispH_setfixint (klisp_State *K, Table *t, int32_t key)
+{
+ const TValue *p = klispH_getfixint(t, key);
+ if (p != &kfree)
+ return cast(TValue *, p);
+ else
+ return newkey(K, t, i2tv(key));
+}
+
+
+TValue *klispH_setstr (klisp_State *K, Table *t, String *key)
+{
+ klisp_assert(kstring_immutablep(gc2str(key)));
+ const TValue *p = klispH_getstr(t, key);
+ if (p != &kfree)
+ return cast(TValue *, p);
+ else {
+ return newkey(K, t, gc2str(key));
+ }
+}
+
+
+TValue *klispH_setsym (klisp_State *K, Table *t, Symbol *key)
+{
+ const TValue *p = klispH_getsym(t, key);
+ if (p != &kfree)
+ return cast(TValue *, p);
+ else {
+ return newkey(K, t, gc2sym(key));
+ }
+}
+
+
+/* klisp: Untested, may have off by one errors, check before using */
+static int32_t unbound_search (Table *t, int32_t j) {
+ int32_t i = j; /* i -1 or a present index */
+ j++;
+ /* find `i' and `j' such that i is present and j is not */
+ while (!ttisfree(*klispH_getfixint(t, j))) {
+ i = j;
+ if (j <= (INT32_MAX - i) / 2)
+ j *= 2;
+ else { /* overflow? */
+ /* table was built with bad purposes: resort to linear search */
+ i = 0;
+ while (!ttisfree(*klispH_getfixint(t, i))) i++;
+ return i-1;
+ }
+ }
+ /* now do a binary search between them */
+ while (j - i > 1) {
+ int32_t m = (i+j)/2;
+ if (ttisfree(*klispH_getfixint(t, m))) j = m;
+ else i = m;
+ }
+ return i;
+}
+
+
+/*
+** Try to find a boundary in table `t'. A `boundary' is an integer index
+** such that t[i] is non-nil and t[i+1] is nil (and 0 if t[1] is nil).
+** klisp: in klisp that indexes are from zero, this returns -1 if t[0] is nil
+** also klisp uses free instead of nil
+*/
+int32_t klispH_getn (Table *t) {
+ int32_t j = t->sizearray - 1;
+ if (j >= 0 && ttisfree(t->array[j])) {
+ /* there is a boundary in the array part: (binary) search for it */
+ int32_t i = -1;
+ while (j - i > 1) {
+ int32_t m = (i+j)/2;
+ if (ttisfree(t->array[m])) j = m;
+ else i = m;
+ }
+ return i;
+ }
+ /* else must find a boundary in hash part */
+ else if (t->node == dummynode) /* hash part is empty? */
+ return j; /* that is easy... */
+ else return unbound_search(t, j);
+}
diff --git a/src/ktable.h b/src/ktable.h
@@ -0,0 +1,40 @@
+/*
+** ktable.h
+** Kernel Hashtables
+** 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 ktable_h
+#define ktable_h
+
+#include "kobject.h"
+#include "kstate.h"
+
+#define gnode(t,i) (&(t)->node[i])
+#define gkey(n) (&(n)->i_key.nk)
+#define gval(n) ((n)->i_val)
+#define gnext(n) ((n)->i_key.nk.next)
+
+#define key2tval(n) ((n)->i_key.tvk)
+
+const TValue *klispH_getfixint (Table *t, int32_t key);
+TValue *klispH_setfixint (klisp_State *K, Table *t, int32_t key);
+const TValue *klispH_getstr (Table *t, String *key);
+TValue *klispH_setstr (klisp_State *K, Table *t, String *key);
+const TValue *klispH_getsym (Table *t, Symbol *key);
+TValue *klispH_setsym (klisp_State *K, Table *t, Symbol *key);
+const TValue *klispH_get (Table *t, TValue key);
+TValue *klispH_set (klisp_State *K, Table *t, TValue key);
+TValue klispH_new (klisp_State *K, int32_t narray, int32_t nhash,
+ int32_t wflags);
+void klispH_resizearray (klisp_State *K, Table *t, int32_t nasize);
+void klispH_free (klisp_State *K, Table *t);
+int32_t klispH_next (klisp_State *K, Table *t, TValue *key, TValue *data);
+int32_t klispH_getn (Table *t);
+
+#endif
diff --git a/src/ktoken.c b/src/ktoken.c
@@ -188,8 +188,7 @@ TValue ktok_get_source_info(klisp_State *K)
{
/* NOTE: the filename doesn't contains embedded '\0's */
TValue filename_str =
- kstring_new(K, K->ktok_source_info.saved_filename,
- strlen(K->ktok_source_info.saved_filename));
+ kstring_new_b_imm(K, K->ktok_source_info.saved_filename);
krooted_tvs_push(K, filename_str);
/* TEMP: for now, lines and column names are fixints */
TValue res = kcons(K, i2tv(K->ktok_source_info.saved_line),
@@ -521,7 +520,10 @@ TValue ktok_read_string(klisp_State *K)
i++;
}
}
- TValue new_str = kstring_new(K, ks_tbget_buffer(K), i);
+ /* TEMP: for now strings "read" are mutable but strings "loaded" are
+ not */
+ TValue new_str = kstring_new_bs_g(K, K->read_mconsp,
+ ks_tbget_buffer(K), i);
krooted_tvs_push(K, new_str);
ks_tbclear(K); /* shouldn't cause gc, but still */
krooted_tvs_pop(K);
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -44,7 +44,7 @@ void kw_print_bigint(klisp_State *K, TValue bigint)
((kbigint_negativep(bigint))? 1 : 0);
krooted_tvs_push(K, bigint);
- TValue buf_str = kstring_new_g(K, size);
+ TValue buf_str = kstring_new_s(K, size);
krooted_tvs_push(K, buf_str);
/* write backwards so we can use printf later */
@@ -338,7 +338,7 @@ void kwrite_fsm(klisp_State *K, TValue obj)
break;
}
case K_TSTRING: {
- if (kstring_is_empty(obj)) {
+ if (kstring_emptyp(obj)) {
kw_printf(K, "\"\"");
} else {
TValue mark = kget_mark(obj);
