commit bf766979a05a3f2816234b856e556444804cd2cc
parent 2486a8a3ab3fa279ed79ee9f6db4b13b64d58014
Author: Andres Navarro <canavarro82@gmail.com>
Date: Fri, 15 Apr 2011 16:46:19 -0300
Started adding temporary rooting of objects during allocations.
Diffstat:
9 files changed, 144 insertions(+), 28 deletions(-)
diff --git a/src/kapplicative.c b/src/kapplicative.c
@@ -18,7 +18,13 @@ TValue kwrap(klisp_State *K, TValue underlying)
TValue kmake_applicative(klisp_State *K, TValue name, TValue si,
TValue underlying)
{
+ krooted_tvs_push(K, name);
+ krooted_tvs_push(K, si);
+ krooted_tvs_push(K, underlying);
Applicative *new_app = klispM_new(K, Applicative);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
/* header + gc_fields */
klispC_link(K, (GCObject *) new_app, K_TAPPLICATIVE, 0);
diff --git a/src/kcontinuation.c b/src/kcontinuation.c
@@ -12,13 +12,43 @@
#include "kmem.h"
#include "kgc.h"
+/* should be at least < GC_PROTECT_SIZE - 3 */
+#define CONT_MAX_ARGS 16
+
TValue kmake_continuation(klisp_State *K, TValue parent, TValue name,
TValue si, klisp_Cfunc fn, int32_t xcount, ...)
{
va_list argp;
+
+ klisp_assert(xcount < CONT_MAX_ARGS);
+
+ TValue args[CONT_MAX_ARGS];
+ va_start(argp, xcount);
+ for (int i = 0; i < xcount; i++) {
+ TValue val = va_arg(argp, TValue);
+ krooted_tvs_push(K, val);
+ args[i] = val;
+ }
+ va_end(argp);
+
+ krooted_tvs_push(K, parent);
+ krooted_tvs_push(K, name);
+ krooted_tvs_push(K, si);
+
Continuation *new_cont = (Continuation *)
klispM_malloc(K, sizeof(Continuation) + sizeof(TValue) * xcount);
+
+ for (int i = 0; i < xcount; i++) {
+ TValue val = args[i];
+ new_cont->extra[i] = val;
+ krooted_tvs_pop(K);
+ }
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
/* header + gc_fields */
klispC_link(K, (GCObject *) new_cont, K_TCONTINUATION, 0);
@@ -29,11 +59,7 @@ TValue kmake_continuation(klisp_State *K, TValue parent, TValue name,
new_cont->parent = parent;
new_cont->fn = fn;
new_cont->extra_size = xcount;
+ /* new_cont->extra was already set */
- va_start(argp, xcount);
- for (int i = 0; i < xcount; i++) {
- new_cont->extra[i] = va_arg(argp, TValue);
- }
- va_end(argp);
return gc2cont(new_cont);
}
diff --git a/src/kencapsulation.c b/src/kencapsulation.c
@@ -14,8 +14,18 @@
TValue kmake_encapsulation(klisp_State *K, TValue name, TValue si,
TValue key, TValue val)
{
+ krooted_tvs_push(K, name);
+ krooted_tvs_push(K, si);
+ krooted_tvs_push(K, key);
+ krooted_tvs_push(K, val);
+
Encapsulation *new_enc = klispM_new(K, Encapsulation);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
/* header + gc_fields */
klispC_link(K, (GCObject *) new_enc, K_TENCAPSULATION, 0);
diff --git a/src/kenvironment.c b/src/kenvironment.c
@@ -26,17 +26,23 @@
/* TEMP: for now allow only a single parent */
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);
/* 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;
@@ -46,9 +52,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);
@@ -67,14 +72,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);
}
@@ -106,9 +111,10 @@ 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 */
+ 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);
}
@@ -118,6 +124,8 @@ void kadd_binding(klisp_State *K, TValue env, TValue sym, TValue val)
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);
@@ -133,6 +141,8 @@ 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);
@@ -144,6 +154,10 @@ inline bool try_get_binding(klisp_State *K, TValue env, TValue sym,
pushed += 2;
}
}
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
*value = KINERT;
return false;
}
@@ -172,14 +186,23 @@ bool kbinds(klisp_State *K, TValue env, TValue sym)
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;
}
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 */
@@ -199,6 +222,8 @@ 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);
@@ -211,6 +236,8 @@ 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/kerror.c b/src/kerror.c
@@ -8,6 +8,10 @@
#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 +19,10 @@ 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? */
+ K->rooted_tvs_top = 0;
+ K->rooted_vars_top = 0;
}
void klispE_throw(klisp_State *K, char *msg)
@@ -37,7 +45,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,6 +38,7 @@ void eval_ls_cfn(klisp_State *K, TValue *xparams, TValue obj)
kapply_cc(K, combiner);
} else {
/* more arguments need to be evaluated */
+ /* GC: all objects are rooted at this point */
TValue new_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL,
&eval_ls_cfn, 4, rest, env,
tail, combiner);
@@ -55,10 +56,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 +74,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,7 +111,6 @@ 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);
-
TValue comb_cont = kmake_continuation(
K, kget_cc(K), KNIL, KNIL, &combine_cfn, 2, arg_ls, env);
diff --git a/src/kground.c b/src/kground.c
@@ -45,22 +45,30 @@
** "value", both of type TValue. symbol will be bound to a symbol named by
** "n_" and can be referrenced in the var_args
*/
-#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); }
+
+/* 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 = make_operative(K_, fn_, __VA_ARGS__); \
+ krooted_tvs_pop(K); \
+ 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); }
+ { symbol = ksymbol_new(K_, n_); \
+ krooted_tvs_push(K, symbol); \
+ value = make_applicative(K_, fn_, __VA_ARGS__); \
+ krooted_tvs_pop(K); \
+ kadd_binding(K_, env_, symbol, value); }
/*
** 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;
/*
diff --git a/src/koperative.c b/src/koperative.c
@@ -12,13 +12,40 @@
#include "kmem.h"
#include "kgc.h"
+/* should be at least < GC_PROTECT_SIZE - 3 */
+#define OP_MAX_ARGS 16
+
TValue kmake_operative(klisp_State *K, TValue name, TValue si,
klisp_Ofunc fn, int32_t xcount, ...)
{
va_list argp;
+
+ klisp_assert(xcount < OP_MAX_ARGS);
+
+ TValue args[OP_MAX_ARGS];
+ va_start(argp, xcount);
+ for (int i = 0; i < xcount; i++) {
+ TValue val = va_arg(argp, TValue);
+ krooted_tvs_push(K, val);
+ args[i] = val;
+ }
+ va_end(argp);
+
+ krooted_tvs_push(K, name);
+ krooted_tvs_push(K, si);
+
Operative *new_op = (Operative *)
klispM_malloc(K, sizeof(Operative) + sizeof(TValue) * xcount);
+ for (int i = 0; i < xcount; i++) {
+ TValue val = args[i];
+ new_op->extra[i] = val;
+ krooted_tvs_pop(K);
+ }
+
+ krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
+
/* header + gc_fields */
klispC_link(K, (GCObject *) new_op, K_TOPERATIVE, 0);
diff --git a/src/kstate.h b/src/kstate.h
@@ -34,8 +34,7 @@ typedef struct {
int32_t saved_col;
} ksource_info_t;
-/* We would probably do with 3 or 4, but have a little extra just in case */
-#define GC_PROTECT_SIZE 16
+#define GC_PROTECT_SIZE 32
/* NOTE: when adding TValues here, remember to add them to
markroot in kgc.c!! */
