commit aadfff628e6096cc7954dbd621d1aa582da7dbb4
parent 95e1af6d08687295f30f0d4c8c04dfeb1e399031
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sat, 16 Apr 2011 09:42:03 -0300
Environment constructors no longer protect parent list, or key/value pairs. check_list & check_typed_list now accept a NULL pointer to indicate that cpairs is not needed. BUGFIX: rooted objs in kground macros, added add_value macro to add continuations.
Diffstat:
11 files changed, 85 insertions(+), 46 deletions(-)
diff --git a/src/kenvironment.c b/src/kenvironment.c
@@ -23,12 +23,11 @@
#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)
{
- krooted_tvs_push(K, parents);
Environment *new_env = klispM_new(K, Environment);
- krooted_tvs_pop(K);
/* header + gc_fields */
klispC_link(K, (GCObject *) new_env, K_TENVIRONMENT, 0);
@@ -106,26 +105,25 @@ 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)) {
- krooted_tvs_push(K, env); /* keep the env rooted */
TValue new_pair = kcons(K, sym, val);
kenv_bindings(K, env) = kcons(K, new_pair, kenv_bindings(K, env));
- krooted_tvs_pop(K);
} else {
kset_cdr(oldb, 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)
{
- krooted_tvs_push(K, env); /* keep the env rooted */
- krooted_tvs_push(K, sym); /* keep the sym rooted */
/* assume the stack may be in use, keep track of pushed objs */
int pushed = 1;
ks_spush(K, env);
@@ -141,8 +139,6 @@ inline bool try_get_binding(klisp_State *K, TValue env, TValue sym,
/* remember to leave the stack as it was */
ks_sdiscardn(K, pushed);
*value = kcdr(oldb);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
return true;
}
TValue parents = kenv_parents(K, obj);
@@ -155,9 +151,6 @@ inline bool try_get_binding(klisp_State *K, TValue env, TValue sym,
}
}
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
-
*value = KINERT;
return false;
}
@@ -183,26 +176,21 @@ 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)
{
- krooted_tvs_push(K, key); /* keep the key/val rooted */
- krooted_tvs_push(K, val);
TValue new_env = kmake_environment(K, parent);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
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)
{
- krooted_tvs_push(K, env); /* keep the env/key rooted */
- krooted_tvs_push(K, key);
-
/* MAYBE: this could be optimized to mark environments to avoid
repetition */
/* assume the stack may be in use, keep track of pushed objs */
@@ -222,8 +210,6 @@ inline bool try_get_keyed(klisp_State *K, TValue env, TValue key,
/* remember to leave the stack as it was */
ks_sdiscardn(K, pushed);
*value = env_keyed_val(obj);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
return true;
} else {
TValue parents = env_keyed_parents(obj);
@@ -236,8 +222,6 @@ inline bool try_get_keyed(klisp_State *K, TValue env, TValue key,
pushed += 2;
}
}
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
*value = KINERT;
return false;
}
diff --git a/src/kenvironment.h b/src/kenvironment.h
@@ -10,7 +10,6 @@
#include "kobject.h"
#include "kstate.h"
-/* TEMP: for now allow only a single parent */
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);
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--) {
@@ -147,6 +147,7 @@ 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 */
+ /* GC: ls is protected by make cont */
TValue new_cont =
kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_Sandp_Sorp,
4, sname, term_bool, ls, denv);
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -44,10 +44,15 @@ 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);
+
+ /* GC: root ptree while body is being copied */
+ krooted_tvs_push(K, vptree); /* make op will protect it now */
+
/* 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);
+
+ krooted_tvs_pop(K); /* make op will protect it now */
TValue new_op = make_operative(K, do_vau, 4, vptree, vpenv, vbody, denv);
kapply_cc(K, new_op);
@@ -68,10 +73,16 @@ 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);
+
+ /* match & add binding may allocate, 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);
+ krooted_tvs_pop(K); /* make cont will protect it now */
+
if (ttisnil(body)) {
kapply_cc(K, KINERT);
} else {
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -233,11 +233,17 @@ 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 */
+ 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);
+
+ krooted_tvs_pop(K); /* make cont will protect it now */
+
/* this is needed because seq continuation doesn't check for
nil sequence */
TValue tail = kcdr(ls);
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)
{
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);
}
}
diff --git a/src/kghelpers.c b/src/kghelpers.c
@@ -193,7 +193,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 +224,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/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);
}
diff --git a/src/kground.c b/src/kground.c
@@ -51,17 +51,30 @@
operand/applicative construction */
#define add_operative(K_, env_, n_, fn_, ...) \
{ symbol = ksymbol_new(K_, n_); \
- krooted_tvs_push(K, symbol); \
+ krooted_tvs_push(K_, symbol); \
value = make_operative(K_, fn_, __VA_ARGS__); \
- krooted_tvs_pop(K); \
- kadd_binding(K_, env_, symbol, value); }
+ 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); \
+ krooted_tvs_push(K_, symbol); \
value = make_applicative(K_, fn_, __VA_ARGS__); \
- krooted_tvs_pop(K); \
- kadd_binding(K_, env_, symbol, value); }
+ 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
@@ -530,14 +543,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/krepl.c b/src/krepl.c
@@ -69,8 +69,11 @@ 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 rooted */
inline void create_loop(klisp_State *K, TValue denv)
{
+ /* GC: the intermediate conts are protected by the
+ others */
TValue loop_cont = kmake_continuation(
K, K->root_cont, KNIL, KNIL, &loop_fn, 1, denv);
TValue eval_cont = kmake_continuation(
@@ -119,22 +122,37 @@ 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);
+
+ krooted_tvs_push(K, root_cont);
+
TValue error_cont = kmake_continuation(K, root_cont, KNIL, KNIL,
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);
+
+ /* don't yet pop std_env */
create_loop(K, std_env);
+ krooted_tvs_pop(K);
}
