commit ad98ac7cc6ae1ee123e4bc2f22aa44c06520dbde
parent 86e66225c5dbeb5780f691de2a3d478f1b7d44ab
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sat, 16 Apr 2011 22:19:35 -0300
Merged gc branch. Garbage collection done (experimental)
Diffstat:
59 files changed, 2302 insertions(+), 650 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 klispconf.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
-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
+ kstring.h kinteger.h kgc.h
+kmem.o: kmem.c kmem.h klisp.h kerror.h klisp.h kstate.h kgc.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
+ 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 koperative.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,27 +8,19 @@
#include "kstate.h"
#include "kapplicative.h"
#include "kmem.h"
+#include "kgc.h"
+/* GC: Assumes underlying is rooted */
TValue kwrap(klisp_State *K, TValue underlying)
{
- return kmake_applicative(K, KNIL, KNIL, underlying);
-}
-
-TValue kmake_applicative(klisp_State *K, TValue name, TValue si,
- TValue underlying)
-{
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;
- new_app->si = si;
+ new_app->name = KNIL;
+ new_app->si = KNIL;
new_app->underlying = underlying;
return gc2app(new_app);
}
diff --git a/src/kapplicative.h b/src/kapplicative.h
@@ -9,9 +9,20 @@
#include "kobject.h"
#include "kstate.h"
+#include "koperative.h"
+/* GC: Assumes underlying is rooted */
TValue kwrap(klisp_State *K, TValue underlying);
-TValue kmake_applicative(klisp_State *K, TValue name, TValue si,
- TValue underlying);
-#define kunwrap(app_) (tv2app(app_)->underlying)
+
+/* GC: Assumes all argps are rooted */
+#define kmake_applicative(K_, ...) \
+ ({ klisp_State *K__ = (K_); \
+ TValue op = kmake_operative(K__, __VA_ARGS__); \
+ krooted_tvs_push(K__, op); \
+ TValue app = kwrap(K__, op); \
+ krooted_tvs_pop(K__); \
+ (app); })
+
+inline TValue kunwrap(TValue app) { return (tv2app(app)->underlying); }
+
#endif
diff --git a/src/kcontinuation.c b/src/kcontinuation.c
@@ -10,25 +10,23 @@
#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, ...)
+TValue kmake_continuation(klisp_State *K, TValue parent, klisp_Cfunc fn,
+ int32_t xcount, ...)
{
va_list argp;
+
Continuation *new_cont = (Continuation *)
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;
- new_cont->name = name;
- new_cont->si = si;
+ new_cont->name = KNIL;
+ new_cont->si = KNIL;
new_cont->parent = parent;
new_cont->fn = fn;
new_cont->extra_size = xcount;
@@ -38,5 +36,6 @@ TValue kmake_continuation(klisp_State *K, TValue parent, TValue name,
new_cont->extra[i] = va_arg(argp, TValue);
}
va_end(argp);
+
return gc2cont(new_cont);
}
diff --git a/src/kcontinuation.h b/src/kcontinuation.h
@@ -11,7 +11,7 @@
#include "kstate.h"
/* TODO: make some specialized constructors for 0, 1 and 2 parameters */
-TValue kmake_continuation(klisp_State *K, TValue parent, TValue name,
- TValue si, klisp_Cfunc fn, int xcount, ...);
+TValue kmake_continuation(klisp_State *K, TValue parent, klisp_Cfunc fn,
+ int xcount, ...);
#endif
diff --git a/src/kencapsulation.c b/src/kencapsulation.c
@@ -9,22 +9,19 @@
#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)
+/* GC: Assumes that key & val are rooted */
+TValue kmake_encapsulation(klisp_State *K, TValue key, TValue val)
{
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;
- new_enc->si = si;
+ new_enc->name = KNIL;
+ new_enc->si = KNIL;
new_enc->key = key;
new_enc->value = val;
diff --git a/src/kencapsulation.h b/src/kencapsulation.h
@@ -10,8 +10,9 @@
#include "kobject.h"
#include "kstate.h"
-TValue kmake_encapsulation(klisp_State *K, TValue name, TValue si,
- TValue key, TValue val);
+/* GC: Assumes that key & val are rooted */
+TValue kmake_encapsulation(klisp_State *K, TValue key, TValue val);
+
TValue kmake_encapsulation_key(klisp_State *K);
inline bool kis_encapsulation_type(TValue enc, TValue key);
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)
@@ -22,24 +23,25 @@
#define env_is_keyed(env_) (!ttisnil(env_keyed_node(env_)))
/* env_ should be keyed! */
#define env_has_key(env_, k_) (tv_equal(env_keyed_key(env_), (k_)))
-/* TEMP: for now allow only a single parent */
+
+/* GC: Assumes that parents is rooted */
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;
- new_env->parents = parents;
+ new_env->parents = parents; /* save them here */
/* TEMP: for now the bindings are an alist */
new_env->bindings = KNIL;
- /* TEMP: this could be passed in by the contructor */
+
+ /* set these here to avoid problems if gc gets called */
+ new_env->keyed_parents = KNIL;
+ new_env->keyed_node = KNIL;
+
/* Contruct the list of keyed parents */
/* MAYBE: this could be optimized to avoid repetition of parents */
TValue kparents;
@@ -49,9 +51,8 @@ TValue kmake_environment(klisp_State *K, TValue parents)
kparents = env_is_keyed(parents)? parents : env_keyed_parents(parents);
} else {
/* list of parents, for now, just append them */
- /* GC: root intermediate objs */
- TValue dummy = kcons(K, KNIL, KNIL);
- TValue tail = dummy;
+ krooted_tvs_push(K, gc2env(new_env)); /* keep the new env rooted */
+ TValue tail = kget_dummy1(K); /* keep the list rooted */
while(!ttisnil(parents)) {
TValue parent = kcar(parents);
TValue pkparents = env_keyed_parents(parent);
@@ -70,14 +71,14 @@ TValue kmake_environment(klisp_State *K, TValue parents)
}
parents = kcdr(parents);
}
- kparents = kcdr(dummy);
+ /* all alocation done */
+ kparents = kcutoff_dummy1(K);
+ krooted_tvs_pop(K);
/* if it's just one env switch from (env) to env. */
if (ttispair(kparents) && ttisnil(kcdr(kparents)))
kparents = kcar(kparents);
}
- new_env->keyed_parents = kparents;
- new_env->keyed_node = KNIL;
-
+ new_env->keyed_parents = kparents; /* overwrite with the proper value */
return gc2env(new_env);
}
@@ -104,12 +105,13 @@ TValue kfind_local_binding(klisp_State *K, TValue bindings, TValue sym)
#define kenv_parents(kst_, env_) (tv2env(env_)->parents)
#define kenv_bindings(kst_, env_) (tv2env(env_)->bindings)
+/* Assumes that env, sym & val are rooted. sym & val need not be
+ 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);
if (ttisnil(oldb)) {
- /* XXX: unrooted pair */
TValue new_pair = kcons(K, sym, val);
kenv_bindings(K, env) = kcons(K, new_pair, kenv_bindings(K, env));
} else {
@@ -118,6 +120,7 @@ void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val)
}
/* This works no matter if parents is a list or a single environment */
+/* GC: assumes env & sym are rooted */
inline bool try_get_binding(klisp_State *K, TValue env, TValue sym,
TValue *value)
{
@@ -147,6 +150,7 @@ inline bool try_get_binding(klisp_State *K, TValue env, TValue sym,
pushed += 2;
}
}
+
*value = KINERT;
return false;
}
@@ -172,14 +176,18 @@ bool kbinds(klisp_State *K, TValue env, TValue sym)
/* keyed dynamic vars */
/* MAYBE: This could be combined with the default constructor */
+/* GC: assumes parent, key & val are rooted */
TValue kmake_keyed_static_env(klisp_State *K, TValue parent, TValue key,
TValue val)
{
TValue new_env = kmake_environment(K, parent);
+ krooted_tvs_push(K, new_env); /* keep the env rooted */
env_keyed_node(new_env) = kcons(K, key, val);
+ krooted_tvs_pop(K);
return new_env;
}
+/* GC: assumes parent, key & env are rooted */
inline bool try_get_keyed(klisp_State *K, TValue env, TValue key,
TValue *value)
{
diff --git a/src/kenvironment.h b/src/kenvironment.h
@@ -10,13 +10,14 @@
#include "kobject.h"
#include "kstate.h"
-/* TEMP: for now allow only a single parent */
+/* GC: Assumes parents is rooted */
TValue kmake_environment(klisp_State *K, TValue parents);
#define kmake_empty_environment(kst_) (kmake_environment(kst_, KNIL))
void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val);
TValue kget_binding(klisp_State *K, TValue env, TValue sym);
bool kbinds(klisp_State *K, TValue env, TValue sym);
/* keyed dynamic vars */
+/* GC: Assumes parents, key & val are rooted */
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);
diff --git a/src/kerror.c b/src/kerror.c
@@ -4,10 +4,15 @@
#include <stdlib.h>
#include "klisp.h"
+#include "kpair.h"
#include "kstate.h"
#include "kmem.h"
#include "kstring.h"
+/* XXX: the msg buffers should be statically allocated and msgs
+ should be copied there, otherwise problems may occur if
+ the objects whose buffers were passed as parameters get GCted */
+
void clear_buffers(klisp_State *K)
{
/* XXX: clear stack and char buffer, clear shared dict */
@@ -15,6 +20,15 @@ void clear_buffers(klisp_State *K)
ks_sclear(K);
ks_tbclear(K);
K->shared_dict = KNIL;
+
+ /* is it okay to do this in all cases? */
+ krooted_tvs_clear(K);
+ krooted_vars_clear(K);
+
+ /* should also clear dummys right? */
+ UNUSED(kcutoff_dummy1(K));
+ UNUSED(kcutoff_dummy2(K));
+ UNUSED(kcutoff_dummy3(K));
}
void klispE_throw(klisp_State *K, char *msg)
@@ -37,7 +51,8 @@ void klispE_throw_extra(klisp_State *K, char *msg, char *extra_msg) {
char *msg_buf = klispM_malloc(K, tl);
strcpy(msg_buf, msg);
strcpy(msg_buf+l1, extra_msg);
-
+ /* 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);
diff --git a/src/keval.c b/src/keval.c
@@ -38,9 +38,9 @@ void eval_ls_cfn(klisp_State *K, TValue *xparams, TValue obj)
kapply_cc(K, combiner);
} else {
/* more arguments need to be evaluated */
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
- &eval_ls_cfn, 4, rest, env,
- tail, combiner);
+ /* GC: all objects are rooted at this point */
+ TValue new_cont = kmake_continuation(K, kget_cc(K), &eval_ls_cfn, 4,
+ rest, env, tail, combiner);
kset_cc(K, new_cont);
ktail_eval(K, kcar(rest), env);
}
@@ -55,10 +55,12 @@ inline void clear_ls_marks(TValue ls)
}
}
-/* operands should be a pair */
+/* operands should be a pair, and should be rooted (GC) */
inline TValue make_arg_ls(klisp_State *K, TValue operands, TValue *tail)
{
TValue arg_ls = kcons(K, kcar(operands), KNIL);
+ krooted_tvs_push(K, arg_ls); /* root the constructed list */
+
TValue last_pair = arg_ls;
kset_mark(operands, last_pair);
TValue rem_op = kcdr(operands);
@@ -71,6 +73,8 @@ inline TValue make_arg_ls(klisp_State *K, TValue operands, TValue *tail)
rem_op = kcdr(rem_op);
}
+ krooted_tvs_pop(K);
+
if (ttispair(rem_op)) {
/* cyclical list */
*tail = kget_mark(rem_op);
@@ -106,14 +110,17 @@ void combine_cfn(klisp_State *K, TValue *xparams, TValue obj)
/* make a copy of the operands (for storing arguments) */
TValue tail;
TValue arg_ls = make_arg_ls(K, operands, &tail);
+ krooted_tvs_push(K, arg_ls);
+ TValue comb_cont = kmake_continuation(K, kget_cc(K), &combine_cfn,
+ 2, arg_ls, env);
- TValue comb_cont = kmake_continuation(
- K, kget_cc(K), KNIL, KNIL, &combine_cfn, 2, arg_ls, env);
-
- TValue els_cont = kmake_continuation(
- K, comb_cont, KNIL, KNIL, &eval_ls_cfn,
- 4, arg_ls, env, tail, tv2app(obj)->underlying);
+ krooted_tvs_pop(K); /* already in cont */
+ krooted_tvs_push(K, comb_cont);
+ TValue els_cont =
+ kmake_continuation(K, comb_cont, &eval_ls_cfn, 4, arg_ls, env,
+ tail, tv2app(obj)->underlying);
kset_cc(K, els_cont);
+ krooted_tvs_pop(K);
ktail_eval(K, kcar(arg_ls), env);
} else {
klispE_throw(K, "Not a list in applicative combination");
@@ -131,12 +138,12 @@ void combine_cfn(klisp_State *K, TValue *xparams, TValue obj)
/* the underlying function of the eval operative */
void keval_ofn(klisp_State *K, TValue *xparams, TValue obj, TValue env)
{
- (void) xparams;
+ UNUSED(xparams);
switch(ttype(obj)) {
case K_TPAIR: {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
- &combine_cfn, 2, kcdr(obj), env);
+ TValue new_cont =
+ kmake_continuation(K, kget_cc(K), &combine_cfn, 2, kcdr(obj), env);
kset_cc(K, new_cont);
ktail_eval(K, kcar(obj), env);
break;
diff --git a/src/kgbooleans.c b/src/kgbooleans.c
@@ -42,9 +42,9 @@ void andp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
UNUSED(denv);
- int32_t dummy; /* don't care about cycle pairs */
+ /* don't care about cycle pairs */
int32_t pairs = check_typed_list(K, "and?", "boolean", kbooleanp,
- true, ptree, &dummy);
+ true, ptree, NULL);
TValue res = KTRUE;
TValue tail = ptree;
while(pairs--) {
@@ -63,9 +63,9 @@ void orp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
UNUSED(denv);
- int32_t dummy; /* don't care about cycle pairs */
+ /* don't care about cycle pairs */
int32_t pairs = check_typed_list(K, "or?", "boolean", kbooleanp,
- true, ptree, &dummy);
+ true, ptree, NULL);
TValue res = KFALSE;
TValue tail = ptree;
while(pairs--) {
@@ -119,7 +119,7 @@ void do_Sandp_Sorp(klisp_State *K, TValue *xparams, TValue obj)
/* This is the important part of tail context + bool check */
if (!ttisnil(ls) || !kis_bool_check_cont(kget_cc(K))) {
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_Sandp_Sorp,
+ kmake_continuation(K, kget_cc(K), do_Sandp_Sorp,
4, sname, term_bool, ls, denv);
/*
** Mark as a bool checking cont this is needed in the last operand
@@ -147,9 +147,10 @@ void Sandp_Sorp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue ls = check_copy_list(K, ksymbol_buf(sname), ptree, false);
/* This will work even if ls is empty */
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_Sandp_Sorp,
- 4, sname, term_bool, ls, denv);
+ krooted_tvs_push(K, ls);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_Sandp_Sorp, 4,
+ sname, term_bool, ls, denv);
+ krooted_tvs_pop(K);
/* there's no need to mark it as bool checking, no evaluation
is done in the dynamic extent of this cont */
kset_cc(K, new_cont);
diff --git a/src/kgc.c b/src/kgc.c
@@ -0,0 +1,768 @@
+/*
+** 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"
+
+/* XXX */
+#include "kwrite.h"
+/* XXX */
+
+#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)
+
+/* this one is klisp specific */
+#define markvaluearray(k, a, s) ({ \
+ TValue *array_ = (a); \
+ int32_t size_ = (s); \
+ for(int32_t i_ = 0; i_ < size_; i_++, array_++) { \
+ TValue mva_obj_ = *array_; \
+ markvalue(k, mva_obj_); \
+ }})
+
+#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;
+ K->gray = o->gch.gclist;
+ 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
+/* 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: {
+ Symbol *s = cast(Symbol *, o);
+ markvalue(K, s->mark);
+ markvalue(K, s->str);
+ return sizeof(Symbol);
+ }
+ case K_TSTRING: {
+ String *s = cast(String *, o);
+ markvalue(K, s->mark);
+ return sizeof(String) + s->size * sizeof(char);
+ }
+ case K_TENVIRONMENT: {
+ Environment *e = cast(Environment *, o);
+ markvalue(K, e->mark);
+ markvalue(K, e->parents);
+ markvalue(K, e->bindings);
+ markvalue(K, e->keyed_node);
+ markvalue(K, e->keyed_parents);
+ return sizeof(Environment);
+ }
+ 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);
+ }
+ 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 */
+
+ /* 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);
+ markvalue(K, K->next_env);
+ /* NOTE: next_x_params is protected by next_obj */
+ markvalue(K, K->eval_op);
+ markvalue(K, K->list_app);
+ markvalue(K, K->ground_env);
+ markvalue(K, K->module_params_sym);
+ markvalue(K, K->root_cont);
+ markvalue(K, K->error_cont);
+
+ markvalue(K, K->kd_in_port_key);
+ markvalue(K, K->kd_out_port_key);
+ markvalue(K, K->empty_string);
+
+ markvalue(K, K->ktok_lparen);
+ markvalue(K, K->ktok_rparen);
+ markvalue(K, K->ktok_dot);
+ markvalue(K, K->shared_dict);
+
+ /* Mark all objects in the auxiliary stack,
+ (all valid indexes are below top), all the objects in
+ the two protected areas, and the three dummy pairs */
+ markvaluearray(K, K->sbuf, K->stop);
+ markvaluearray(K, K->rooted_tvs_buf, K->rooted_tvs_top);
+ /* the area protecting variables is an array of type TValue *[] */
+ TValue **ptr = K->rooted_vars_buf;
+ for (int i = 0, top = K->rooted_vars_top; i < top; i++, ptr++) {
+ markvalue(K, **ptr);
+ }
+
+ markvalue(K, K->dummy_pair1);
+ markvalue(K, K->dummy_pair2);
+ markvalue(K, K->dummy_pair3);
+/* 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 = flags;
+ /* 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/kgcombiners.c b/src/kgcombiners.c
@@ -44,12 +44,19 @@ void Svau(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* The ptree & body are copied to avoid mutation */
vptree = check_copy_ptree(K, "$vau", vptree, vpenv);
+
+ krooted_tvs_push(K, vptree);
+
/* the body should be a list */
- int32_t dummy;
- (void)check_list(K, "$vau", true, vbody, &dummy);
+ UNUSED(check_list(K, "$vau", true, vbody, NULL));
vbody = copy_es_immutable_h(K, "$vau", vbody, false);
- TValue new_op = make_operative(K, do_vau, 4, vptree, vpenv, vbody, denv);
+ krooted_tvs_push(K, vbody);
+
+ TValue new_op = kmake_operative(K, do_vau, 4, vptree, vpenv, vbody, denv);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
kapply_cc(K, new_op);
}
@@ -68,21 +75,29 @@ void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv)
/* bindings in an operative are in a child of the static env */
TValue env = kmake_environment(K, senv);
+
+ /* protect env */
+ krooted_tvs_push(K, env);
+
/* TODO use name from operative */
match(K, "[user-operative]", env, ptree, obj);
kadd_binding(K, env, penv, denv);
+
+ /* keep env in stack in case a cont has to be constructed */
if (ttisnil(body)) {
+ krooted_tvs_pop(K);
kapply_cc(K, KINERT);
} else {
/* this is needed because seq continuation doesn't check for
nil sequence */
TValue tail = kcdr(body);
if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
do_seq, 2, tail, env);
kset_cc(K, new_cont);
}
+ krooted_tvs_pop(K);
ktail_eval(K, kcar(body), env);
}
}
@@ -118,13 +133,15 @@ void Slambda(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* The ptree & body are copied to avoid mutation */
vptree = check_copy_ptree(K, "$lambda", vptree, KIGNORE);
+ krooted_tvs_push(K, vptree);
/* the body should be a list */
- int32_t dummy;
- (void)check_list(K, "$lambda", true, vbody, &dummy);
+ UNUSED(check_list(K, "$lambda", true, vbody, NULL));
vbody = copy_es_immutable_h(K, "$lambda", vbody, false);
- TValue new_app = make_applicative(K, do_vau, 4, vptree, KIGNORE, vbody,
- denv);
+ krooted_tvs_push(K, vbody);
+
+ TValue new_app = kmake_applicative(K, do_vau, 4, vptree, KIGNORE, vbody,
+ denv);
kapply_cc(K, new_app);
}
@@ -142,7 +159,10 @@ void apply(klisp_State *K, TValue *xparams, TValue ptree,
TValue env = (get_opt_tpar(K, "apply", K_TENVIRONMENT, &maybe_env))?
maybe_env : kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
TValue expr = kcons(K, kunwrap(app), obj);
+ krooted_tvs_pop(K);
+
ktail_eval(K, expr, env);
}
@@ -229,18 +249,18 @@ void map_for_each_get_metrics(klisp_State *K, char *name, TValue lss,
/* Return two lists, isomorphic to lss: one list of cars and one list
of cdrs (replacing the value of lss) */
+
+/* GC: assumes lss is rooted, and dummy1 & 2 are free in K */
TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
int32_t apairs, int32_t cpairs)
{
TValue tail = *lss;
- TValue dummy_cars = kcons(K, KINERT, KNIL);
- TValue lp_cars = dummy_cars;
- TValue lap_cars = dummy_cars;
+ TValue lp_cars = kget_dummy1(K);
+ TValue lap_cars = lp_cars;
- TValue dummy_cdrs = kcons(K, KINERT, KNIL);
- TValue lp_cdrs = dummy_cdrs;
- TValue lap_cdrs = dummy_cdrs;
+ TValue lp_cdrs = kget_dummy2(K);
+ TValue lap_cdrs = lp_cdrs;
while(apairs != 0 || cpairs != 0) {
int32_t pairs;
@@ -284,23 +304,30 @@ TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
}
}
- *lss = kcdr(dummy_cdrs);
- return kcdr(dummy_cars);
+ *lss = kcutoff_dummy2(K);
+ return kcutoff_dummy1(K);
}
/* Transpose lss so that the result is a list of lists, each one having
metrics (app_apairs, app_cpairs). The metrics of the returned list
should be (res_apairs, res_cpairs) */
+
+/* GC: assumes lss is rooted */
TValue map_for_each_transpose(klisp_State *K, TValue lss,
int32_t app_apairs, int32_t app_cpairs,
int32_t res_apairs, int32_t res_cpairs)
{
- /* GC: root intermediate objects */
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue lp = dummy;
- TValue lap = dummy;
+ /* reserve dummy1 & 2 to get_cars_cdrs */
+ TValue lp = kget_dummy3(K);
+ TValue lap = lp;
+ TValue cars = KNIL; /* put something for GC */
TValue tail = lss;
+
+ /* GC: both cars & tail vary in each loop, to protect them we need
+ the vars stack */
+ krooted_vars_push(K, &cars);
+ krooted_vars_push(K, &tail);
/* Loop over list of lists, creating a list of cars and
a list of cdrs, accumulate the list of cars and loop
@@ -318,9 +345,7 @@ TValue map_for_each_transpose(klisp_State *K, TValue lss,
while(pairs--) {
/* accumulate cars and replace tail with cdrs */
- TValue cars =
- map_for_each_get_cars_cdrs(K, &tail, app_apairs, app_cpairs);
-
+ cars = map_for_each_get_cars_cdrs(K, &tail, app_apairs, app_cpairs);
TValue np = kcons(K, cars, KNIL);
kset_cdr(lp, np);
lp = np;
@@ -337,7 +362,9 @@ TValue map_for_each_transpose(klisp_State *K, TValue lss,
}
}
- return kcdr(dummy);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+ return kcutoff_dummy3(K);
}
/* Continuation helpers for map */
@@ -417,11 +444,15 @@ void do_map(klisp_State *K, TValue *xparams, TValue obj)
TValue first_ptree = check_copy_list(K, "map", kcar(ls), false);
ls = kcdr(ls);
n = n-1;
+ krooted_tvs_push(K, first_ptree);
/* have to unwrap the applicative to avoid extra evaluation of first */
TValue new_expr = kcons(K, kunwrap(app), first_ptree);
+ krooted_tvs_push(K, new_expr);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_map, 6, app,
+ kmake_continuation(K, kget_cc(K), do_map, 6, app,
ls, last_pair, i2tv(n), denv, KFALSE);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
kset_cc(K, new_cont);
ktail_eval(K, new_expr, denv);
}
@@ -447,15 +478,17 @@ void do_map_cycle(klisp_State *K, TValue *xparams, TValue obj)
/* this continuation will close the cycle and return the list */
TValue encycle_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_map_encycle, 2,
+ kmake_continuation(K, kget_cc(K), do_map_encycle, 2,
dummy, last_apair);
+ krooted_tvs_push(K, encycle_cont);
/* schedule the mapping of the elements of the cycle,
signal dummyp = true to avoid creating a pair for
the inert value passed to the first continuation */
TValue new_cont =
- kmake_continuation(K, encycle_cont, KNIL, KNIL, do_map, 6, app, ls,
+ kmake_continuation(K, encycle_cont, do_map, 6, app, ls,
last_apair, cpairs, denv, KTRUE);
+ krooted_tvs_pop(K);
kset_cc(K, new_cont);
/* this will be like a nop and will continue with do_map */
kapply_cc(K, KINERT);
@@ -491,20 +524,32 @@ void map(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
isn't all that great..., but what are the expectations considering
there is no prescribed order? */
+ krooted_tvs_push(K, lss);
/* This will be the list to be returned, but it will be copied
before to play a little nicer with continuations */
TValue dummy = kcons(K, KINERT, KNIL);
+ krooted_tvs_push(K, dummy);
+
TValue ret_cont = (res_cpairs == 0)?
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_map_ret, 1, dummy)
- : kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_map_cycle, 4,
+ kmake_continuation(K, kget_cc(K), do_map_ret, 1, dummy)
+ : kmake_continuation(K, kget_cc(K), do_map_cycle, 4,
app, dummy, i2tv(res_cpairs), denv);
+
+
+ krooted_tvs_push(K, ret_cont);
+
/* schedule the mapping of the elements of the acyclic part.
signal dummyp = true to avoid creating a pair for
the inert value passed to the first continuation */
TValue new_cont =
- kmake_continuation(K, ret_cont, KNIL, KNIL, do_map, 6, app, lss, dummy,
+ kmake_continuation(K, ret_cont, do_map, 6, app, lss, dummy,
i2tv(res_apairs), denv, KTRUE);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
kset_cc(K, new_cont);
/* this will be a nop, and will continue with do_map */
kapply_cc(K, KINERT);
diff --git a/src/kgcombiners.h b/src/kgcombiners.h
@@ -54,12 +54,16 @@ void map_for_each_get_metrics(
/* Return two lists, isomorphic to lss: one list of cars and one list
of cdrs (replacing the value of lss) */
+/* GC: Assumes lss is rooted, uses dummys 2 & 3 */
TValue map_for_each_get_cars_cdrs(klisp_State *K, TValue *lss,
int32_t apairs, int32_t cpairs);
/* Transpose lss so that the result is a list of lists, each one having
metrics (app_apairs, app_cpairs). The metrics of the returned list
should be (res_apairs, res_cpairs) */
+
+/* GC: Assumes lss is rooted, uses dummys 1, &
+ (through get_cars_cdrs, 2, 3) */
TValue map_for_each_transpose(klisp_State *K, TValue lss,
int32_t app_apairs, int32_t app_cpairs,
int32_t res_apairs, int32_t res_cpairs);
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -34,8 +34,7 @@ void call_cc(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
UNUSED(xparams);
bind_1tp(K, "call/cc", ptree, "combiner", ttiscombiner, comb);
- /* GC: root pairs */
- TValue expr = kcons(K, comb, kcons(K, kget_cc(K), KNIL));
+ TValue expr = klist(K, 2, comb, kget_cc(K));
ktail_eval(K, expr, denv);
}
@@ -69,8 +68,10 @@ void extend_continuation(klisp_State *K, TValue *xparams, TValue ptree,
TValue env = (get_opt_tpar(K, "apply", K_TENVIRONMENT, &maybe_env))?
maybe_env : kmake_empty_environment(K);
- TValue new_cont = kmake_continuation(K, cont, KNIL, KNIL,
+ krooted_tvs_push(K, env);
+ TValue new_cont = kmake_continuation(K, cont,
do_extended_cont, 2, app, env);
+ krooted_tvs_pop(K);
kapply_cc(K, new_cont);
}
@@ -91,6 +92,8 @@ void do_pass_value(klisp_State *K, TValue *xparams, TValue obj)
/* this unmarks root before throwing any error */
/* TODO: this isn't very clean, refactor */
+
+/* GC: assumes obj & root are rooted, dummy1 is in use */
inline TValue check_copy_single_entry(klisp_State *K, char *name,
TValue obj, TValue root)
{
@@ -116,7 +119,6 @@ inline TValue check_copy_single_entry(klisp_State *K, char *name,
return KINERT;
}
- /* GC: save intermediate pair */
/* save the operative directly, don't waste space/time
with a list, use just a pair */
return kcons(K, cont, kunwrap(app));
@@ -124,20 +126,22 @@ inline TValue check_copy_single_entry(klisp_State *K, char *name,
/* the guards are probably generated on the spot so we don't check
for immutability and copy it anyways */
+/* GC: Assumes obj is rooted */
TValue check_copy_guards(klisp_State *K, char *name, TValue obj)
{
if (ttisnil(obj)) {
return obj;
} else {
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue last_pair = dummy;
+ TValue last_pair = kget_dummy1(K);
TValue tail = obj;
while(ttispair(tail) && !kis_marked(tail)) {
/* this will clear the marks and throw an error if the structure
is incorrect */
TValue entry = check_copy_single_entry(K, name, kcar(tail), obj);
+ krooted_tvs_push(K, entry);
TValue new_pair = kcons(K, entry, KNIL);
+ krooted_tvs_pop(K);
kmark(tail);
kset_cdr(last_pair, new_pair);
last_pair = new_pair;
@@ -146,12 +150,12 @@ TValue check_copy_guards(klisp_State *K, char *name, TValue obj)
/* dont close the cycle (if there is one) */
unmark_list(K, obj);
-
+ TValue ret = kcutoff_dummy1(K);
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_extra(K, name , ": expected list");
return KINERT;
}
- return kcdr(dummy);
+ return ret;
}
}
@@ -167,31 +171,40 @@ void guard_continuation(klisp_State *K, TValue *xparams, TValue ptree,
entry_guards = check_copy_guards(K, "guard-continuation: entry guards",
entry_guards);
+ krooted_tvs_push(K, entry_guards);
+
exit_guards = check_copy_guards(K, "guard-continuation: exit guards",
exit_guards);
+ krooted_tvs_push(K, exit_guards);
- TValue outer_cont = kmake_continuation(K, cont, KNIL, KNIL, do_pass_value,
+ TValue outer_cont = kmake_continuation(K, cont, do_pass_value,
2, entry_guards, denv);
+ krooted_tvs_push(K, outer_cont);
/* mark it as an outer continuation */
kset_outer_cont(outer_cont);
- TValue inner_cont = kmake_continuation(K, outer_cont, KNIL, KNIL,
+ TValue inner_cont = kmake_continuation(K, outer_cont,
do_pass_value, 2, exit_guards, denv);
/* mark it as an outer continuation */
kset_inner_cont(inner_cont);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
kapply_cc(K, inner_cont);
}
/* 7.2.5 continuation->applicative */
-/* TODO: look out for guards and dynamic variables */
void continuation_applicative(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
{
UNUSED(xparams);
bind_1tp(K, "continuation->applicative", ptree, "continuation",
ttiscontinuation, cont);
- /* cont_app is from kstate */
- TValue app = make_applicative(K, cont_app, 1, cont);
+ /* cont_app is from kstate, it handles dynamic vars &
+ interceptions */
+ TValue app = kmake_applicative(K, cont_app, 1, cont);
kapply_cc(K, app);
}
@@ -215,8 +228,8 @@ void apply_continuation(klisp_State *K, TValue *xparams, TValue ptree,
bind_2tp(K, "apply-continuation", ptree, "continuation", ttiscontinuation,
cont, "any", anytype, obj);
- /* TODO: look out for guards and dynamic variables */
- /* should be probably handled in kcall_cont() */
+ /* kcall_cont is from kstate, it handles dynamic vars &
+ interceptions */
kcall_cont(K, cont, obj);
}
@@ -233,19 +246,27 @@ void Slet_cc(klisp_State *K, TValue *xparams, TValue ptree,
kapply_cc(K, KINERT);
} else {
TValue new_env = kmake_environment(K, denv);
+
+ /* add binding may allocate, protect env,
+ keep in stack until continuation is allocated */
+ krooted_tvs_push(K, new_env);
kadd_binding(K, new_env, sym, kget_cc(K));
/* the list of instructions is copied to avoid mutation */
/* MAYBE: copy the evaluation structure, ASK John */
TValue ls = check_copy_list(K, "$let/cc", objs, false);
+
/* this is needed because seq continuation doesn't check for
nil sequence */
TValue tail = kcdr(ls);
if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
do_seq, 2, tail, new_env);
kset_cc(K, new_cont);
}
+
+ krooted_tvs_pop(K);
+
ktail_eval(K, kcar(ls), new_env);
}
}
@@ -262,21 +283,29 @@ void guard_dynamic_extent(klisp_State *K, TValue *xparams, TValue ptree,
entry_guards = check_copy_guards(K, "guard-dynamic-extent: entry guards",
entry_guards);
+ krooted_tvs_push(K, entry_guards);
exit_guards = check_copy_guards(K, "guard-dynamic-extent: exit guards",
exit_guards);
+ krooted_tvs_push(K, exit_guards);
/* GC: root continuations */
/* The current continuation is guarded */
- TValue outer_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_pass_value,
+ TValue outer_cont = kmake_continuation(K, kget_cc(K), do_pass_value,
1, entry_guards);
kset_outer_cont(outer_cont);
- TValue inner_cont = kmake_continuation(K, outer_cont, KNIL, KNIL,
+ kset_cc(K, outer_cont); /* this implicitly roots outer_cont */
+
+ TValue inner_cont = kmake_continuation(K, outer_cont,
do_pass_value, 1, exit_guards);
kset_inner_cont(inner_cont);
/* call combiner with no operands in the dynamic extent of inner,
with the dynamic env of this call */
- kset_cc(K, inner_cont);
+ kset_cc(K, inner_cont); /* this implicitly roots inner_cont */
TValue expr = kcons(K, comb, KNIL);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
ktail_eval(K, expr, denv);
}
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -37,14 +37,14 @@ void Sif(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_3p(K, "$if", ptree, test, cons_c, alt_c);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, select_clause,
+ kmake_continuation(K, kget_cc(K), select_clause,
3, denv, cons_c, alt_c);
/*
** Mark as a bool checking cont, not necessary but avoids a continuation
** in the last evaluation in the common use of ($if ($or?/$and? ...) ...)
*/
kset_bool_check_cont(new_cont);
- klispS_set_cc(K, new_cont);
+ kset_cc(K, new_cont);
ktail_eval(K, test, denv);
}
@@ -68,7 +68,7 @@ void select_clause(klisp_State *K, TValue *xparams, TValue obj)
/* 5.1.1 $sequence */
void Ssequence(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
- (void) xparams;
+ UNUSED(xparams);
if (ttisnil(ptree)) {
kapply_cc(K, KINERT);
@@ -82,9 +82,11 @@ void Ssequence(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
allow used from $lambda, $vau, $let family, load, etc */
TValue tail = kcdr(ls);
if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
- do_seq, 2, tail, denv);
+ krooted_tvs_push(K, ls);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2,
+ tail, denv);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
}
ktail_eval(K, kcar(ls), denv);
}
@@ -104,8 +106,8 @@ void do_seq(klisp_State *K, TValue *xparams, TValue obj)
TValue denv = xparams[1];
if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
- do_seq, 2, tail, denv);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2, tail,
+ denv);
kset_cc(K, new_cont);
}
ktail_eval(K, first, denv);
@@ -121,13 +123,12 @@ void do_seq(klisp_State *K, TValue *xparams, TValue obj)
** on $sequence, cf. $let, $vau and $lambda)
** Throw errors if any of the above mentioned checks fail.
*/
+/* GC: assumes clauses is rooted, uses dummy 1 & 2 */
TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
TValue *bodies)
{
- TValue dummy_cars = kcons(K, KNIL, KNIL);
- TValue last_car_pair = dummy_cars;
- TValue dummy_cdrs = kcons(K, KNIL, KNIL);
- TValue last_cdr_pair = dummy_cdrs;
+ TValue last_car_pair = kget_dummy1(K);
+ TValue last_cdr_pair = kget_dummy2(K);
TValue tail = clauses;
int32_t count = 0;
@@ -166,22 +167,23 @@ TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
klispE_throw(K, "$cond: expected list (clauses)");
return KNIL;
} else {
-
- tail = kcdr(dummy_cdrs);
/*
check all the bodies (should be lists), and
make a copy of the list structure.
couldn't be done before because this uses
marks, count is used because it may be a cyclic list
*/
+ tail = kget_dummy2_tail(K);
while(count--) {
TValue first = kcar(tail);
+ /* this uses dummy3 */
TValue copy = check_copy_list(K, "$cond", first, false);
kset_car(tail, copy);
tail = kcdr(tail);
}
- *bodies = kcdr(dummy_cdrs);
- return kcdr(dummy_cars);
+
+ *bodies = kcutoff_dummy2(K);
+ return kcutoff_dummy1(K);
}
}
@@ -208,8 +210,8 @@ void do_cond(klisp_State *K, TValue *xparams, TValue obj)
} else {
TValue tail = kcdr(this_body);
if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
- do_seq, 2, tail, denv);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_seq, 2,
+ tail, denv);
kset_cc(K, new_cont);
}
ktail_eval(K, kcar(this_body), denv);
@@ -220,7 +222,7 @@ void do_cond(klisp_State *K, TValue *xparams, TValue obj)
kapply_cc(K, KINERT);
} else {
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_cond, 4,
+ kmake_continuation(K, kget_cc(K), do_cond, 4,
kcar(bodies), kcdr(tests), kcdr(bodies),
denv);
/*
@@ -242,7 +244,9 @@ void Scond(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue bodies;
TValue tests = split_check_cond_clauses(K, ptree, &bodies);
-
+ krooted_tvs_push(K, tests);
+ krooted_tvs_push(K, bodies);
+
TValue obj;
if (ttisnil(tests)) {
obj = KINERT;
@@ -250,7 +254,7 @@ void Scond(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* pass a dummy body and a #f to the $cond continuation to
avoid code repetition here */
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_cond, 4,
+ kmake_continuation(K, kget_cc(K), do_cond, 4,
KNIL, tests, bodies, denv);
/* there is no need to mark this continuation with bool check
because it is just a dummy, no evaluation happens in its
@@ -258,6 +262,9 @@ void Scond(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kset_cc(K, new_cont);
obj = KFALSE;
}
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
kapply_cc(K, obj);
}
@@ -286,13 +293,16 @@ void do_for_each(klisp_State *K, TValue *xparams, TValue obj)
/* XXX: no check necessary, could just use copy_list if there
was such a procedure */
TValue first_ptree = check_copy_list(K, "for-each", kcar(ls), false);
+ krooted_tvs_push(K, first_ptree);
ls = kcdr(ls);
n = n-1;
+
/* have to unwrap the applicative to avoid extra evaluation of first */
TValue new_expr = kcons(K, kunwrap(app), first_ptree);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_for_each, 4,
+ kmake_continuation(K, kget_cc(K), do_for_each, 4,
app, ls, i2tv(n), denv);
+ krooted_tvs_pop(K);
kset_cc(K, new_cont);
ktail_eval(K, new_expr, denv);
}
@@ -324,12 +334,15 @@ void for_each(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs,
res_apairs, res_cpairs);
+ krooted_tvs_push(K, lss);
+
/* schedule all elements at once, the cycle is just ignored, this
will also return #inert once done. */
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_for_each, 4, app, lss,
+ kmake_continuation(K, kget_cc(K), do_for_each, 4, app, lss,
i2tv(res_pairs), denv);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
/* this will be a nop */
kapply_cc(K, KINERT);
}
diff --git a/src/kgencapsulations.c b/src/kgencapsulations.c
@@ -62,7 +62,7 @@ void enc_wrap(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
** xparams[0]: encapsulation key
*/
TValue key = xparams[0];
- TValue enc = kmake_encapsulation(K, KNIL, KNIL, key, obj);
+ TValue enc = kmake_encapsulation(K, key, obj);
kapply_cc(K, enc);
}
@@ -95,10 +95,19 @@ void make_encapsulation_type(klisp_State *K, TValue *xparams, TValue ptree,
/* GC: root intermediate values & pairs */
TValue key = kmake_encapsulation_key(K);
- TValue e = make_applicative(K, enc_wrap, 1, key);
- TValue p = make_applicative(K, enc_typep, 1, key);
- TValue d = make_applicative(K, enc_unwrap, 1, key);
+ krooted_tvs_push(K, key);
+ TValue e = kmake_applicative(K, enc_wrap, 1, key);
+ krooted_tvs_push(K, e);
+ TValue p = kmake_applicative(K, enc_typep, 1, key);
+ krooted_tvs_push(K, p);
+ TValue d = kmake_applicative(K, enc_unwrap, 1, key);
+ krooted_tvs_push(K, d);
- TValue ls = kcons(K, e, kcons(K, p, kcons(K, d, KNIL)));
+ TValue ls = klist(K, 3, e, p, d);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
kapply_cc(K, ls);
}
diff --git a/src/kgenv_mut.c b/src/kgenv_mut.c
@@ -33,11 +33,14 @@ void SdefineB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue def_sym = xparams[0];
dptree = check_copy_ptree(K, "$define!", dptree, KIGNORE);
+
+ krooted_tvs_push(K, dptree);
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
do_match, 3, dptree, denv,
def_sym);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
ktail_eval(K, expr, denv);
}
@@ -67,11 +70,14 @@ void SsetB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_3p(K, "$set!", ptree, env_exp, raw_formals, eval_exp);
TValue formals = check_copy_ptree(K, "$set!", raw_formals, KIGNORE);
+ krooted_tvs_push(K, formals);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_set_eval_obj, 4,
+ kmake_continuation(K, kget_cc(K), do_set_eval_obj, 4,
sname, formals, eval_exp, denv);
kset_cc(K, new_cont);
+
+ krooted_tvs_pop(K);
ktail_eval(K, env_exp, denv);
}
@@ -97,7 +103,7 @@ void do_set_eval_obj(klisp_State *K, TValue *xparams, TValue obj)
TValue env = obj;
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_match, 3,
+ kmake_continuation(K, kget_cc(K), do_match, 3,
formals, env, sname);
kset_cc(K, new_cont);
ktail_eval(K, eval_exp, denv);
@@ -122,13 +128,13 @@ inline void unmark_maybe_symbol_list(klisp_State *K, TValue ls)
** Check that obj is a finite list of symbols with no duplicates and
** returns a copy of the list (cf. check_copy_ptree)
*/
+/* GC: Assumes obj is rooted, uses dummy1 */
TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj)
{
TValue tail = obj;
bool type_errorp = false;
bool repeated_errorp = false;
- TValue dummy = kcons(K, KNIL, KNIL);
- TValue last_pair = dummy;
+ TValue last_pair = kget_dummy1(K);
while(ttispair(tail) && !kis_marked(tail)) {
/* even if there is a type error continue checking the structure */
@@ -160,7 +166,7 @@ TValue check_copy_symbol_list(klisp_State *K, char *name, TValue obj)
} else if (repeated_errorp) {
klispE_throw_extra(K, name , ": repeated symbols");
}
- return kcdr(dummy);
+ return kcutoff_dummy1(K);
}
void do_import(klisp_State *K, TValue *xparams, TValue obj)
@@ -181,7 +187,7 @@ void do_import(klisp_State *K, TValue *xparams, TValue obj)
} else {
TValue env = obj;
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_match, 3,
+ kmake_continuation(K, kget_cc(K), do_match, 3,
symbols, denv, sname);
kset_cc(K, new_cont);
ktail_eval(K, kcons(K, K->list_app, symbols), env);
@@ -200,31 +206,41 @@ void SprovideB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_al1p(K, name, ptree, symbols, body);
symbols = check_copy_symbol_list(K, name, symbols);
+ krooted_tvs_push(K, symbols);
body = check_copy_list(K, name, body, false);
+ krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
/* this will copy the bindings from new_env to denv */
+ krooted_tvs_push(K, new_env);
TValue import_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_import, 3,
+ kmake_continuation(K, kget_cc(K), do_import, 3,
sname, symbols, denv);
+ kset_cc(K, import_cont); /* this implicitly roots import_cont */
/* this will ignore the last value and pass the env to the
above continuation */
TValue ret_exp_cont =
- kmake_continuation(K, import_cont, KNIL, KNIL, do_return_value,
+ kmake_continuation(K, import_cont, do_return_value,
1, new_env);
- kset_cc(K, ret_exp_cont);
+ kset_cc(K, ret_exp_cont); /* this implicitly roots ret_exp_cont */
if (ttisnil(body)) {
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
kapply_cc(K, KINERT);
} else {
/* this is needed because seq continuation doesn't check for
nil sequence */
TValue tail = kcdr(body);
if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
do_seq, 2, tail, new_env);
kset_cc(K, new_cont);
}
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
ktail_eval(K, kcar(body), new_env);
}
}
@@ -258,9 +274,11 @@ void SimportB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
of the symbol list (other operatives that could use this model to
avoid copying are $set!, $define! & $binds?) */
+ krooted_tvs_push(K, symbols);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_import, 3,
+ kmake_continuation(K, kget_cc(K), do_import, 3,
sname, symbols, denv);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
ktail_eval(K, env_expr, denv);
}
diff --git a/src/kgenv_mut.h b/src/kgenv_mut.h
@@ -50,6 +50,7 @@ inline void ptree_clear_all(klisp_State *K, TValue sym_ls)
ks_tbclear(K);
}
+/* GC: assumes env, ptree & obj are rooted */
inline void match(klisp_State *K, char *name, TValue env, TValue ptree,
TValue obj)
{
@@ -96,18 +97,14 @@ inline void match(klisp_State *K, char *name, TValue env, TValue ptree,
}
}
+/* GC: assumes ptree & penv are rooted */
inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree,
TValue penv)
{
- /*
- ** GC: ptree is rooted because it is in the stack at all times.
- ** The copied pair should be kept safe some other way
- ** the same for ptree
- */
-
/* copy is only valid if the state isn't ST_PUSH */
- /* but init anyways to avoid warning */
+ /* but init anyways for gc (and avoiding warnings) */
TValue copy = ptree;
+ krooted_vars_push(K, ©);
/*
** NIL terminated singly linked list of symbols
@@ -157,7 +154,7 @@ inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree,
kset_mark(top, top);
} else {
/* create a new pair as copy, save it in the mark */
- TValue new_pair = kdummy_imm_cons(K);
+ TValue new_pair = kimm_cons(K, KNIL, KNIL);
kset_mark(top, new_pair);
}
/* keep the old pair and continue with the car */
@@ -229,6 +226,7 @@ inline TValue check_copy_ptree(klisp_State *K, char *name, TValue ptree,
"environment parmameter");
}
ptree_clear_all(K, sym_ls);
+ krooted_vars_pop(K);
return copy;
}
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -67,7 +67,9 @@ void make_environment(klisp_State *K, TValue *xparams, TValue ptree,
/* this is the general case, copy the list but without the
cycle if there is any */
TValue parents = check_copy_env_list(K, "make-environment", ptree);
+ krooted_tvs_push(K, parents);
new_env = kmake_environment(K, parents);
+ krooted_tvs_pop(K);
kapply_cc(K, new_env);
}
}
@@ -86,13 +88,12 @@ void make_environment(klisp_State *K, TValue *xparams, TValue ptree,
** If bindings is not finite (or not a list) an error is signaled.
*/
+/* GC: assume bindings is rooted, uses dummys 1 & 2 */
TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
TValue *exprs, bool starp)
{
- TValue dummy_cars = kcons(K, KNIL, KNIL);
- TValue last_car_pair = dummy_cars;
- TValue dummy_cadrs = kcons(K, KNIL, KNIL);
- TValue last_cadr_pair = dummy_cadrs;
+ TValue last_car_pair = kget_dummy1(K);
+ TValue last_cadr_pair = kget_dummy2(K);
TValue tail = bindings;
@@ -125,23 +126,24 @@ TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
klispE_throw_extra(K, name , ": expected finite list");
return KNIL;
} else {
- *exprs = kcdr(dummy_cadrs);
TValue res;
if (starp) {
/* all bindings are consider individual ptrees in these 'let's,
replace each ptree with its copy (after checking of course) */
- tail = kcdr(dummy_cars);
+ tail = kget_dummy1_tail(K);
while(!ttisnil(tail)) {
TValue first = kcar(tail);
TValue copy = check_copy_ptree(K, name, first, KIGNORE);
kset_car(tail, copy);
tail = kcdr(tail);
}
- res = kcdr(dummy_cars);
+ res = kget_dummy1_tail(K);
} else {
/* all bindings are consider one ptree in these 'let's */
- res = check_copy_ptree(K, name, kcdr(dummy_cars), KIGNORE);
+ res = check_copy_ptree(K, name, kget_dummy1_tail(K), KIGNORE);
}
+ *exprs = kcutoff_dummy2(K);
+ UNUSED(kcutoff_dummy1(K));
return res;
}
}
@@ -181,7 +183,7 @@ void do_let(klisp_State *K, TValue *xparams, TValue obj)
nil sequence */
TValue tail = kcdr(body);
if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
do_seq, 2, tail, env);
kset_cc(K, new_cont);
}
@@ -189,10 +191,12 @@ void do_let(klisp_State *K, TValue *xparams, TValue obj)
}
} else {
TValue new_env = kmake_environment(K, env);
+ krooted_tvs_push(K, new_env);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname,
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
kcar(bindings), kcdr(bindings), kcdr(exprs),
new_env, b2tv(false), body);
+ krooted_tvs_pop(K);
kset_cc(K, new_cont);
ktail_eval(K, kcar(exprs), recp? new_env : env);
}
@@ -211,16 +215,28 @@ void Slet(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue exprs;
TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
- int32_t dummy;
- UNUSED(check_list(K, name, true, body, &dummy));
+ krooted_tvs_push(K, bptree);
+ krooted_tvs_push(K, exprs);
+
+ UNUSED(check_list(K, name, true, body, NULL));
body = copy_es_immutable_h(K, name, body, false);
+ krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
+ krooted_tvs_push(K, new_env);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname,
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
bptree, KNIL, KNIL, new_env, b2tv(false), body);
kset_cc(K, new_cont);
- ktail_eval(K, kcons(K, K->list_app, exprs), denv);
+
+ TValue expr = kcons(K, K->list_app, exprs);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ ktail_eval(K, expr, denv);
}
/* Helper for $binds? */
@@ -260,13 +276,14 @@ void Sbindsp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_al1p(K, "binds?", ptree, env_expr, symbols);
/* REFACTOR replace with single function check_copy_typed_list */
- int32_t dummy;
int32_t count = check_typed_list(K, "$binds?", "symbol", ksymbolp,
- true, symbols, &dummy);
+ true, symbols, NULL);
symbols = check_copy_list(K, "$binds?", symbols, false);
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_bindsp,
+ krooted_tvs_push(K, symbols);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), do_bindsp,
2, symbols, i2tv(count));
+ krooted_tvs_pop(K);
kset_cc(K, new_cont);
ktail_eval(K, env_expr, denv);
}
@@ -304,24 +321,39 @@ void SletS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue exprs;
TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, true);
- int32_t dummy;
- UNUSED(check_list(K, name, true, body, &dummy));
+ krooted_tvs_push(K, exprs);
+ krooted_tvs_push(K, bptree);
+ UNUSED(check_list(K, name, true, body, NULL));
body = copy_es_immutable_h(K, name, body, false);
+ krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
+ krooted_tvs_push(K, new_env);
+
if (ttisnil(bptree)) {
/* same as $let */
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname,
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
bptree, KNIL, KNIL, new_env, b2tv(false), body);
kset_cc(K, new_cont);
- ktail_eval(K, kcons(K, K->list_app, exprs), denv);
+
+ TValue expr = kcons(K, K->list_app, exprs);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ ktail_eval(K, expr, denv);
} else {
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname,
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
kcar(bptree), kcdr(bptree), kcdr(exprs),
new_env, b2tv(false), body);
kset_cc(K, new_cont);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
ktail_eval(K, kcar(exprs), denv);
}
}
@@ -338,16 +370,29 @@ void Sletrec(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue exprs;
TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
- int32_t dummy;
- UNUSED(check_list(K, name, true, body, &dummy));
+ krooted_tvs_push(K, exprs);
+ krooted_tvs_push(K, bptree);
+
+ UNUSED(check_list(K, name, true, body, NULL));
body = copy_es_immutable_h(K, name, body, false);
+ krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
+ krooted_tvs_push(K, new_env);
+
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname,
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
bptree, KNIL, KNIL, new_env, b2tv(true), body);
kset_cc(K, new_cont);
- ktail_eval(K, kcons(K, K->list_app, exprs), new_env);
+
+ TValue expr = kcons(K, K->list_app, exprs);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ ktail_eval(K, expr, new_env);
}
/* 6.7.6 $letrec* */
@@ -362,24 +407,40 @@ void SletrecS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue exprs;
TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, true);
- int32_t dummy;
- UNUSED(check_list(K, name, true, body, &dummy));
+ krooted_tvs_push(K, exprs);
+ krooted_tvs_push(K, bptree);
+ UNUSED(check_list(K, name, true, body, NULL));
body = copy_es_immutable_h(K, name, body, false);
+ krooted_tvs_push(K, body);
TValue new_env = kmake_environment(K, denv);
+ krooted_tvs_push(K, new_env);
+
if (ttisnil(bptree)) {
/* same as $letrec */
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname,
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
bptree, KNIL, KNIL, new_env, b2tv(true), body);
kset_cc(K, new_cont);
- ktail_eval(K, kcons(K, K->list_app, exprs), new_env);
+
+ TValue expr = kcons(K, K->list_app, exprs);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ ktail_eval(K, expr, new_env);
} else {
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname,
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
kcar(bptree), kcdr(bptree), kcdr(exprs),
new_env, b2tv(true), body);
kset_cc(K, new_cont);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
ktail_eval(K, kcar(exprs), new_env);
}
}
@@ -406,10 +467,13 @@ void do_let_redirect(klisp_State *K, TValue *xparams, TValue obj)
return;
}
TValue new_env = kmake_environment(K, obj);
+ krooted_tvs_push(K, new_env);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname,
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
bptree, KNIL, KNIL, new_env, b2tv(false), body);
kset_cc(K, new_cont);
+
+ krooted_tvs_pop(K);
ktail_eval(K, lexpr, denv);
}
@@ -425,15 +489,26 @@ void Slet_redirect(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue exprs;
TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
- int32_t dummy;
- UNUSED(check_list(K, name, true, body, &dummy));
+ krooted_tvs_push(K, exprs);
+ krooted_tvs_push(K, bptree);
+
+ UNUSED(check_list(K, name, true, body, NULL));
body = copy_es_immutable_h(K, name, body, false);
+ krooted_tvs_push(K, body);
TValue eexpr = kcons(K, K->list_app, exprs);
+ krooted_tvs_push(K, eexpr);
+
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let_redirect, 5, sname,
+ kmake_continuation(K, kget_cc(K), do_let_redirect, 5, sname,
bptree, eexpr, denv, body);
kset_cc(K, new_cont);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
ktail_eval(K, env_exp, denv);
}
@@ -449,18 +524,31 @@ void Slet_safe(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue exprs;
TValue bptree = split_check_let_bindings(K, name, bindings, &exprs, false);
- int32_t dummy;
- UNUSED(check_list(K, name, true, body, &dummy));
+ krooted_tvs_push(K, exprs);
+ krooted_tvs_push(K, bptree);
+
+ UNUSED(check_list(K, name, true, body, NULL));
+
body = copy_es_immutable_h(K, name, body, false);
+ krooted_tvs_push(K, body);
+
/* according to the definition of the report it should be a child
of a child of the ground environment, but since this is a fresh
environment, the semantics are the same */
TValue new_env = kmake_environment(K, K->ground_env);
+ krooted_tvs_push(K, new_env);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_let, 7, sname,
+ kmake_continuation(K, kget_cc(K), do_let, 7, sname,
bptree, KNIL, KNIL, new_env, b2tv(false), body);
kset_cc(K, new_cont);
- ktail_eval(K, kcons(K, K->list_app, exprs), denv);
+
+ TValue expr = kcons(K, K->list_app, exprs);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ ktail_eval(K, expr, denv);
}
/* 6.7.9 $remote-eval */
@@ -471,7 +559,7 @@ void Sremote_eval(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_2p(K, "$remote-eval", ptree, obj, env_exp);
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
do_remote_eval, 1, obj);
kset_cc(K, new_cont);
@@ -513,9 +601,20 @@ void Sbindings_to_environment(klisp_State *K, TValue *xparams, TValue ptree,
TValue exprs;
TValue bptree = split_check_let_bindings(K, "$bindings->environment",
ptree, &exprs, false);
+ krooted_tvs_push(K, exprs);
+ krooted_tvs_push(K, bptree);
+
TValue new_env = kmake_environment(K, KNIL);
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ krooted_tvs_push(K, new_env);
+
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
do_b_to_env, 2, bptree, new_env);
kset_cc(K, new_cont);
- ktail_eval(K, kcons(K, K->list_app, exprs), denv);
+ TValue expr = kcons(K, K->list_app, exprs);
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ ktail_eval(K, expr, denv);
}
diff --git a/src/kgeqp.c b/src/kgeqp.c
@@ -24,11 +24,10 @@
/* NOTE: this does 2 passes but could do it in one */
void eqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
- (void) denv;
- (void) xparams;
+ UNUSED(denv);
+ UNUSED(xparams);
- int32_t cpairs;
- int32_t pairs = check_list(K, "eq?", true, ptree, &cpairs);
+ int32_t pairs = check_list(K, "eq?", true, ptree, NULL);
/* In this case we can get away without comparing the
first and last element on a cycle because eq? is
diff --git a/src/kgequalp.c b/src/kgequalp.c
@@ -36,11 +36,10 @@
*/
void equalp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
- (void) denv;
- (void) xparams;
+ UNUSED(denv);
+ UNUSED(xparams);
- int32_t cpairs;
- int32_t pairs = check_list(K, "equal?", true, ptree, &cpairs);
+ int32_t pairs = check_list(K, "equal?", true, ptree, NULL);
/* In this case we can get away without comparing the
first and last element on a cycle because equal? is
@@ -76,6 +75,8 @@ void equalp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
** if the node is not the root, and (#t . n) where n is the number
** of elements in the set, if the node is the root.
** This pair also doubles as the "name" of the set in [2].
+**
+** GC: all of these assume that arguments are rooted.
*/
/* find "name" of the set of this obj, if there isn't one create it,
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -19,11 +19,11 @@
void typep(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
- (void) denv;
/*
** xparams[0]: name symbol
** xparams[1]: type tag (as by i2tv)
*/
+ UNUSED(denv);
int32_t tag = ivalue(xparams[1]);
/* check the ptree is a list while checking the predicate.
@@ -176,7 +176,6 @@ void ftyped_bpredp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kapply_cc(K, b2tv(res));
}
-/* TODO: allow NULL as argument to cpairs and avoid writing it in that case */
/* typed finite list. Structure error should be throw before type errors */
int32_t check_typed_list(klisp_State *K, char *name, char *typename,
bool (*typep)(TValue), bool allow_infp, TValue obj,
@@ -193,7 +192,10 @@ int32_t check_typed_list(klisp_State *K, char *name, char *typename,
tail = kcdr(tail);
++pairs;
}
- *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0;
+
+ if (cpairs != NULL)
+ *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0;
+
unmark_list(K, obj);
if (!ttispair(tail) && !ttisnil(tail)) {
@@ -221,7 +223,10 @@ int32_t check_list(klisp_State *K, char *name, bool allow_infp,
tail = kcdr(tail);
++pairs;
}
- *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0;
+
+ if (cpairs != NULL)
+ *cpairs = ttispair(tail)? (pairs - ivalue(kget_mark(tail))) : 0;
+
unmark_list(K, obj);
if (!ttispair(tail) && !ttisnil(tail)) {
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -219,12 +219,6 @@ inline bool get_opt_tpar(klisp_State *K, char *name, int32_t type, TValue *par)
}
-/* TODO: add name and source info */
-#define make_operative(K_, fn_, ...) \
- kmake_operative(K_, KNIL, KNIL, fn_, __VA_ARGS__)
-#define make_applicative(K_, fn_, ...) \
- kwrap(K_, kmake_operative(K_, KNIL, KNIL, fn_, __VA_ARGS__))
-
/*
** This states are useful for traversing trees, saving the state in the
** token char buffer
@@ -240,7 +234,7 @@ inline bool get_opt_tpar(klisp_State *K, char *name, int32_t type, TValue *par)
*/
inline void unmark_list(klisp_State *K, TValue obj)
{
- (void) K; /* not needed, it's here for consistency */
+ UNUSED(K); /* not needed, it's here for consistency */
while(ttispair(obj) && kis_marked(obj)) {
kunmark(obj);
obj = kcdr(obj);
@@ -277,6 +271,7 @@ int32_t check_typed_list(klisp_State *K, char *name, char *typename,
int32_t *cpairs);
/* check that obj is a list, returns the number of pairs */
+/* TODO change the return to void and add int32_t pairs obj */
int32_t check_list(klisp_State *K, char *name, bool allow_infp,
TValue obj, int32_t *cpairs);
@@ -290,7 +285,7 @@ int32_t check_list(klisp_State *K, char *name, bool allow_infp,
/* TODO: remove inline */
/* check that obj is a list and make a copy if it is not immutable or
force_copy is true */
-
+/* GC: assumes obj is rooted, use dummy3 */
inline TValue check_copy_list(klisp_State *K, char *name, TValue obj,
bool force_copy)
{
@@ -298,12 +293,10 @@ inline TValue check_copy_list(klisp_State *K, char *name, TValue obj,
return obj;
if (ttispair(obj) && kis_immutable(obj) && !force_copy) {
- int32_t dummy;
- (void)check_list(K, name, true, obj, &dummy);
+ UNUSED(check_list(K, name, true, obj, NULL));
return obj;
} else {
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue last_pair = dummy;
+ TValue last_pair = kget_dummy3(K);
TValue tail = obj;
while(ttispair(tail) && !kis_marked(tail)) {
@@ -326,16 +319,16 @@ inline TValue check_copy_list(klisp_State *K, char *name, TValue obj,
klispE_throw_extra(K, name , ": expected list");
return KINERT;
}
- return kcdr(dummy);
+ return kcutoff_dummy3(K);
}
}
/* check that obj is a list of environments and make a copy but don't keep
the cycles */
+/* GC: assume obj is rooted, uses dummy3 */
inline TValue check_copy_env_list(klisp_State *K, char *name, TValue obj)
{
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue last_pair = dummy;
+ TValue last_pair = kget_dummy3(K);
TValue tail = obj;
while(ttispair(tail) && !kis_marked(tail)) {
@@ -358,7 +351,7 @@ inline TValue check_copy_env_list(klisp_State *K, char *name, TValue obj)
klispE_throw_extra(K, name , ": expected list");
return KINERT;
}
- return kcdr(dummy);
+ return kcutoff_dummy3(K);
}
/*
@@ -399,9 +392,10 @@ void ftyped_bpredp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv);
*/
void do_return_value(klisp_State *K, TValue *xparams, TValue obj);
+/* GC: assumes parent & obj are rooted */
inline TValue make_return_value_cont(klisp_State *K, TValue parent, TValue obj)
{
- return kmake_continuation(K, parent, KNIL, KNIL, do_return_value, 1, obj);
+ return kmake_continuation(K, parent, do_return_value, 1, obj);
}
/* Some helpers for working with fixints (signed 32 bits) */
diff --git a/src/kgkd_vars.c b/src/kgkd_vars.c
@@ -95,31 +95,56 @@ void do_set_pass(klisp_State *K, TValue *xparams, TValue ptree,
/* create continuation to set the key on both normal return and
abnormal passes */
/* TODO: reuse the code for guards in kgcontinuations.c */
+
+/* GC: this assumes that key is rooted */
inline TValue make_bind_continuation(klisp_State *K, TValue key,
TValue old_flag, TValue old_value,
TValue new_flag, TValue new_value)
{
- TValue unbind_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ TValue unbind_cont = kmake_continuation(K, kget_cc(K),
do_unbind, 3, key, old_flag,
old_value);
+ krooted_tvs_push(K, unbind_cont);
/* create the guards to guarantee that the values remain consistent on
abnormal passes (in both directions) */
- TValue exit_int = kmake_operative(K, KNIL, KNIL, do_set_pass,
+ TValue exit_int = kmake_operative(K, do_set_pass,
3, key, old_flag, old_value);
- TValue entry_int = kmake_operative(K, KNIL, KNIL, do_set_pass,
- 3, key, new_flag, new_value);
+ krooted_tvs_push(K, exit_int);
TValue exit_guard = kcons(K, K->root_cont, exit_int);
+ krooted_tvs_pop(K); /* already rooted in guard */
+ krooted_tvs_push(K, exit_guard);
TValue exit_guards = kcons(K, exit_guard, KNIL);
+ krooted_tvs_pop(K); /* already rooted in guards */
+ krooted_tvs_push(K, exit_guards);
+
+ TValue entry_int = kmake_operative(K, do_set_pass,
+ 3, key, new_flag, new_value);
+ krooted_tvs_push(K, entry_int);
TValue entry_guard = kcons(K, K->root_cont, entry_int);
+ krooted_tvs_pop(K); /* already rooted in guard */
+ krooted_tvs_push(K, entry_guard);
TValue entry_guards = kcons(K, entry_guard, KNIL);
+ krooted_tvs_pop(K); /* already rooted in guards */
+ krooted_tvs_push(K, entry_guards);
+
+
+ /* NOTE: in the stack now we have the unbind cont & two guard lists */
/* this is needed for interception code */
TValue env = kmake_empty_environment(K);
- TValue outer_cont = kmake_continuation(K, unbind_cont, KNIL, KNIL,
+ krooted_tvs_push(K, env);
+ TValue outer_cont = kmake_continuation(K, unbind_cont,
do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
- TValue inner_cont = kmake_continuation(K, outer_cont, KNIL, KNIL,
+ krooted_tvs_push(K, outer_cont);
+ TValue inner_cont = kmake_continuation(K, outer_cont,
do_pass_value, 2, exit_guards, env);
kset_inner_cont(inner_cont);
+
+ /* unbind_cont & 2 guard_lists */
+ krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
+ /* env & outer_cont */
+ krooted_tvs_pop(K); krooted_tvs_pop(K);
+
return inner_cont;
}
@@ -146,9 +171,11 @@ void do_bind(klisp_State *K, TValue *xparams, TValue ptree,
normal return and abnormal passes */
TValue new_cont = make_bind_continuation(K, key, old_flag, old_value,
new_flag, new_value);
- kset_cc(K, new_cont);
+ kset_cc(K, new_cont); /* implicit rooting */
TValue env = kmake_empty_environment(K);
+ krooted_tvs_push(K, env);
TValue expr = kcons(K, comb, KNIL);
+ krooted_tvs_pop(K);
ktail_eval(K, expr, env)
}
@@ -161,9 +188,15 @@ void make_keyed_dynamic_variable(klisp_State *K, TValue *xparams,
check_0p(K, "make-keyed-dynamic-variable", ptree);
TValue key = kcons(K, KFALSE, KINERT);
- TValue a = kwrap(K, kmake_operative(K, KNIL, KNIL, do_access, 1, key));
- TValue b = kwrap(K, kmake_operative(K, KNIL, KNIL, do_bind, 1, key));
- TValue ls = kcons(K, b, kcons(K, a, KNIL));
+ krooted_tvs_push(K, key);
+ TValue a = kmake_applicative(K, do_access, 1, key);
+ krooted_tvs_push(K, a);
+ TValue b = kmake_applicative(K, do_bind, 1, key);
+ krooted_tvs_push(K, b);
+ TValue ls = klist(K, 2, b, a);
+
+ krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
+
kapply_cc(K, ls);
}
diff --git a/src/kgks_vars.c b/src/kgks_vars.c
@@ -50,7 +50,7 @@ void do_sv_bind(klisp_State *K, TValue *xparams, TValue ptree,
"environment", ttisenvironment, env);
UNUSED(denv);
TValue key = xparams[0];
- /* GC: root intermediate objs */
+ /* GC: all objs are rooted in ptree, or xparams */
TValue new_env = kmake_keyed_static_env(K, env, key, obj);
kapply_cc(K, new_env);
}
@@ -65,8 +65,14 @@ void make_keyed_static_variable(klisp_State *K, TValue *xparams,
check_0p(K, "make-keyed-static-variable", ptree);
/* the key is just a dummy pair */
TValue key = kcons(K, KINERT, KINERT);
- TValue a = kwrap(K, kmake_operative(K, KNIL, KNIL, do_sv_access, 1, key));
- TValue b = kwrap(K, kmake_operative(K, KNIL, KNIL, do_sv_bind, 1, key));
- TValue ls = kcons(K, b, kcons(K, a, KNIL));
+ krooted_tvs_push(K, key);
+ TValue a = kmake_applicative(K, do_sv_access, 1, key);
+ krooted_tvs_push(K, a);
+ TValue b = kmake_applicative(K, do_sv_bind, 1, key);
+ krooted_tvs_push(K, b);
+ TValue ls = klist(K, 2, b, a);
+
+ krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
+
kapply_cc(K, ls);
}
diff --git a/src/kgnumbers.c b/src/kgnumbers.c
@@ -47,6 +47,9 @@ bool kintegerp(TValue obj) { return ttisinteger(obj); }
/* this will come handy when there are more numeric types,
it is intended to be used in switch */
+/* MAYBE: change to return -1, 0, 1 to indicate which type is bigger, and
+ return min & max in two extra pointers passed in. Change name to
+ classify_types */
inline int32_t max_ttype(TValue obj1, TValue obj2)
{
int32_t t1 = ttype(obj1);
@@ -114,6 +117,7 @@ bool knum_gep(TValue n1, TValue n2) { return !knum_ltp(n1, n2); }
first tries fixint addition and if that fails calls knum_plus */
/* May throw an error */
+/* GC: assumes n1 & n2 rooted */
TValue knum_plus(klisp_State *K, TValue n1, TValue n2)
{
switch(max_ttype(n1, n2)) {
@@ -147,6 +151,7 @@ TValue knum_plus(klisp_State *K, TValue n1, TValue n2)
}
/* May throw an error */
+/* GC: assumes n1 & n2 rooted */
TValue knum_times(klisp_State *K, TValue n1, TValue n2)
{
switch(max_ttype(n1, n2)) {
@@ -179,6 +184,7 @@ TValue knum_times(klisp_State *K, TValue n1, TValue n2)
}
/* May throw an error */
+/* GC: assumes n1 & n2 rooted */
TValue knum_minus(klisp_State *K, TValue n1, TValue n2)
{
switch(max_ttype(n1, n2)) {
@@ -210,6 +216,7 @@ TValue knum_minus(klisp_State *K, TValue n1, TValue n2)
}
}
+/* GC: assumes n rooted */
TValue knum_abs(klisp_State *K, TValue n)
{
switch(ttype(n)) {
@@ -238,6 +245,7 @@ TValue knum_abs(klisp_State *K, TValue n)
/* unlike the kernel gcd this returns |n| for gcd(n, 0) and gcd(0, n) and
0 for gcd(0, 0) */
+/* GC: assumes n1 & n2 rooted */
TValue knum_gcd(klisp_State *K, TValue n1, TValue n2)
{
switch(max_ttype(n1, n2)) {
@@ -268,6 +276,7 @@ TValue knum_gcd(klisp_State *K, TValue n1, TValue n2)
}
/* may throw an error if one of the arguments if zero */
+/* GC: assumes n1 & n2 rooted */
TValue knum_lcm(klisp_State *K, TValue n1, TValue n2)
{
/* get this out of the way first */
@@ -313,6 +322,7 @@ void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* first the acyclic part */
TValue ares = i2tv(0);
+ krooted_vars_push(K, &ares);
TValue tail = ptree;
while(apairs--) {
@@ -324,14 +334,16 @@ void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* next the cyclic part */
- TValue cres = i2tv(0);
+ TValue cres = i2tv(0); /* push it only if needed */
if (cpairs == 0) {
/* speed things up if there is no cycle */
res = ares;
+ krooted_vars_pop(K);
} else {
bool all_zero = true;
+ krooted_vars_push(K, &cres);
while(cpairs--) {
TValue first = kcar(tail);
tail = kcdr(tail);
@@ -350,6 +362,8 @@ void kplus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
} else
cres = knegativep(cres)? KEMINF : KEPINF;
res = knum_plus(K, ares, cres);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
}
kapply_cc(K, res);
}
@@ -371,6 +385,7 @@ void ktimes(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue ares = i2tv(1);
TValue tail = ptree;
+ krooted_vars_push(K, &ares);
while(apairs--) {
TValue first = kcar(tail);
tail = kcdr(tail);
@@ -383,9 +398,11 @@ void ktimes(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
if (cpairs == 0) {
/* speed things up if there is no cycle */
res = ares;
+ krooted_vars_pop(K);
} else {
bool all_one = true;
+ krooted_vars_push(K, &cres);
while(cpairs--) {
TValue first = kcar(tail);
tail = kcdr(tail);
@@ -416,6 +433,8 @@ void ktimes(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
res = knum_times(K, ares, cres);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
}
kapply_cc(K, res);
}
@@ -447,6 +466,8 @@ void kminus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue ares = i2tv(0);
TValue tail = kcdr(ptree);
+ krooted_vars_push(K, &ares);
+
while(apairs--) {
TValue first = kcar(tail);
tail = kcdr(tail);
@@ -459,9 +480,11 @@ void kminus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
if (cpairs == 0) {
/* speed things up if there is no cycle */
res = ares;
+ krooted_vars_pop(K);
} else {
bool all_zero = true;
+ krooted_vars_push(K, &cres);
while(cpairs--) {
TValue first = kcar(tail);
tail = kcdr(tail);
@@ -478,10 +501,14 @@ void kminus(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
} else
cres = knegativep(cres)? KEMINF : KEPINF;
res = knum_plus(K, ares, cres);
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
}
/* now substract the sum of all the elements in the list to the first
value */
+ krooted_tvs_push(K, res);
res = knum_minus(K, first_val, res);
+ krooted_tvs_pop(K);
kapply_cc(K, res);
}
@@ -640,7 +667,11 @@ void kdiv_mod(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
TValue res;
if (flags & FDIV_DIV) {
if (flags & FDIV_MOD) { /* return both div and mod */
- res = kcons(K, tv_div, kcons(K, tv_mod, KNIL));
+ krooted_tvs_push(K, tv_div);
+ krooted_tvs_push(K, tv_mod);
+ res = klist(K, 2, tv_div, tv_mod);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
} else {
res = tv_div;
}
@@ -778,14 +809,15 @@ void kgcd(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
int32_t pairs = check_typed_list(K, "gcd", "number", kimp_intp, true,
ptree, &dummy);
- TValue res;
+ TValue res = i2tv(0);
+ krooted_vars_push(K, &res);
if (pairs == 0) {
res = KEPINF; /* report: (gcd) = #e+infinity */
} else {
TValue tail = ptree;
bool seen_finite_non_zero = false;
- res = i2tv(0);
+ /* res = 0 */
while(pairs--) {
TValue first = kcar(tail);
@@ -802,6 +834,7 @@ void kgcd(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
}
+ krooted_vars_pop(K);
kapply_cc(K, res);
}
@@ -816,6 +849,7 @@ void klcm(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* report: this will cover the case of (lcm) = 1 */
TValue res = i2tv(1);
+ krooted_vars_push(K, &res);
TValue tail = ptree;
while(pairs--) {
@@ -824,6 +858,8 @@ void klcm(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* This will check that neither is zero */
res = knum_lcm(K, res, first);
}
+
+ krooted_vars_pop(K);
kapply_cc(K, res);
}
diff --git a/src/kgpair_mut.c b/src/kgpair_mut.c
@@ -84,14 +84,13 @@ void copy_es(klisp_State *K, TValue *xparams,
** to keep track of which of car or cdr we were copying,
** 0 means just pushed, 1 means return from car, 2 means return from cdr
*/
+
+/* GC: assumes obj is rooted */
TValue copy_es_immutable_h(klisp_State *K, char *name, TValue obj,
bool mut_flag)
{
- /*
- ** GC: obj is rooted because it is in the stack at all times.
- ** The copied pair should be kept safe some other way
- */
TValue copy = obj;
+ krooted_vars_push(K, ©);
assert(ks_sisempty(K));
assert(ks_tbisempty(K));
@@ -140,6 +139,7 @@ TValue copy_es_immutable_h(klisp_State *K, char *name, TValue obj,
}
}
unmark_tree(K, obj);
+ krooted_vars_pop(K);
return copy;
}
@@ -243,11 +243,12 @@ inline void appendB_clear_last_pairs(klisp_State *K, TValue ls)
last pair (if not nil), return a list of objects so that the cdr of the odd
objects (1 based) should be set to the next object in the list (this will
encycle! the result if necessary) */
+
+/* GC: Assumes lss is rooted, uses dummy1 */
TValue appendB_get_lss_endpoints(klisp_State *K, TValue lss, int32_t apairs,
int32_t cpairs)
{
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue last_pair = dummy;
+ TValue last_pair = kget_dummy1(K);
TValue tail = lss;
/* this is a list of last pairs using the marks to link the pairs) */
TValue last_pairs = KNIL;
@@ -367,7 +368,7 @@ TValue appendB_get_lss_endpoints(klisp_State *K, TValue lss, int32_t apairs,
/* discard the first element (there is always one) because it
isn't necessary, the list is used to set the last pairs of
the objects to the correspoding next first pair */
- return kcddr(dummy);
+ return kcdr(kcutoff_dummy1(K));
}
/* 6.4.1 append! */
@@ -422,9 +423,8 @@ void assq(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_2p(K, "assq", ptree, obj, ls);
/* first pass, check structure */
- int32_t dummy;
int32_t pairs = check_typed_list(K, "assq", "pair", kpairp,
- true, ls, &dummy);
+ true, ls, NULL);
TValue tail = ls;
TValue res = KNIL;
while(pairs--) {
@@ -448,8 +448,7 @@ void memqp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_2p(K, "memq?", ptree, obj, ls);
/* first pass, check structure */
- int32_t dummy;
- int32_t pairs = check_list(K, "memq?", true, ls, &dummy);
+ int32_t pairs = check_list(K, "memq?", true, ls, NULL);
TValue tail = ls;
TValue res = KFALSE;
while(pairs--) {
diff --git a/src/kgpairs_lists.c b/src/kgpairs_lists.c
@@ -34,8 +34,8 @@
/* 4.6.3 cons */
void cons(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
- (void) denv;
- (void) xparams;
+ UNUSED(denv);
+ UNUSED(xparams);
bind_2p(K, "cons", ptree, car, cdr);
TValue new_pair = kcons(K, car, cdr);
@@ -48,8 +48,8 @@ void list(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
/* the underlying combiner of list return the complete ptree, the only list
checking is implicit in the applicative evaluation */
- (void) xparams;
- (void) denv;
+ UNUSED(xparams);
+ UNUSED(denv);
kapply_cc(K, ptree);
}
@@ -62,16 +62,14 @@ void listS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
the last pair, because the list of operands is fresh. Also the type
check wouldn't be necessary. This optimization technique could be
used in lots of places to avoid checks and the like. */
- (void) xparams;
- (void) denv;
+ UNUSED(xparams);
+ UNUSED(denv);
if (ttisnil(ptree)) {
klispE_throw(K, "list*: empty argument list");
return;
}
- /* GC: should root dummy */
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue last_pair = dummy;
+ TValue last_pair = kget_dummy1(K);
TValue tail = ptree;
/* First copy the list, but remembering the next to last pair */
@@ -92,7 +90,7 @@ void listS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
we need at least one pair for this to work. */
TValue next_to_last_pair = kcdr(last_pair);
kset_cdr(next_to_last_pair, kcar(last_pair));
- kapply_cc(K, kcdr(dummy));
+ kapply_cc(K, kcutoff_dummy1(K));
} else if (ttispair(tail)) { /* cyclic argument list */
klispE_throw(K, "list*: cyclic argument list");
return;
@@ -173,27 +171,26 @@ void get_list_metrics_aux(klisp_State *K, TValue obj, int32_t *p, int32_t *n,
unmark_list(K, obj);
- if (p) *p = pairs;
- if (n) *n = nils;
- if (a) *a = apairs;
- if (c) *c = cpairs;
+ if (p != NULL) *p = pairs;
+ if (n != NULL) *n = nils;
+ if (a != NULL) *a = apairs;
+ if (c != NULL) *c = cpairs;
}
/* 5.7.1 get-list-metrics */
void get_list_metrics(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
{
- (void) denv;
- (void) xparams;
+ UNUSED(xparams);
+ UNUSED(denv);
bind_1p(K, "get-list-metrics", ptree, obj);
int32_t pairs, nils, apairs, cpairs;
get_list_metrics_aux(K, obj, &pairs, &nils, &apairs, &cpairs);
- /* GC: root intermediate pairs */
- TValue res = kcons(K, i2tv(apairs), kcons(K, i2tv(cpairs), KNIL));
- res = kcons(K, i2tv(pairs), kcons(K, i2tv(nils), res));
+ TValue res = klist(K, 4, i2tv(pairs), i2tv(nils),
+ i2tv(apairs), i2tv(cpairs));
kapply_cc(K, res);
}
@@ -222,9 +219,11 @@ int32_t ksmallest_index(klisp_State *K, char *name, TValue obj,
kensure_bigint(tv_cpairs);
TValue idx = kbigint_minus(K, tk, tv_apairs);
+ krooted_tvs_push(K, idx); /* root idx if it is a bigint */
/* idx may have become a fixint */
kensure_bigint(idx);
UNUSED(kbigint_div_mod(K, idx, tv_cpairs, &idx));
+ krooted_tvs_pop(K);
/* now idx is less than cpairs so it fits in a fixint */
assert(ttisfixint(idx));
return ivalue(idx) + apairs;
@@ -238,8 +237,8 @@ void list_tail(klisp_State *K, TValue *xparams, TValue ptree,
/* ASK John: can the object be a cyclic list? the wording of the report
seems to indicate that can't be the case, but it makes sense here
(cf $encycle!) to allow cyclic lists, so that's what I do */
- (void) denv;
- (void) xparams;
+ UNUSED(xparams);
+ UNUSED(denv);
bind_2tp(K, "list-tail", ptree, "any", anytype, obj,
"integer", kintegerp, tk);
@@ -327,6 +326,8 @@ void list_ref(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* Check that ls is an acyclic list, copy it and return both the list
(as the ret value) and the last_pair. If obj is nil, *last_pair remains
unmodified (this avoids having to check ttisnil before calling this) */
+
+/* GC: Assumes obj is rooted, uses dummy1 */
TValue append_check_copy_list(klisp_State *K, char *name, TValue obj,
TValue *last_pair_ptr)
{
@@ -334,8 +335,7 @@ TValue append_check_copy_list(klisp_State *K, char *name, TValue obj,
if (ttisnil(obj))
return obj;
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue last_pair = dummy;
+ TValue last_pair = kget_dummy1(K);
TValue tail = obj;
while(ttispair(tail) && !kis_marked(tail)) {
@@ -355,7 +355,7 @@ TValue append_check_copy_list(klisp_State *K, char *name, TValue obj,
return KINERT;
}
*last_pair_ptr = last_pair;
- return kcdr(dummy);
+ return kcutoff_dummy1(K);
}
/* 6.3.3 append */
@@ -368,8 +368,8 @@ void append(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
int32_t pairs = check_list(K, "append", true, ptree, &cpairs);
int32_t apairs = pairs - cpairs;
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue last_pair = dummy;
+ /* use dummy2, append_check_copy uses dummy1 */
+ TValue last_pair = kget_dummy2(K);
TValue lss = ptree;
TValue last_apair;
@@ -417,7 +417,7 @@ void append(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
kset_cdr(last_cpair, first_cpair); /* encycle! */
}
}
- kapply_cc(K, kcdr(dummy));
+ kapply_cc(K, kcutoff_dummy2(K));
}
/* 6.3.4 list-neighbors */
@@ -426,7 +426,7 @@ void list_neighbors(klisp_State *K, TValue *xparams, TValue ptree,
{
UNUSED(xparams);
UNUSED(denv);
- /* GC: root intermediate pairs */
+
bind_1p(K, "list_neighbors", ptree, ls);
int32_t cpairs;
@@ -434,17 +434,18 @@ void list_neighbors(klisp_State *K, TValue *xparams, TValue ptree,
TValue tail = ls;
int32_t count = cpairs? pairs - cpairs : pairs - 1;
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue last_pair = dummy;
- TValue last_apair = dummy; /* set after first loop */
+ TValue last_pair = kget_dummy1(K);
+ TValue last_apair = last_pair; /* set after first loop */
bool doing_cycle = false;
while(count > 0 || !doing_cycle) {
while(count-- > 0) { /* can be -1 if ls is nil */
TValue first = kcar(tail);
tail = kcdr(tail); /* tail advances one place per iter */
- TValue new_car = kcons(K, first, kcons(K, kcar(tail), KNIL));
+ TValue new_car = klist(K, 2, first, kcar(tail));
+ krooted_tvs_push(K, new_car);
TValue new_pair = kcons(K, new_car, KNIL);
+ krooted_tvs_pop(K);
kset_cdr(last_pair, new_pair);
last_pair = new_pair;
}
@@ -463,8 +464,7 @@ void list_neighbors(klisp_State *K, TValue *xparams, TValue ptree,
/* this will loop once more */
}
}
- /* discard dummy pair to obtain the constructed list */
- kapply_cc(K, kcdr(dummy));
+ kapply_cc(K, kcutoff_dummy1(K));
}
/* Helpers for filter */
@@ -552,12 +552,16 @@ void do_filter(klisp_State *K, TValue *xparams, TValue obj)
TValue new_n = i2tv(n-1);
TValue first = kcar(ls);
TValue new_env = kmake_empty_environment(K);
+ krooted_tvs_push(K, new_env);
/* have to unwrap the applicative to avoid extra evaluation of first */
- TValue new_expr = kcons(K, kunwrap(app), kcons(K, first, KNIL));
+ TValue new_expr = klist(K, 2, kunwrap(app), first, KNIL);
+ krooted_tvs_push(K, new_expr);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_filter, 4, app,
+ kmake_continuation(K, kget_cc(K), do_filter, 4, app,
ls, last_pair, new_n);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
ktail_eval(K, new_expr, new_env);
}
}
@@ -580,16 +584,17 @@ void do_filter_cycle(klisp_State *K, TValue *xparams, TValue obj)
/* this continuation will close the cycle and return the list */
TValue encycle_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_filter_encycle, 2,
+ kmake_continuation(K, kget_cc(K), do_filter_encycle, 2,
dummy, last_apair);
-
+ krooted_tvs_push(K, encycle_cont);
/* schedule the filtering of the elements of the cycle */
/* add inert before first element to be discarded when KFALSE
is received */
TValue new_cont =
- kmake_continuation(K, encycle_cont, KNIL, KNIL, do_filter, 4, app,
+ kmake_continuation(K, encycle_cont, do_filter, 4, app,
kcons(K, KINERT, ls), last_apair, cpairs);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
/* this will be like a nop and will continue with do_filter */
kapply_cc(K, KFALSE);
}
@@ -615,17 +620,22 @@ void filter(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* This will be the list to be returned, but it will be copied
before to play a little nicer with continuations */
TValue dummy = kcons(K, KINERT, KNIL);
+ krooted_tvs_push(K, dummy);
TValue ret_cont = (cpairs == 0)?
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_ret_cdr, 1, dummy)
- : kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_filter_cycle, 3,
+ kmake_continuation(K, kget_cc(K), do_ret_cdr, 1, dummy)
+ : kmake_continuation(K, kget_cc(K), do_filter_cycle, 3,
app, dummy, i2tv(cpairs));
+
+ krooted_tvs_pop(K); /* already in cont */
+ krooted_tvs_push(K, ret_cont);
/* add inert before first element to be discarded when KFALSE
is received */
TValue new_cont =
- kmake_continuation(K, ret_cont, KNIL, KNIL, do_filter, 4, app,
+ kmake_continuation(K, ret_cont, do_filter, 4, app,
kcons(K, KINERT, ls), dummy, i2tv(pairs-cpairs));
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
/* this will be a nop, and will continue with do_filter */
kapply_cc(K, KFALSE);
}
@@ -638,9 +648,8 @@ void assoc(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_2p(K, "assoc", ptree, obj, ls);
/* first pass, check structure */
- int32_t dummy;
int32_t pairs = check_typed_list(K, "assoc", "pair", kpairp,
- true, ls, &dummy);
+ true, ls, NULL);
TValue tail = ls;
TValue res = KNIL;
while(pairs--) {
@@ -663,8 +672,7 @@ void memberp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_2p(K, "member?", ptree, obj, ls);
/* first pass, check structure */
- int32_t dummy;
- int32_t pairs = check_list(K, "member?", true, ls, &dummy);
+ int32_t pairs = check_list(K, "member?", true, ls, NULL);
TValue tail = ls;
TValue res = KFALSE;
while(pairs--) {
@@ -685,8 +693,7 @@ void finite_listp(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
UNUSED(denv);
- int32_t dummy;
- int32_t pairs = check_list(K, "finite-list?", true, ptree, &dummy);
+ int32_t pairs = check_list(K, "finite-list?", true, ptree, NULL);
TValue res = KTRUE;
TValue tail = ptree;
@@ -715,8 +722,7 @@ void countable_listp(klisp_State *K, TValue *xparams, TValue ptree,
{
UNUSED(xparams);
UNUSED(denv);
- int32_t dummy;
- int32_t pairs = check_list(K, "countable-list?", true, ptree, &dummy);
+ int32_t pairs = check_list(K, "countable-list?", true, ptree, NULL);
TValue res = KTRUE;
TValue tail = ptree;
@@ -767,11 +773,13 @@ void do_reduce_prec(klisp_State *K, TValue *xparams, TValue obj)
/* pass the first element to the do_reduce_inc continuation */
kapply_cc(K, kcar(first_pair));
} else {
- TValue expr = kcons(K, kunwrap(prec), kcons(K, kcar(ls), KNIL));
+ TValue expr = klist(K, 2, kunwrap(prec), kcar(ls));
+ krooted_tvs_push(K, expr);
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_reduce_prec,
+ kmake_continuation(K, kget_cc(K), do_reduce_prec,
5, first_pair, ls, i2tv(cpairs-1), prec, denv);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
ktail_eval(K, expr, denv);
}
}
@@ -785,7 +793,7 @@ void do_reduce_postc(klisp_State *K, TValue *xparams, TValue obj)
TValue postc = xparams[0];
TValue denv = xparams[1];
- TValue expr = kcons(K, kunwrap(postc), kcons(K, obj, KNIL));
+ TValue expr = klist(K, 2, kunwrap(postc), obj);
ktail_eval(K, expr, denv);
}
@@ -806,8 +814,8 @@ void do_reduce_combine(klisp_State *K, TValue *xparams, TValue obj)
/* obj: cyclic_res */
TValue cyclic_res = obj;
- TValue params = kcons(K, acyclic_res, kcons(K, cyclic_res, KNIL));
- TValue expr = kcons(K, kunwrap(bin), params);
+ TValue expr = klist(K, 3, kunwrap(bin), acyclic_res,
+ cyclic_res);
ktail_eval(K, expr, denv);
}
@@ -840,31 +848,33 @@ void do_reduce_cycle(klisp_State *K, TValue *xparams, TValue obj)
if (has_acyclic_partp) {
TValue acyclic_obj = obj;
TValue combine_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_reduce_combine,
+ kmake_continuation(K, kget_cc(K), do_reduce_combine,
3, acyclic_obj, bin, denv);
- kset_cc(K, combine_cont);
+ kset_cc(K, combine_cont); /* implitly rooted */
} /* if there is no acyclic part, just let the result pass through */
TValue post_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_reduce_postc,
+ kmake_continuation(K, kget_cc(K), do_reduce_postc,
2, postc, denv);
- kset_cc(K, post_cont);
+ kset_cc(K, post_cont); /* implitly rooted */
/* pass one less so that pre_cont can pass the first argument
to the continuation */
TValue in_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_reduce,
+ kmake_continuation(K, kget_cc(K), do_reduce,
4, kcdr(ls), i2tv(cpairs - 1), inc, denv);
kset_cc(K, in_cont);
/* add dummy to allow passing inert to pre_cont */
TValue dummy = kcons(K, KINERT, ls);
+ krooted_tvs_push(K, dummy);
/* pass ls as the first pair to be passed to the do_reduce
continuation */
TValue pre_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_reduce_prec,
+ kmake_continuation(K, kget_cc(K), do_reduce_prec,
5, ls, dummy, i2tv(cpairs), prec, denv);
kset_cc(K, pre_cont);
+ krooted_tvs_pop(K);
/* this will overwrite dummy, but that's ok */
kapply_cc(K, KINERT);
}
@@ -890,21 +900,27 @@ void do_reduce(klisp_State *K, TValue *xparams, TValue obj)
this will help with error signaling and backtraces */
kapply_cc(K, obj);
} else {
- /* GC: root intermediate objs */
TValue next = kcar(ls);
- TValue params = kcons(K, obj, kcons(K, next, KNIL));
- TValue expr = kcons(K, kunwrap(bin), params);
-
+ TValue expr = klist(K, 3, kunwrap(bin), obj, next);
+ krooted_tvs_push(K, expr);
+
TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_reduce, 4,
+ kmake_continuation(K, kget_cc(K), do_reduce, 4,
kcdr(ls), i2tv(pairs-1), bin, denv);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
/* use the dynamic environment of the call to reduce */
ktail_eval(K, expr, denv);
}
}
/* 6.3.10 reduce */
+/* ASK John: There should probably be a clarification to reduce comparing
+ with fold like in Haskell, r6rs and srfi-1 (all of which have the
+ mentioned in the report, left/right distintion).
+ srfi-1 also defines reduce-left/reduce-right that work as in
+ kernel. The difference is the use or not of the id value if the list
+ is not null */
void reduce(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
{
UNUSED(xparams);
@@ -958,7 +974,7 @@ void reduce(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* make cycle reducing cont */
TValue cyc_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_reduce_cycle, 8,
+ kmake_continuation(K, kget_cc(K), do_reduce_cycle, 8,
first_cycle_pair, i2tv(cpairs), bin, prec,
inc, postc, denv, b2tv(apairs != 0));
kset_cc(K, cyc_cont);
@@ -974,7 +990,7 @@ void reduce(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
and not a regular pair to allow the above case of
a one element list to signal no acyclic part */
TValue acyc_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_reduce, 4,
+ kmake_continuation(K, kget_cc(K), do_reduce, 4,
kcdr(ls), i2tv(apairs-1), bin, denv);
kset_cc(K, acyc_cont);
res = kcar(ls);
diff --git a/src/kgports.c b/src/kgports.c
@@ -65,15 +65,21 @@ void with_file(klisp_State *K, TValue *xparams, TValue ptree,
bind_2tp(K, name, ptree, "string", ttisstring, filename,
"combiner", ttiscombiner, comb);
- /* gc: root intermediate values */
- TValue new_port = kmake_port(K, filename, writep, KNIL, KNIL);
+ TValue new_port = kmake_port(K, filename, writep);
+ krooted_tvs_push(K, new_port);
/* make the continuation to close the file before returning */
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
do_close_file_ret, 1, new_port);
- kset_cc(K, new_cont);
+ kset_cc(K, new_cont); /* cont implicitly rooted */
+ krooted_tvs_pop(K); /* new_port is in cont */
+
+ TValue op = kmake_operative(K, do_bind, 1, key);
+ krooted_tvs_push(K, op);
+
+ TValue args = klist(K, 2, new_port, comb);
+
+ krooted_tvs_pop(K);
- TValue op = kmake_operative(K, KNIL, KNIL, do_bind, 1, key);
- TValue args = kcons(K, new_port, kcons(K, comb, KNIL));
/* even if we call with denv, do_bind calls comb in an empty env */
ktail_call(K, op, args, denv);
}
@@ -107,7 +113,7 @@ void open_file(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_1tp(K, name, ptree, "string", ttisstring, filename);
- TValue new_port = kmake_port(K, filename, writep, KNIL, KNIL);
+ TValue new_port = kmake_port(K, filename, writep);
kapply_cc(K, new_port);
}
@@ -350,21 +356,25 @@ void call_with_file(klisp_State *K, TValue *xparams, TValue ptree,
bind_2tp(K, name, ptree, "string", ttisstring, filename,
"combiner", ttiscombiner, comb);
- /* gc: root intermediate values */
- TValue empty_env = kmake_empty_environment(K);
- TValue new_port = kmake_port(K, filename, writep, KNIL, KNIL);
- TValue expr = kcons(K, comb, kcons(K, new_port, KNIL));
-
+ TValue new_port = kmake_port(K, filename, writep);
+ krooted_tvs_push(K, new_port);
/* make the continuation to close the file before returning */
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
do_close_file_ret, 1, new_port);
- kset_cc(K, new_cont);
+ kset_cc(K, new_cont); /* implicit rooting */
+ krooted_tvs_pop(K); /* new_port is in new_cont */
+ TValue empty_env = kmake_empty_environment(K);
+ krooted_tvs_push(K, empty_env);
+ TValue expr = klist(K, 2, comb, new_port);
+
+ krooted_tvs_pop(K);
ktail_eval(K, expr, empty_env);
}
/* helpers for load */
/* read all expressions in a file, as immutable pairs */
+/* GC: assume port is rooted */
TValue read_all_expr(klisp_State *K, TValue port)
{
/* TEMP: for now set this by hand */
@@ -373,14 +383,15 @@ TValue read_all_expr(klisp_State *K, TValue port)
K->read_mconsp = false; /* read immutable pairs */
/* GC: root dummy and obj */
- TValue dummy = kimm_cons(K, KNIL, KNIL);
- TValue tail = dummy;
+ TValue tail = kget_dummy1(K);
TValue obj = KINERT;
+ krooted_vars_push(K, &obj);
while(true) {
obj = kread(K);
if (ttiseof(obj)) {
- return kcdr(dummy);
+ krooted_vars_pop(K);
+ return kcutoff_dummy1(K);
} else {
TValue new_pair = kimm_cons(K, obj, KNIL);
kset_cdr(tail, new_pair);
@@ -410,22 +421,34 @@ void do_int_close_file(klisp_State *K, TValue *xparams, TValue ptree,
/*
** guarded continuation making for read seq
*/
+
+/* GC: assumes parent & port are rooted */
TValue make_guarded_read_cont(klisp_State *K, TValue parent, TValue port)
{
/* create the guard to close file after read errors */
- TValue exit_int = kmake_operative(K, KNIL, KNIL, do_int_close_file,
+ TValue exit_int = kmake_operative(K, do_int_close_file,
1, port);
+ krooted_tvs_push(K, exit_int);
TValue exit_guard = kcons(K, K->error_cont, exit_int);
+ krooted_tvs_pop(K); /* alread in guard */
+ krooted_tvs_push(K, exit_guard);
TValue exit_guards = kcons(K, exit_guard, KNIL);
+ krooted_tvs_pop(K); /* alread in guards */
+ krooted_tvs_push(K, exit_guards);
+
TValue entry_guards = KNIL;
+
/* this is needed for interception code */
TValue env = kmake_empty_environment(K);
- TValue outer_cont = kmake_continuation(K, parent, KNIL, KNIL,
+ krooted_tvs_push(K, env);
+ TValue outer_cont = kmake_continuation(K, parent,
do_pass_value, 2, entry_guards, env);
kset_outer_cont(outer_cont);
- TValue inner_cont = kmake_continuation(K, outer_cont, KNIL, KNIL,
+ krooted_tvs_push(K, outer_cont);
+ TValue inner_cont = kmake_continuation(K, outer_cont,
do_pass_value, 2, exit_guards, env);
kset_inner_cont(inner_cont);
+ krooted_tvs_pop(K); krooted_tvs_pop(K); krooted_tvs_pop(K);
return inner_cont;
}
@@ -448,29 +471,38 @@ void load(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
/* the reads must be guarded to close the file if there is some error
this continuation also will return inert after the evaluation of the
last expression is done */
- TValue port = kmake_port(K, filename, false, KNIL, KNIL);
+ TValue port = kmake_port(K, filename, false);
+ krooted_tvs_push(K, port);
+
+ TValue inert_cont = make_return_value_cont(K, kget_cc(K), KINERT);
+ krooted_tvs_push(K, inert_cont);
+
TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port);
/* this will be used later, but contruct it now to use the
current continuation as parent
GC: root this obj */
- TValue inert_cont = make_return_value_cont(K, kget_cc(K), KINERT);
-
- kset_cc(K, guarded_cont);
+ kset_cc(K, guarded_cont); /* implicit rooting */
TValue ls = read_all_expr(K, port); /* any error will close the port */
/* now the sequence of expresions should be evaluated in denv
and #inert returned after all are done */
- kset_cc(K, inert_cont);
+ kset_cc(K, inert_cont); /* implicit rooting */
+ krooted_tvs_pop(K); /* already rooted */
+
if (ttisnil(ls)) {
+ krooted_tvs_pop(K); /* port */
kapply_cc(K, KINERT);
} else {
TValue tail = kcdr(ls);
if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ krooted_tvs_push(K, ls);
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
do_seq, 2, tail, denv);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K); /* ls */
}
+ krooted_tvs_pop(K); /* port */
ktail_eval(K, kcar(ls), denv);
}
}
@@ -483,38 +515,46 @@ void get_module(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
bind_al1tp(K, "get-module", ptree, "string", ttisstring, filename,
maybe_env);
+ TValue port = kmake_port(K, filename, false);
+ krooted_tvs_push(K, port);
+
TValue env = kmake_environment(K, K->ground_env);
+ krooted_tvs_push(K, env);
if (get_opt_tpar(K, "", K_TENVIRONMENT, &maybe_env)) {
kadd_binding(K, env, K->module_params_sym, maybe_env);
}
+ TValue ret_env_cont = make_return_value_cont(K, kget_cc(K), env);
+ krooted_tvs_pop(K); /* env alread in cont */
+ krooted_tvs_push(K, ret_env_cont);
+
/* the reads must be guarded to close the file if there is some error
this continuation also will return inert after the evaluation of the
last expression is done */
- TValue port = kmake_port(K, filename, false, KNIL, KNIL);
TValue guarded_cont = make_guarded_read_cont(K, kget_cc(K), port);
- /* this will be used later, but contruct it now to use the
- current continuation as parent
- GC: root this obj */
- TValue ret_env_cont = make_return_value_cont(K, kget_cc(K), env);
+ kset_cc(K, guarded_cont); /* implicit roooting */
- kset_cc(K, guarded_cont);
TValue ls = read_all_expr(K, port); /* any error will close the port */
/* now the sequence of expresions should be evaluated in the created env
and the environment returned after all are done */
- kset_cc(K, ret_env_cont);
+ kset_cc(K, ret_env_cont); /* implicit rooting */
+ krooted_tvs_pop(K); /* implicitly rooted */
if (ttisnil(ls)) {
+ krooted_tvs_pop(K); /* port */
kapply_cc(K, KINERT);
} else {
TValue tail = kcdr(ls);
if (ttispair(tail)) {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ krooted_tvs_push(K, ls);
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
do_seq, 2, tail, env);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
}
+ krooted_tvs_pop(K); /* port */
ktail_eval(K, kcar(ls), env);
}
}
diff --git a/src/kgpromises.c b/src/kgpromises.c
@@ -50,7 +50,7 @@ void handle_result(klisp_State *K, TValue *xparams, TValue obj)
/* promise was already determined */
kapply_cc(K, expr);
} else {
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
+ TValue new_cont = kmake_continuation(K, kget_cc(K),
handle_result, 1, prom);
kset_cc(K, new_cont);
ktail_eval(K, expr, maybe_env);
@@ -78,8 +78,7 @@ void force(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
} else {
TValue expr = kpromise_exp(obj);
TValue env = kpromise_maybe_env(obj);
- TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
- handle_result, 1, obj);
+ TValue new_cont = kmake_continuation(K, kget_cc(K), handle_result, 1, obj);
kset_cc(K, new_cont);
ktail_eval(K, expr, env);
}
@@ -91,7 +90,7 @@ void Slazy(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
UNUSED(xparams);
bind_1p(K, "$lazy", ptree, exp);
- TValue new_prom = kmake_promise(K, KNIL, KNIL, exp, denv);
+ TValue new_prom = kmake_promise(K, exp, denv);
kapply_cc(K, new_prom);
}
@@ -102,6 +101,6 @@ void memoize(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
UNUSED(denv);
bind_1p(K, "memoize", ptree, exp);
- TValue new_prom = kmake_promise(K, KNIL, KNIL, exp, KNIL);
+ TValue new_prom = kmake_promise(K, exp, KNIL);
kapply_cc(K, new_prom);
}
diff --git a/src/kground.c b/src/kground.c
@@ -44,23 +44,45 @@
** BEWARE: this is highly unhygienic, it assumes variables "symbol" and
** "value", both of type TValue. symbol will be bound to a symbol named by
** "n_" and can be referrenced in the var_args
+** GC: All of these assume that the extra args are rooted
*/
-#define add_operative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_); \
- value = make_operative(K_, fn_, __VA_ARGS__); \
- kadd_binding(K_, env_, symbol, value); }
-#define add_applicative(K_, env_, n_, fn_, ...) \
- { symbol = ksymbol_new(K_, n_); \
- value = make_applicative(K_, fn_, __VA_ARGS__); \
- kadd_binding(K_, env_, symbol, value); }
+/* Right now all symbols are rooted, but when possible, they will
+ be moved to a weak hashtable, so just in case root symbols during
+ operand/applicative construction */
+#define add_operative(K_, env_, n_, fn_, ...) \
+ { symbol = ksymbol_new(K_, n_); \
+ krooted_tvs_push(K_, symbol); \
+ value = kmake_operative(K_, fn_, __VA_ARGS__); \
+ krooted_tvs_push(K_, value); \
+ kadd_binding(K_, env_, symbol, value); \
+ krooted_tvs_pop(K_); \
+ krooted_tvs_pop(K_); }
+
+#define add_applicative(K_, env_, n_, fn_, ...) \
+ { symbol = ksymbol_new(K_, n_); \
+ krooted_tvs_push(K_, symbol); \
+ value = kmake_applicative(K_, fn_, __VA_ARGS__); \
+ krooted_tvs_push(K_, value); \
+ kadd_binding(K_, env_, symbol, value); \
+ krooted_tvs_pop(K_); \
+ krooted_tvs_pop(K_); }
+
+#define add_value(K_, env_, n_, v_) \
+ { value = v_; \
+ krooted_tvs_push(K_, value); \
+ symbol = ksymbol_new(K_, n_); \
+ krooted_tvs_push(K_, symbol); \
+ kadd_binding(K_, env_, symbol, v_); \
+ krooted_tvs_pop(K_); \
+ krooted_tvs_pop(K_); }
/*
** This is called once to bind all symbols in the ground environment
*/
void kinit_ground_env(klisp_State *K)
{
- TValue ground_env = K->ground_env;
+ TValue ground_env = K->ground_env; /* this is already rooted */
TValue symbol, value;
/*
@@ -522,14 +544,12 @@ void kinit_ground_env(klisp_State *K)
continuation_applicative, 0);
/* 7.2.6 root-continuation */
- symbol = ksymbol_new(K, "root-continuation");
- value = K->root_cont;
- kadd_binding(K, ground_env, symbol, value);
+ add_value(K, ground_env, "root-continuation",
+ K->root_cont);
/* 7.2.7 error-continuation */
- symbol = ksymbol_new(K, "error-continuation");
- value = K->error_cont;
- kadd_binding(K, ground_env, symbol, value);
+ add_value(K, ground_env, "error-continuation",
+ K->root_cont);
/*
** 7.3 Library features
diff --git a/src/kgstrings.c b/src/kgstrings.c
@@ -117,6 +117,7 @@ void string_setS(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
}
/* Helper for string and list->string */
+/* GC: Assumes ls is rooted */
inline TValue list_to_string_h(klisp_State *K, char *name, TValue ls)
{
int32_t dummy;
@@ -342,8 +343,8 @@ void string_to_list(klisp_State *K, TValue *xparams, TValue ptree,
bind_1tp(K, "string->list", ptree, "string", ttisstring, str);
int32_t pairs = kstring_size(str);
char *buf = kstring_buf(str);
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue tail = dummy;
+
+ TValue tail = kget_dummy1(K);
while(pairs--) {
TValue new_pair = kcons(K, ch2tv(*buf), KNIL);
@@ -351,7 +352,7 @@ void string_to_list(klisp_State *K, TValue *xparams, TValue ptree,
kset_cdr(tail, new_pair);
tail = new_pair;
}
- kapply_cc(K, kcdr(dummy));
+ kapply_cc(K, kcutoff_dummy1(K));
}
void list_to_string(klisp_State *K, TValue *xparams, TValue ptree,
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:
@@ -58,6 +55,7 @@ TValue kbigint_new(klisp_State *K, bool sign, uint32_t digit)
}
/* used in write to destructively get the digits */
+/* assumes src is rooted */
TValue kbigint_copy(klisp_State *K, TValue src)
{
TValue copy = kbigint_new(K, false, 0);
@@ -69,6 +67,7 @@ TValue kbigint_copy(klisp_State *K, TValue src)
/* This algorithm is like a fused multiply add on bignums,
unlike any other function here it modifies bigint. It is used in read
and it assumes that bigint is positive */
+/* GC: Assumes tv_bigint is rooted */
void kbigint_add_digit(klisp_State *K, TValue tv_bigint, int32_t base,
int32_t digit)
{
@@ -79,6 +78,7 @@ void kbigint_add_digit(klisp_State *K, TValue tv_bigint, int32_t base,
/* This is used by the writer to get the digits of a number
tv_bigint must be positive */
+/* GC: Assumes tv_bigint is rooted */
int32_t kbigint_remove_digit(klisp_State *K, TValue tv_bigint, int32_t base)
{
UNUSED(K);
@@ -97,6 +97,7 @@ bool kbigint_has_digits(klisp_State *K, TValue tv_bigint)
/* Mutate the bigint to have the opposite sign, used in read
and write*/
+/* GC: Assumes tv_bigint is rooted */
void kbigint_invert_sign(klisp_State *K, TValue tv_bigint)
{
Bigint *bigint = tv2bigint(tv_bigint);
@@ -141,33 +142,43 @@ bool kbigint_gep(TValue tv_bigint1, TValue tv_bigint2)
tv2bigint(tv_bigint2)) >= 0);
}
+/*
+** GC: All of these assume the parameters are rooted
+*/
TValue kbigint_plus(klisp_State *K, TValue n1, TValue n2)
{
TValue res = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, res);
UNUSED(mp_int_add(K, tv2bigint(n1), tv2bigint(n2), tv2bigint(res)));
+ krooted_tvs_pop(K);
return kbigint_try_fixint(K, res);
}
TValue kbigint_times(klisp_State *K, TValue n1, TValue n2)
{
TValue res = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, res);
UNUSED(mp_int_mul(K, tv2bigint(n1), tv2bigint(n2), tv2bigint(res)));
+ krooted_tvs_pop(K);
return kbigint_try_fixint(K, res);
}
TValue kbigint_minus(klisp_State *K, TValue n1, TValue n2)
{
TValue res = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, res);
UNUSED(mp_int_sub(K, tv2bigint(n1), tv2bigint(n2), tv2bigint(res)));
+ krooted_tvs_pop(K);
return kbigint_try_fixint(K, res);
}
/* NOTE: n2 can't be zero, that case should be checked before calling this */
TValue kbigint_div_mod(klisp_State *K, TValue n1, TValue n2, TValue *res_r)
{
- /* GC: root bigints */
TValue tv_q = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, tv_q);
TValue tv_r = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, tv_r);
Bigint *n = tv2bigint(n1);
Bigint *d = tv2bigint(n2);
@@ -188,6 +199,9 @@ TValue kbigint_div_mod(klisp_State *K, TValue n1, TValue n2, TValue *res_r)
}
}
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
*res_r = kbigint_try_fixint(K, tv_r);
return kbigint_try_fixint(K, tv_q);
}
@@ -196,7 +210,9 @@ TValue kbigint_div0_mod0(klisp_State *K, TValue n1, TValue n2, TValue *res_r)
{
/* GC: root bigints */
TValue tv_q = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, tv_q);
TValue tv_r = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, tv_r);
Bigint *n = tv2bigint(n1);
Bigint *d = tv2bigint(n2);
@@ -208,10 +224,12 @@ TValue kbigint_div0_mod0(klisp_State *K, TValue n1, TValue n2, TValue *res_r)
/* Adjust q & r so that -|d/2| <= r < |d/2| */
/* It seems easier to check -|d| <= 2r < |d| */
TValue tv_two_r = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, tv_two_r);
Bigint *two_r = tv2bigint(tv_two_r);
/* two_r = r * 2 = r * 2^1 */
UNUSED(mp_int_mul_pow2(K, r, 1, two_r));
TValue tv_abs_d = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, tv_abs_d);
/* NOTE: this makes a copy if d >= 0 */
Bigint *abs_d = tv2bigint(tv_abs_d);
UNUSED(mp_int_abs(K, d, abs_d));
@@ -241,6 +259,11 @@ TValue kbigint_div0_mod0(klisp_State *K, TValue n1, TValue n2, TValue *res_r)
}
}
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
*res_r = kbigint_try_fixint(K, tv_r);
return kbigint_try_fixint(K, tv_q);
}
@@ -269,7 +292,9 @@ TValue kbigint_abs(klisp_State *K, TValue tv_bigint)
{
if (kbigint_negativep(tv_bigint)) {
TValue copy = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, copy);
UNUSED(mp_int_abs(K, tv2bigint(tv_bigint), tv2bigint(copy)));
+ krooted_tvs_pop(K);
/* NOTE: this can never be a fixint if the parameter was a bigint */
return copy;
} else {
@@ -280,17 +305,21 @@ TValue kbigint_abs(klisp_State *K, TValue tv_bigint)
TValue kbigint_gcd(klisp_State *K, TValue n1, TValue n2)
{
TValue res = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, res);
UNUSED(mp_int_gcd(K, tv2bigint(n1), tv2bigint(n2), tv2bigint(res)));
+ krooted_tvs_pop(K);
return kbigint_try_fixint(K, res);
}
TValue kbigint_lcm(klisp_State *K, TValue n1, TValue n2)
{
TValue tv_res = kbigint_new(K, false, 0);
+ krooted_tvs_push(K, tv_res);
Bigint *res = tv2bigint(tv_res);
/* unlike in kernel, lcm in IMath can return a negative value
(if sign a != sign b) */
UNUSED(mp_int_lcm(K, tv2bigint(n1), tv2bigint(n2), res));
UNUSED(mp_int_abs(K, res, res));
+ krooted_tvs_pop(K);
return kbigint_try_fixint(K, tv_res);
}
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,51 @@
+/*
+** 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>
+
+/* temp defines till gc is stabilized */
+/* #define KUSE_GC 1 */
+/* Print msgs when starting and ending gc */
+/* #define KDEBUG_GC 1 */
+
+/*
+#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.
+*/
+
+/* In lua that has incremental gc this is setted to 200, in
+ klisp as we don't yet have incremental gc, we set it to 400 */
+#define KLISPI_GCPAUSE 400 /* 400% (wait memory to quadruple 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
@@ -18,6 +18,7 @@
#include "klimits.h"
#include "kmem.h"
#include "kerror.h"
+#include "kgc.h"
/*
** About the realloc function:
@@ -44,8 +45,23 @@
void *klispM_realloc_ (klisp_State *K, void *block, size_t osize, size_t nsize) {
klisp_assert((osize == 0) == (block == NULL));
+ /* TEMP: for now only Stop the world GC */
+ #ifdef KUSE_GC
+ if (K->totalbytes - osize + nsize >= K->GCthreshold) {
+ #ifdef KDEBUG_GC
+ printf("GC START, total_bytes: %d\n", K->totalbytes);
+ #endif
+ klispC_fullgc(K);
+ #ifdef KDEBUG_GC
+ printf("GC END, total_bytes: %d\n", K->totalbytes);
+ #endif
+ }
+ #endif
+
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
@@ -31,12 +31,9 @@
#include <stdbool.h>
#include <stdint.h>
#include <stdio.h>
-#include <assert.h>
-/* This should be in a configuration .h */
-/*
-#define KTRACK_MARKS (true)
-*/
+#include "klimits.h"
+#include "klispconf.h"
/*
** Union of all collectible objects
@@ -47,8 +44,38 @@ 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; uint16_t gct;
+#define CommonHeader GCObject *next; uint8_t tt; uint8_t flags; \
+ 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
+ from lua, they serve as compact bool fields for certain types */
+
+/*
+** NOTE: this is next pointer comes from lua. This is a byproduct of the
+** lua allocator. Because objects come from an arbitrary allocator, they
+** can't be assumed to be contiguous; but in the sweep phase of garbage
+** collection there has to be a way to iterate over all allocated objects
+** and that is the function of the next pointer: for storing the white
+** list. Upon allocation objects are added to this white list, all linked
+** together by a succession of next pointers starting in a field of the
+** state struct. Likewise, during the tracing phase, gray objects are linked
+** by means of the gclist pointer. Technically this is necessary only for
+** objects that have references, but in klisp all objects except strings
+** have them so it is easier to just put it here. Re the use of the padding,
+** this is necessary (TODO add 32-bit check) in 32 bits because of the packed
+** attribute. Otherwise, all TValues would be misaligned. All of this,
+** assuming the compiler complies with it, but if not the padding doesn't
+** hurt.
+*/
+/*
+** MAYBE/REFACTOR: other way to do it would be to have a packed GCHeader
+** struct inside each object, but would have to change all references to
+** header objects from 'obj.*' to 'obj.h.*', or something like that. I
+** think the next C standard (C1X at this point) allows the use of
+** anonymous inner struct and unions for this use case
+*/
/*
** Common header in struct form
@@ -75,6 +102,8 @@ typedef struct __attribute__ ((__packed__)) GCheader {
** This gives us 256 types and as many as 8 flags per type.
*/
+/* TODO eliminate flags */
+
/*
** Macros for manipulating tags directly
*/
@@ -135,6 +164,9 @@ typedef struct __attribute__ ((__packed__)) GCheader {
/* this is used to test for numbers, as returned by ttype */
#define K_LAST_NUMBER_TYPE K_TCOMPLEX
+/* this is used to if the object is collectable */
+#define K_FIRST_GC_TYPE K_TPAIR
+
#define K_MAKE_VTAG(t) (K_TAG_TAGGED | (t))
/*
@@ -177,8 +209,8 @@ typedef struct __attribute__ ((__packed__)) GCheader {
*/
/* NOTE: This is intended for use in switch statements */
-#define ttype(o) ({ TValue o_ = (o); \
- ttisdouble(o_)? K_TDOUBLE : ttype_(o_); })
+#define ttype(o) ({ TValue tto_ = (o); \
+ ttisdouble(tto_)? K_TDOUBLE : ttype_(tto_); })
/* This is intended for internal use below. DON'T USE OUTSIDE THIS FILE */
#define ttag(o) ((o).tv.t)
@@ -192,6 +224,7 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttisbigint(o) (tbasetype_(o) == K_TAG_FIXINT)
#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); })
#define ttiseinf(o) (tbasetype_(o) == K_TAG_EINF)
#define ttisiinf(o) (tbasetype_(o) == K_TAG_IINF)
#define ttisnil(o) (tbasetype_(o) == K_TAG_NIL)
@@ -202,7 +235,13 @@ typedef struct __attribute__ ((__packed__)) GCheader {
#define ttischar(o) (tbasetype_(o) == K_TAG_CHAR)
#define ttisdouble(o) ((ttag(o) & K_TAG_BASE_MASK) != K_TAG_TAGGED)
-/* Complex types (value in heap) */
+/* Complex types (value in heap),
+ (bigints, rationals, etc could be collectable)
+ maybe we should use a better way for this, to speed up checks, maybe use
+ a flag? */
+#define iscollectable(o) ({ uint8_t t = ttype(o); \
+ (t == K_TBIGINT || t == K_TBIGRAT || t >= K_FIRST_GC_TYPE); })
+
#define ttisstring(o) (tbasetype_(o) == K_TAG_STRING)
#define ttissymbol(o) (tbasetype_(o) == K_TAG_SYMBOL)
#define ttispair(o) (tbasetype_(o) == K_TAG_PAIR)
@@ -580,4 +619,15 @@ bool kis_output_port(TValue o);
/* Macro to test the most basic equality on TValues */
#define tv_equal(tv1_, tv2_) ((tv1_).raw == (tv2_).raw)
+/*
+** for internal debug only
+*/
+#define checkconsistency(obj) \
+ klisp_assert(!iscollectable(obj) || (ttype_(obj) == gcvalue(obj)->gch.tt))
+
+#define checkliveness(k,obj) \
+ klisp_assert(!iscollectable(obj) || \
+ ((ttype_(obj) == gcvalue(obj)->gch.tt) && !isdead(k, gcvalue(obj))))
+
+
#endif
diff --git a/src/koperative.c b/src/koperative.c
@@ -10,24 +10,22 @@
#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, ...)
+/* GC: Assumes all argps are rooted */
+TValue kmake_operative(klisp_State *K, klisp_Ofunc fn, int32_t xcount, ...)
{
va_list argp;
+
Operative *new_op = (Operative *)
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;
- new_op->si = si;
+ new_op->name = KNIL;
+ new_op->si = KNIL;
new_op->fn = fn;
new_op->extra_size = xcount;
@@ -36,5 +34,6 @@ TValue kmake_operative(klisp_State *K, TValue name, TValue si,
new_op->extra[i] = va_arg(argp, TValue);
}
va_end(argp);
+
return gc2op(new_op);
}
diff --git a/src/koperative.h b/src/koperative.h
@@ -11,7 +11,8 @@
#include "kstate.h"
/* TODO: make some specialized constructors for 0, 1 and 2 parameters */
-TValue kmake_operative(klisp_State *K, TValue name, TValue si,
- klisp_Ofunc fn, int xcount, ...);
+
+/* GC: Assumes all argps are rooted */
+TValue kmake_operative(klisp_State *K, klisp_Ofunc fn, int xcount, ...);
#endif
diff --git a/src/kpair.c b/src/kpair.c
@@ -4,21 +4,21 @@
** See Copyright Notice in klisp.h
*/
+#include <stdarg.h>
+
#include "kpair.h"
#include "kobject.h"
#include "kstate.h"
#include "kmem.h"
+#include "kgc.h"
+/* GC: assumes car & cdr are rooted */
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;
@@ -29,4 +29,33 @@ TValue kcons_g(klisp_State *K, bool m, TValue car, TValue cdr)
return gc2pair(new_pair);
}
+#define MAX_LIST_N 16
+
+/* GC: assumes all argps are rooted */
+TValue klist_g(klisp_State *K, bool m, int32_t n, ...)
+{
+ va_list argp;
+
+ klisp_assert(n < MAX_LIST_N);
+
+ /* don't use any of the klisp dummys, because this is
+ called from many places */
+ TValue dummy = kcons_g(K, m, KINERT, KNIL);
+ krooted_tvs_push(K, dummy);
+ TValue tail = dummy;
+
+ va_start(argp, n);
+ for (int i = 0; i < n; i++) {
+ TValue next_car = va_arg(argp, TValue);
+ TValue np = kcons_g(K, m, next_car, KNIL);
+ kset_cdr(tail, np);
+ tail = np;
+ }
+ va_end(argp);
+
+ krooted_tvs_pop(K);
+ return kcdr(dummy);
+}
+
+
bool kpairp(TValue obj) { return ttispair(obj); }
diff --git a/src/kpair.h b/src/kpair.h
@@ -9,6 +9,7 @@
#include "kobject.h"
#include "kstate.h"
+#include "klimits.h"
/* TODO: add type assertions */
#define kcar(p_) (tv2pair(p_)->car)
@@ -50,17 +51,80 @@
#define kset_car(p_, v_) (kcar(p_) = (v_))
#define kset_cdr(p_, v_) (kcdr(p_) = (v_))
-#define kdummy_cons(st_) (kcons(st_, KNIL, KNIL))
-#define kdummy_imm_cons(st_) (kimm_cons(st_, KNIL, KNIL))
-
+/* GC: assumes car & cdr are rooted */
TValue kcons_g(klisp_State *K, bool m, TValue car, TValue cdr);
+/* GC: assumes all argps are rooted */
+TValue klist_g(klisp_State *K, bool m, int32_t n, ...);
+
#define kcons(K_, car_, cdr_) (kcons_g(K_, true, car_, cdr_))
#define kimm_cons(K_, car_, cdr_) (kcons_g(K_, false, car_, cdr_))
+#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_))
bool kpairp(TValue obj);
+inline TValue kget_dummy1(klisp_State *K)
+{
+ klisp_assert(ttispair(K->dummy_pair2) && ttisnil(kcdr(K->dummy_pair2)));
+ return K->dummy_pair1;
+}
+
+inline TValue kget_dummy1_tail(klisp_State *K)
+{
+ klisp_assert(ttispair(K->dummy_pair1));
+ return kcdr(K->dummy_pair1);
+}
+
+inline TValue kcutoff_dummy1(klisp_State *K)
+{
+ klisp_assert(ttispair(K->dummy_pair1));
+ TValue res = kcdr(K->dummy_pair1);
+ kset_cdr(K->dummy_pair1, KNIL);
+ return res;
+}
+
+inline TValue kget_dummy2(klisp_State *K)
+{
+ klisp_assert(ttispair(K->dummy_pair2) && ttisnil(kcdr(K->dummy_pair2)));
+ return K->dummy_pair2;
+}
+
+inline TValue kget_dummy2_tail(klisp_State *K)
+{
+ klisp_assert(ttispair(K->dummy_pair2));
+ return kcdr(K->dummy_pair2);
+}
+
+inline TValue kcutoff_dummy2(klisp_State *K)
+{
+ klisp_assert(ttispair(K->dummy_pair2));
+ TValue res = kcdr(K->dummy_pair2);
+ kset_cdr(K->dummy_pair2, KNIL);
+ return res;
+}
+
+inline TValue kget_dummy3(klisp_State *K)
+{
+ klisp_assert(ttispair(K->dummy_pair3) && ttisnil(kcdr(K->dummy_pair3)));
+ return K->dummy_pair3;
+}
+
+inline TValue kget_dummy3_tail(klisp_State *K)
+{
+ klisp_assert(ttispair(K->dummy_pair3));
+ return kcdr(K->dummy_pair3);
+}
+
+inline TValue kcutoff_dummy3(klisp_State *K)
+{
+ klisp_assert(ttispair(K->dummy_pair3));
+ TValue res = kcdr(K->dummy_pair3);
+ kset_cdr(K->dummy_pair3, KNIL);
+ return res;
+}
+
#endif
diff --git a/src/kport.c b/src/kport.c
@@ -13,14 +13,16 @@
#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,
file-exists? and a mechanism to truncate or append to a file, or
throw error if it exists.
Should use open, but it is non standard (fcntl.h, POSIX only) */
-TValue kmake_port(klisp_State *K, TValue filename, bool writep, TValue name,
- TValue si)
+
+/* GC: Assumes filename is rooted */
+TValue kmake_port(klisp_State *K, TValue filename, bool writep)
{
/* for now always use text mode */
FILE *f = fopen(kstring_buf(filename), writep? "w": "r");
@@ -28,25 +30,24 @@ TValue kmake_port(klisp_State *K, TValue filename, bool writep, TValue name,
klispE_throw(K, "Create port: could't open file");
return KINERT;
} else {
- return kmake_std_port(K, filename, writep, name, si, f);
+ return kmake_std_port(K, filename, writep, KNIL, KNIL, f);
}
}
/* this is for creating ports for stdin/stdout/stderr &
also a helper for the above */
+
+/* GC: Assumes filename, name & si are rooted */
TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
TValue name, TValue si, FILE *file)
{
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/kport.h b/src/kport.h
@@ -12,10 +12,12 @@
#include "kobject.h"
#include "kstate.h"
-TValue kmake_port(klisp_State *K, TValue filename, bool writep, TValue name,
- TValue si);
+/* GC: Assumes filename is rooted */
+TValue kmake_port(klisp_State *K, TValue filename, bool writep);
-/* this is for creating ports for stdin/stdout/stderr */
+/* this is for creating ports for stdin/stdout/stderr &
+ helper for the one above */
+/* GC: Assumes filename, name & si are rooted */
TValue kmake_std_port(klisp_State *K, TValue filename, bool writep,
TValue name, TValue si, FILE *file);
diff --git a/src/kpromise.c b/src/kpromise.c
@@ -9,23 +9,22 @@
#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)
+/* GC: Assumes exp & maybe_env are roooted */
+TValue kmake_promise(klisp_State *K, TValue exp, TValue maybe_env)
{
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;
- new_prom->si = si;
- /* GC: root new_prom before cons */
+ 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);
+ krooted_tvs_pop(K);
return gc2prom(new_prom);
}
diff --git a/src/kpromise.h b/src/kpromise.h
@@ -11,8 +11,8 @@
#include "kstate.h"
#include "kpair.h"
-TValue kmake_promise(klisp_State *K, TValue name, TValue si,
- TValue exp, TValue maybe_env);
+/* GC: Assumes exp & maybe_env are roooted */
+TValue kmake_promise(klisp_State *K, TValue exp, TValue maybe_env);
#define kpromise_node(p_) (tv2prom(p_)->node)
#define kpromise_exp(p_) (kcar(kpromise_node(p_)))
diff --git a/src/kread.c b/src/kread.c
@@ -69,6 +69,12 @@ void kread_error(klisp_State *K, char *str)
ks_tbclear(K);
ks_sclear(K);
clear_shared_dict(K);
+
+ /* this is needed because it would be too complicated to
+ pop manually on each kind of error */
+ krooted_tvs_clear(K);
+ krooted_vars_clear(K);
+
klispE_throw(K, str);
}
@@ -95,7 +101,8 @@ TValue try_shared_ref(klisp_State *K, TValue ref_token)
return KINERT;
}
-TValue try_shared_def(klisp_State *K, TValue def_token, TValue value)
+/* GC: def token is rooted */
+void try_shared_def(klisp_State *K, TValue def_token, TValue value)
{
/* IMPLEMENTATION RESTRICTION: only allow fixints in shared tokens */
int32_t ref_num = ivalue(kcdr(def_token));
@@ -105,15 +112,16 @@ TValue try_shared_def(klisp_State *K, TValue def_token, TValue value)
if (ref_num == ivalue(kcar(head))) {
kread_error(K, "duplicate shared def found");
/* avoid warning */
- return KINERT;
+ return;
}
tail = kcdr(tail);
}
- /* XXX: what happens on out of mem? & gc? (inner cons is not rooted) */
- K->shared_dict = kcons(K, kcons(K, kcdr(def_token), value),
- K->shared_dict);
- return KINERT;
+ TValue new_tok = kcons(K, kcdr(def_token), value);
+ krooted_tvs_push(K, new_tok);
+ K->shared_dict = kcons(K, new_tok, K->shared_dict); /* value is protected by cons */
+ krooted_tvs_pop(K);
+ return;
}
/* This overwrites a previouly made def, it is used in '() */
@@ -152,9 +160,13 @@ TValue kread_fsm(klisp_State *K)
/* the source code information of that obj */
TValue obj_si;
+ krooted_vars_push(K, &obj);
+ krooted_vars_push(K, &obj_si);
+
while (!(get_state(K) == ST_READ && !read_next_token)) {
if (read_next_token) {
- TValue tok = ktok_read_token(K);
+ TValue tok = ktok_read_token(K); /* only root it when necessary */
+
if (ttispair(tok)) { /* special token */
switch (chvalue(kcar(tok))) {
case '(': {
@@ -166,6 +178,7 @@ TValue kread_fsm(klisp_State *K)
}
/* construct the list with the correct type of pair */
TValue np = kcons_g(K, K->read_mconsp, KINERT, KNIL);
+ krooted_tvs_push(K, np);
/*
** NOTE: the source info of the '(' is temporarily saved
** in np (later it will be replace by the source info
@@ -187,6 +200,8 @@ TValue kread_fsm(klisp_State *K)
push_data(K, np);
push_state(K, ST_FIRST_LIST);
read_next_token = true;
+
+ krooted_tvs_pop(K);
break;
}
case ')': {
@@ -289,18 +304,15 @@ TValue kread_fsm(klisp_State *K)
/* avoid warning */
return KINERT;
default: {
- TValue res = try_shared_def(K, tok, KNIL);
- /* TEMP: while error returns EOF */
- if (ttiseof(res)) {
- return res;
- } else {
- /* token ok, read defined object */
- /* NOTE: save the source info to return it
- after the defined object is read */
- push_data(K, kcons(K, tok, ktok_get_source_info(K)));
- push_state(K, ST_SHARED_DEF);
- read_next_token = true;
- }
+ krooted_tvs_push(K, tok);
+ try_shared_def(K, tok, KNIL);
+ /* token ok, read defined object */
+ /* NOTE: save the source info to return it
+ after the defined object is read */
+ push_data(K, kcons(K, tok, ktok_get_source_info(K)));
+ push_state(K, ST_SHARED_DEF);
+ read_next_token = true;
+ krooted_tvs_pop(K);
}
}
break;
@@ -319,16 +331,11 @@ TValue kread_fsm(klisp_State *K)
return KINERT;
default: {
TValue res = try_shared_ref(K, tok);
- /* TEMP: while error returns EOF */
- if (ttiseof(res)) {
- return res;
- } else {
- /* ref ok, process it in next iteration */
- obj = res;
- /* NOTE: use source info of ref token */
- obj_si = ktok_get_source_info(K);
- read_next_token = false;
- }
+ /* ref ok, process it in next iteration */
+ obj = res;
+ /* NOTE: use source info of ref token */
+ obj_si = ktok_get_source_info(K);
+ read_next_token = false;
}
}
break;
@@ -390,6 +397,8 @@ TValue kread_fsm(klisp_State *K)
TValue fp = get_data(K);
/* replace source info in fp with the saved one */
/* NOTE: the old one will be returned when list is complete */
+ /* 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_car(fp, obj);
@@ -408,13 +417,16 @@ TValue kread_fsm(klisp_State *K)
/* get the state out of the way */
pop_state(K);
/* construct the list with the correct type of pair */
+ /* 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_cdr(get_data(K), np);
/* replace last pair of the (still incomplete) read next obj */
pop_data(K);
push_data(K, np);
push_state(K, ST_MIDDLE_LIST);
+ krooted_tvs_pop(K);
read_next_token = true;
break;
}
@@ -454,6 +466,9 @@ TValue kread_fsm(klisp_State *K)
}
}
+ krooted_vars_pop(K);
+ krooted_vars_pop(K);
+
pop_state(K);
assert(ks_sisempty(K));
return obj;
diff --git a/src/krepl.c b/src/krepl.c
@@ -21,9 +21,8 @@
/* the exit continuation, it exits the loop */
void exit_fn(klisp_State *K, TValue *xparams, TValue obj)
{
- /* avoid warnings */
- (void) xparams;
- (void) obj;
+ UNUSED(xparams);
+ UNUSED(obj);
/* force the loop to terminate */
K->next_func = NULL;
@@ -33,8 +32,8 @@ void exit_fn(klisp_State *K, TValue *xparams, TValue obj)
/* the underlying function of the read cont */
void read_fn(klisp_State *K, TValue *xparams, TValue obj)
{
- (void) obj;
- (void) xparams;
+ UNUSED(xparams);
+ UNUSED(obj);
/* show prompt */
fprintf(stdout, "klisp> ");
@@ -69,15 +68,20 @@ void eval_cfn(klisp_State *K, TValue *xparams, TValue obj)
void loop_fn(klisp_State *K, TValue *xparams, TValue obj);
/* this is called from both loop_fn and error_fn */
+/* GC: assumes denv is NOT rooted */
inline void create_loop(klisp_State *K, TValue denv)
{
- TValue loop_cont = kmake_continuation(
- K, K->root_cont, KNIL, KNIL, &loop_fn, 1, denv);
- TValue eval_cont = kmake_continuation(
- K, loop_cont, KNIL, KNIL, &eval_cfn, 1, denv);
- TValue read_cont = kmake_continuation(
- K, eval_cont, KNIL, KNIL, &read_fn, 0);
+ krooted_tvs_push(K, denv);
+ TValue loop_cont =
+ kmake_continuation(K, K->root_cont, &loop_fn, 1, denv);
+ krooted_tvs_push(K, loop_cont);
+ TValue eval_cont = kmake_continuation(K, loop_cont, &eval_cfn, 1, denv);
+ krooted_tvs_pop(K); /* in eval cont */
+ krooted_tvs_push(K, eval_cont);
+ TValue read_cont = kmake_continuation(K, eval_cont, &read_fn, 0);
kset_cc(K, read_cont);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
kapply_cc(K, KINERT);
}
@@ -118,23 +122,32 @@ void error_fn(klisp_State *K, TValue *xparams, TValue obj)
void kinit_repl(klisp_State *K)
{
TValue std_env = kmake_environment(K, K->ground_env);
+ krooted_tvs_push(K, std_env);
/* set up the continuations */
- TValue root_cont = kmake_continuation(K, KNIL, KNIL, KNIL,
- exit_fn, 0);
- TValue error_cont = kmake_continuation(K, root_cont, KNIL, KNIL,
- error_fn, 1, std_env);
+ TValue root_cont = kmake_continuation(K, KNIL, exit_fn, 0);
+ krooted_tvs_push(K, root_cont);
+
+ TValue error_cont = kmake_continuation(K, root_cont, error_fn, 1, std_env);
+ krooted_tvs_push(K, error_cont);
/* update the ground environment with these two conts */
TValue symbol;
symbol = ksymbol_new(K, "root-continuation");
+ /* GC: symbol should already be in root */
kadd_binding(K, K->ground_env, symbol, root_cont);
- symbol = ksymbol_new(K, "error-continuation");
+ symbol = ksymbol_new(K, "error-continuation");
+ /* GC: symbol should already be in root */
kadd_binding(K, K->ground_env, symbol, error_cont);
/* and save them in the structure */
K->root_cont = root_cont;
K->error_cont = error_cont;
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
+ /* GC: create_loop will root std_env */
create_loop(K, std_env);
}
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
@@ -62,6 +63,7 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
/* TODO: create a continuation */
K->curr_cont = KNIL;
+ K->next_obj = KINERT;
K->next_func = NULL;
K->next_value = KINERT;
K->next_env = KNIL;
@@ -89,14 +91,38 @@ 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;
K->totalbytes = state_size() + KS_ISSIZE * sizeof(TValue) +
KS_ITBSIZE;
- K->root_gc = NULL;
+ K->GCthreshold = UINT32_MAX; /* we still have a lot of allocation
+ to do, put a very high value to
+ avoid collection */
+ 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 */
+ /* init the stacks used to protect variables & values from gc,
+ this should be done before any new object is created because
+ they are used by them */
+ K->rooted_tvs_top = 0;
+ K->rooted_vars_top = 0;
+
+ K->dummy_pair1 = kcons(K, KINERT, KNIL);
+ K->dummy_pair2 = kcons(K, KINERT, KNIL);
+ K->dummy_pair3 = kcons(K, KINERT, KNIL);
+
/* initialize strings */
/* Empty string */
/* TODO: make it uncollectible */
@@ -143,13 +169,16 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
K->kd_out_port_key = kcons(K, KTRUE, out_port);
/* create the ground environment and the eval operative */
- K->eval_op = kmake_operative(K, KNIL, KNIL, keval_ofn, 0);
- K->list_app = kwrap(K, kmake_operative(K, KNIL, KNIL, list, 0));
+ K->eval_op = kmake_operative(K, keval_ofn, 0);
+ K->list_app = kmake_applicative(K, list, 0);
K->ground_env = kmake_empty_environment(K);
K->module_params_sym = ksymbol_new(K, "module-parameters");
-
+
kinit_ground_env(K);
+ /* set the threshold for gc start now that we have allocated all mem */
+ K->GCthreshold = 4*K->totalbytes;
+
return K;
}
@@ -275,14 +304,14 @@ TValue select_interceptor(TValue guard_ls)
** Returns a list of entries like the following:
** (interceptor-op outer_cont . denv)
*/
-/* TODO: should inline this one, is only called from one place */
-TValue create_interception_list(klisp_State *K, TValue src_cont,
+
+/* GC: assume src_cont & dst_cont are rooted, uses dummy1 */
+inline TValue create_interception_list(klisp_State *K, TValue src_cont,
TValue dst_cont)
{
/* GC: root intermediate pairs */
mark_iancestors(dst_cont);
- TValue dummy = kcons(K, KINERT, KNIL);
- TValue tail = dummy;
+ TValue tail = kget_dummy1(K);
TValue cont = src_cont;
/* exit guards are from the inside to the outside, and
@@ -299,9 +328,13 @@ TValue create_interception_list(klisp_State *K, TValue src_cont,
/* TODO make macros */
TValue denv = tv2cont(cont)->extra[1];
TValue outer = tv2cont(cont)->parent;
- TValue new_entry = kcons(K, interceptor,
- kcons(K, outer, denv));
+ TValue outer_denv = kcons(K, outer, denv);
+ krooted_tvs_push(K, outer_denv);
+ TValue new_entry = kcons(K, interceptor, outer_denv);
+ krooted_tvs_pop(K); /* already in entry */
+ krooted_tvs_push(K, new_entry);
TValue new_pair = kcons(K, new_entry, KNIL);
+ krooted_tvs_pop(K);
kset_cdr(tail, new_pair);
tail = new_pair;
}
@@ -318,6 +351,7 @@ TValue create_interception_list(klisp_State *K, TValue src_cont,
cont = dst_cont;
TValue entry_int = KNIL;
+ krooted_vars_push(K, &entry_int);
while(!kis_marked(cont)) {
/* only outer conts have entry guards */
@@ -328,9 +362,13 @@ TValue create_interception_list(klisp_State *K, TValue src_cont,
/* TODO make macros */
TValue denv = tv2cont(cont)->extra[1];
TValue outer = cont;
- TValue new_entry = kcons(K, interceptor,
- kcons(K, outer, denv));
+ TValue outer_denv = kcons(K, outer, denv);
+ krooted_tvs_push(K, outer_denv);
+ TValue new_entry = kcons(K, interceptor, outer_denv);
+ krooted_tvs_pop(K); /* already in entry */
+ krooted_tvs_push(K, new_entry);
entry_int = kcons(K, new_entry, entry_int);
+ krooted_tvs_pop(K);
}
}
cont = tv2cont(cont)->parent;
@@ -340,7 +378,8 @@ TValue create_interception_list(klisp_State *K, TValue src_cont,
/* all interceptions collected, append the two lists and return */
kset_cdr(tail, entry_int);
- return kcdr(dummy);
+ krooted_vars_pop(K);
+ return kcutoff_dummy1(K);
}
/* this passes the operand tree to the continuation */
@@ -376,20 +415,20 @@ void do_interception(klisp_State *K, TValue *xparams, TValue obj)
TValue op = kcar(first);
TValue outer = kcadr(first);
TValue denv = kcddr(first);
- TValue app = kwrap(K, kmake_operative(K, KNIL, KNIL,
- cont_app, 1, outer));
- TValue ptree = kcons(K, obj, kcons(K, app, KNIL));
- TValue new_cont =
- kmake_continuation(K, outer, KNIL, KNIL, do_interception,
- 2, kcdr(ls), dst_cont);
+ TValue app = kmake_applicative(K, cont_app, 1, outer);
+ krooted_tvs_push(K, app);
+ TValue ptree = klist(K, 2, obj, app);
+ krooted_tvs_pop(K); /* already in ptree */
+ krooted_tvs_push(K, ptree);
+ TValue new_cont = kmake_continuation(K, outer, do_interception,
+ 2, kcdr(ls), dst_cont);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
ktail_call(K, op, ptree, denv);
}
}
-/* GC: should probably save the cont to retain the objects in
- xparams in case of gc (Also useful for source code info)
- probably a new field in K called active_cont */
+/* GC: assumes obj & dst_cont are rooted */
void kcall_cont(klisp_State *K, TValue dst_cont, TValue obj)
{
TValue src_cont = kget_cc(K);
@@ -398,11 +437,12 @@ void kcall_cont(klisp_State *K, TValue dst_cont, TValue obj)
if (ttisnil(int_ls)) {
new_cont = dst_cont; /* no interceptions */
} else {
+ krooted_tvs_push(K, int_ls);
/* we have to contruct a continuation to do the interceptions
in order and finally call dst_cont if no divert occurs */
- new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
- do_interception, 2, int_ls, dst_cont);
-
+ new_cont = kmake_continuation(K, kget_cc(K), do_interception,
+ 2, int_ls, dst_cont);
+ krooted_tvs_pop(K);
}
/*
@@ -449,72 +489,15 @@ 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"
@@ -37,6 +34,10 @@ typedef struct {
int32_t saved_col;
} ksource_info_t;
+#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;
TValue curr_cont;
@@ -46,6 +47,8 @@ struct klisp_State {
** (from a continuation) and otherwise next_func is of type
** klisp_Ofunc (from an operative)
*/
+ TValue next_obj; /* this is the operative or continuation to call
+ must be here to protect it from gc */
void *next_func; /* the next function to call (operative or cont) */
TValue next_value; /* the value to be passed to the next function */
TValue next_env; /* either NIL or an environment for next operative */
@@ -64,9 +67,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;
@@ -111,6 +127,24 @@ struct klisp_State {
int32_t ssize; /* total size of array */
int32_t stop; /* top of the stack (all elements are below this index) */
TValue *sbuf;
+
+ /* TValue stack to protect values from gc, must not grow, otherwise
+ it may call the gc */
+ int32_t rooted_tvs_top;
+ TValue rooted_tvs_buf[GC_PROTECT_SIZE];
+
+ /* TValue * stack to protect c variables from gc. This is used when the
+ object pointed to by a variable may change */
+ int32_t rooted_vars_top;
+ TValue *rooted_vars_buf[GC_PROTECT_SIZE];
+
+ /* These three are useful for constructing lists by means of set-car &
+ set-cdr. The idea is that these dummy pairs start as the head of
+ the list (protecting the entire chain from GC) and at the end of the
+ construction, the list is cut off from the cdr of the dummy */
+ TValue dummy_pair1;
+ TValue dummy_pair2;
+ TValue dummy_pair3;
};
/* some size related macros */
@@ -149,10 +183,13 @@ inline bool ks_sisempty(klisp_State *K);
inline void ks_spush(klisp_State *K, TValue obj)
{
- if (ks_stop(K) == ks_ssize(K))
- ks_sgrow(K, ks_stop(K)+1);
ks_selem(K, ks_stop(K)) = obj;
++ks_stop(K);
+ /* put check after so that there is always space for one obj, and if
+ realloc is needed, obj is already rooted */
+ if (ks_stop(K) == ks_ssize(K)) {
+ ks_sgrow(K, ks_stop(K)+1);
+ }
}
@@ -239,7 +276,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);
}
@@ -255,6 +292,40 @@ inline bool ks_tbisempty(klisp_State *K)
return ks_tbidx(K) == 0;
}
+/*
+** Functions to protect values from GC
+** TODO: add write barriers
+*/
+inline void krooted_tvs_push(klisp_State *K, TValue tv)
+{
+ klisp_assert(K->rooted_tvs_top < GC_PROTECT_SIZE);
+ K->rooted_tvs_buf[K->rooted_tvs_top++] = tv;
+}
+
+inline void krooted_tvs_pop(klisp_State *K)
+{
+ klisp_assert(K->rooted_tvs_top > 0);
+ --(K->rooted_tvs_top);
+}
+
+inline void krooted_tvs_clear(klisp_State *K) { K->rooted_tvs_top = 0; }
+
+inline void krooted_vars_push(klisp_State *K, TValue *v)
+{
+ klisp_assert(K->rooted_vars_top < GC_PROTECT_SIZE);
+ K->rooted_vars_buf[K->rooted_vars_top++] = v;
+}
+
+inline void krooted_vars_pop(klisp_State *K)
+{
+ klisp_assert(K->rooted_vars_top > 0);
+ --(K->rooted_vars_top);
+}
+
+inline void krooted_vars_clear(klisp_State *K) { K->rooted_vars_top = 0; }
+
+/* dummy functions will be in kpair.h, because we can't include
+ it from here */
/*
** prototypes for underlying c functions of continuations &
@@ -270,6 +341,10 @@ typedef void (*klisp_Ofunc) (klisp_State *K, TValue *ud, TValue ptree,
*/
inline void klispS_apply_cc(klisp_State *K, TValue val)
{
+ klisp_assert(K->rooted_tvs_top == 0);
+ klisp_assert(K->rooted_vars_top == 0);
+
+ K->next_obj = K->curr_cont; /* save it from GC */
Continuation *cont = tv2cont(K->curr_cont);
K->next_func = cont->fn;
K->next_value = val;
@@ -298,6 +373,10 @@ inline void klispS_set_cc(klisp_State *K, TValue new_cont)
inline void klispS_tail_call(klisp_State *K, TValue top, TValue ptree,
TValue env)
{
+ klisp_assert(K->rooted_tvs_top == 0);
+ klisp_assert(K->rooted_vars_top == 0);
+
+ K->next_obj = top; /* save it from GC */
Operative *op = tv2op(top);
K->next_func = op->fn;
K->next_value = ptree;
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)
@@ -36,22 +37,22 @@ TValue ksymbol_new_g(klisp_State *K, const char *buf, int32_t size,
/* 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 */
+ krooted_tvs_push(K, new_str);
Symbol *new_sym = klispM_new(K, Symbol);
+ krooted_tvs_pop(K);
/* 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;
new_sym->str = new_str;
TValue new_symv = gc2sym(new_sym);
- /* GC: root new_symb */
+ krooted_tvs_push(K, new_symv);
K->symbol_table = kcons(K, new_symv, K->symbol_table);
+ krooted_tvs_pop(K);
return new_symv;
}
@@ -69,6 +70,7 @@ TValue ksymbol_new(klisp_State *K, const char *buf)
}
/* for string->symbol */
+/* GC: assumes str is rooted */
TValue ksymbol_new_check_i(klisp_State *K, TValue str)
{
int32_t size = kstring_size(str);
@@ -104,7 +106,9 @@ TValue ksymbol_new_check_i(klisp_State *K, TValue str)
/* recover size & buf*/
size = kstring_size(str);
buf = kstring_buf(str);
- return ksymbol_new_g(K, buf, size, identifierp);
+
+ TValue new_sym = ksymbol_new_g(K, buf, size, identifierp);
+ return new_sym;
}
bool ksymbolp(TValue obj) { return ttissymbol(obj); }
diff --git a/src/ktoken.c b/src/ktoken.c
@@ -186,14 +186,19 @@ void ktok_save_source_info(klisp_State *K)
TValue ktok_get_source_info(klisp_State *K)
{
- /* XXX: what happens on gc? (unrooted objects) */
/* 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));
+ krooted_tvs_push(K, filename_str);
/* TEMP: for now, lines and column names are fixints */
- return kcons(K, filename_str, kcons(K, i2tv(K->ktok_source_info.saved_line),
- i2tv(K->ktok_source_info.saved_col)));
+ TValue res = kcons(K, i2tv(K->ktok_source_info.saved_line),
+ i2tv(K->ktok_source_info.saved_col));
+ krooted_tvs_push(K, res);
+ res = kcons(K, filename_str, res);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ return res;
}
/*
@@ -211,6 +216,10 @@ void ktok_error(klisp_State *K, char *str)
ks_tbclear(K);
ks_sclear(K);
clear_shared_dict(K);
+
+ krooted_tvs_clear(K);
+ krooted_vars_clear(K);
+
klispE_throw(K, str);
}
@@ -277,6 +286,7 @@ TValue ktok_read_token(klisp_State *K)
/* positive number, no exactness or radix indicator */
int32_t buf_len = ktok_read_until_delimiter(K);
char *buf = ks_tbget_buffer(K);
+ /* read number should free the tbbuffer */
return ktok_read_number(K, buf, buf_len, false, false, false, 10);
}
case '+': case '-':
@@ -420,7 +430,7 @@ TValue ktok_read_number(klisp_State *K, char *buf, int32_t len,
occur if it used the regular bigint+ and bigint* */
is_fixint = false;
bigint_res = kbigint_new(K, false, fixint_res);
- /* GC: root bigint_res */
+ krooted_vars_push(K, &bigint_res);
}
kbigint_add_digit(K, bigint_res, radix, new_digit);
}
@@ -435,6 +445,7 @@ TValue ktok_read_number(klisp_State *K, char *buf, int32_t len,
} else {
if (!is_pos)
kbigint_invert_sign(K, bigint_res);
+ krooted_vars_pop(K);
return bigint_res;
}
}
@@ -447,11 +458,13 @@ TValue ktok_read_maybe_signed_numeric(klisp_State *K)
ks_tbadd(K, ch);
ks_tbadd(K, '\0');
TValue new_sym = ksymbol_new_i(K, ks_tbget_buffer(K), 1);
- ks_tbclear(K);
+ krooted_tvs_push(K, new_sym);
+ ks_tbclear(K); /* this shouldn't cause gc, but just in case */
+ krooted_tvs_pop(K);
return new_sym;
} else {
ks_tbadd(K, ch);
- int32_t buf_len = ktok_read_until_delimiter(K);
+ int32_t buf_len = ktok_read_until_delimiter(K)+1;
char *buf = ks_tbget_buffer(K);
/* no exactness or radix prefix, default radix: 10 */
return ktok_read_number(K, buf, buf_len, false, false, false, 10);
@@ -508,8 +521,10 @@ TValue ktok_read_string(klisp_State *K)
i++;
}
}
- TValue new_str = kstring_new(K, ks_tbget_buffer(K), i);
- ks_tbclear(K);
+ TValue new_str = kstring_new(K, ks_tbget_buffer(K), i);
+ krooted_tvs_push(K, new_str);
+ ks_tbclear(K); /* shouldn't cause gc, but still */
+ krooted_tvs_pop(K);
return new_str;
}
@@ -744,7 +759,9 @@ TValue ktok_read_identifier(klisp_State *K)
}
ks_tbadd(K, '\0');
TValue new_sym = ksymbol_new_i(K, ks_tbget_buffer(K), i-1);
- ks_tbclear(K);
+ krooted_tvs_push(K, new_sym);
+ ks_tbclear(K); /* this shouldn't cause gc, but just in case */
+ krooted_tvs_pop(K);
return new_sym;
}
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -43,11 +43,16 @@ void kw_print_bigint(klisp_State *K, TValue bigint)
int32_t size = kbigint_print_size(bigint, 10) +
((kbigint_negativep(bigint))? 1 : 0);
+ krooted_tvs_push(K, bigint);
TValue buf_str = kstring_new_g(K, size);
+ krooted_tvs_push(K, buf_str);
+
/* write backwards so we can use printf later */
char *buf = kstring_buf(buf_str) + size - 1;
- /* GC: root copy */
+
TValue copy = kbigint_copy(K, bigint);
+ krooted_vars_push(K, ©);
+
/* must work with positive bigint to get the digits */
if (kbigint_negativep(bigint))
kbigint_invert_sign(K, copy);
@@ -62,8 +67,10 @@ void kw_print_bigint(klisp_State *K, TValue bigint)
*buf-- = '-';
kw_printf(K, "%s", buf+1);
- /* MAYBE: we could free the copy & string instead of letting the
- gc do it */
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_vars_pop(K);
}
/*
@@ -113,9 +120,9 @@ void kw_print_string(klisp_State *K, TValue str)
/*
** Mark initialization and clearing
*/
+/* GC: root is rooted */
void kw_clear_marks(klisp_State *K, TValue root)
{
-
assert(ks_sisempty(K));
push_data(K, root);
@@ -146,7 +153,7 @@ void kw_clear_marks(klisp_State *K, TValue root)
** - The objects that appear only once are marked with a #t to
** find repetitions and to allow unmarking after write
*/
-
+/* GC: root is rooted */
void kw_set_initial_marks(klisp_State *K, TValue root)
{
assert(ks_sisempty(K));
@@ -276,6 +283,7 @@ void kwrite_simple(klisp_State *K, TValue obj)
}
+/* GC: obj is rooted */
void kwrite_fsm(klisp_State *K, TValue obj)
{
/* NOTE: a fixint is more than enough for output */
@@ -367,10 +375,15 @@ void kwrite_fsm(klisp_State *K, TValue obj)
*/
void kwrite(klisp_State *K, TValue obj)
{
+ /* GC: root obj */
+ krooted_tvs_push(K, obj);
+
kw_set_initial_marks(K, obj);
kwrite_fsm(K, obj);
kw_flush(K);
kw_clear_marks(K, obj);
+
+ krooted_tvs_pop(K);
}
void kwrite_newline(klisp_State *K)
