commit e5470018c40ada14122090965ff1c25ef7ed20c3
parent 0af0483146e78e873be4820124965773f54dce9f
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sat, 16 Apr 2011 12:47:43 -0300
Added gc rooting to kgenv_mut. Modified check_copy_list to use dummy3. Added dummy cleaning on error throw.
Diffstat:
8 files changed, 67 insertions(+), 53 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -61,7 +61,7 @@ kstate.o: kstate.c kstate.h klisp.h kobject.h kmem.h kstring.h klisp.h \
krepl.h kcontinuation.h kapplicative.h kport.h ksymbol.h kport.h \
kstring.h kinteger.h kgc.h
kmem.o: kmem.c kmem.h klisp.h kerror.h klisp.h kstate.h
-kerror.o: kerror.c kerror.h klisp.h kstate.h klisp.h kmem.h kstring.h
+kerror.o: kerror.c kerror.h klisp.h kstate.h klisp.h kmem.h kstring.h kpair.h
kauxlib.o: kauxlib.c kauxlib.h klisp.h kstate.h klisp.h
kenvironment.o: kenvironment.c kenvironment.h kpair.h kobject.h kerror.h \
kmem.h kstate.h klisp.h kgc.h
diff --git a/src/kerror.c b/src/kerror.c
@@ -4,6 +4,7 @@
#include <stdlib.h>
#include "klisp.h"
+#include "kpair.h"
#include "kstate.h"
#include "kmem.h"
#include "kstring.h"
@@ -23,6 +24,11 @@ void clear_buffers(klisp_State *K)
/* 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)
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -100,7 +100,6 @@ inline TValue check_copy_single_entry(klisp_State *K, char *name,
if (!ttispair(obj) || !ttispair(kcdr(obj)) ||
!ttisnil(kcddr(obj))) {
unmark_list(K, root);
- UNUSED(kcutoff_dummy1(K));
klispE_throw_extra(K, name , ": Bad entry (expected "
"list of length 2)");
return KINERT;
@@ -110,13 +109,11 @@ inline TValue check_copy_single_entry(klisp_State *K, char *name,
if (!ttiscontinuation(cont)) {
unmark_list(K, root);
- UNUSED(kcutoff_dummy1(K));
klispE_throw_extra(K, name, ": Bad type on first element (expected "
"continuation)");
return KINERT;
} else if (!singly_wrapped(app)) {
unmark_list(K, root);
- UNUSED(kcutoff_dummy1(K));
klispE_throw_extra(K, name, ": Bad type on second element (expected "
"singly wrapped applicative)");
return KINERT;
@@ -295,22 +292,19 @@ void guard_dynamic_extent(klisp_State *K, TValue *xparams, TValue ptree,
TValue outer_cont = kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_pass_value,
1, entry_guards);
kset_outer_cont(outer_cont);
- krooted_tvs_push(K, outer_cont);
+ kset_cc(K, outer_cont); /* this implicitly roots outer_cont */
TValue inner_cont = kmake_continuation(K, outer_cont, KNIL, KNIL,
do_pass_value, 1, exit_guards);
kset_inner_cont(inner_cont);
- krooted_tvs_push(K, 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);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
ktail_eval(K, expr, denv);
}
diff --git a/src/kgcontrol.c b/src/kgcontrol.c
@@ -138,8 +138,6 @@ TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
TValue first = kcar(tail);
if (!ttispair(first)) {
unmark_list(K, clauses);
- UNUSED(kcutoff_dummy1(K));
- UNUSED(kcutoff_dummy2(K));
klispE_throw(K, "$cond: bad structure in clauses");
return KNIL;
}
@@ -165,36 +163,27 @@ TValue split_check_cond_clauses(klisp_State *K, TValue clauses,
unmark_list(K, clauses);
- TValue cars = kcutoff_dummy1(K);
- TValue cdrs = kcutoff_dummy2(K);
-
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw(K, "$cond: expected list (clauses)");
return KNIL;
} else {
- /* check copy list could throw an error
- and leave the dummys full, use tvs_push instead */
- krooted_tvs_push(K, cars);
- krooted_tvs_push(K, 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 = cdrs;
+ 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);
}
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- *bodies = cdrs;
- return cars;
+ *bodies = kcutoff_dummy2(K);
+ return kcutoff_dummy1(K);
}
}
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,
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,
sname, formals, eval_exp, denv);
kset_cc(K, new_cont);
+
+ krooted_tvs_pop(K);
ktail_eval(K, env_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)
@@ -200,21 +206,28 @@ 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,
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,
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
@@ -225,6 +238,9 @@ void SprovideB(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
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,
sname, symbols, denv);
kset_cc(K, new_cont);
+ krooted_tvs_pop(K);
ktail_eval(K, env_expr, denv);
}
diff --git a/src/kgenvironments.c b/src/kgenvironments.c
@@ -103,8 +103,6 @@ TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
if (!ttispair(first) || !ttispair(kcdr(first)) ||
!ttisnil(kcddr(first))) {
unmark_list(K, bindings);
- UNUSED(kcutoff_dummy1(K));
- UNUSED(kcutoff_dummy2(K));
klispE_throw_extra(K, name, ": bad structure in bindings");
return KNIL;
}
@@ -121,9 +119,6 @@ TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
unmark_list(K, bindings);
- TValue cars = kcutoff_dummy1(K);
- TValue cadrs = kcutoff_dummy2(K);
-
if (!ttispair(tail) && !ttisnil(tail)) {
klispE_throw_extra(K, name, ": expected list");
return KNIL;
@@ -131,29 +126,25 @@ TValue split_check_let_bindings(klisp_State *K, char *name, TValue bindings,
klispE_throw_extra(K, name , ": expected finite list");
return KNIL;
} else {
- /* check copy list could throw an error
- and leave the dummys full, use tvs_push instead */
- krooted_tvs_push(K, cars);
- krooted_tvs_push(K, cadrs);
-
- *exprs = 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 = 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 = kget_dummy1_tail(K);
} else {
/* all bindings are consider one ptree in these 'let's */
- cars = check_copy_ptree(K, name, cars, KIGNORE);
+ res = check_copy_ptree(K, name, kget_dummy1_tail(K), KIGNORE);
}
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- return cars;
+ *exprs = kcutoff_dummy2(K);
+ UNUSED(kcutoff_dummy1(K));
+ return res;
}
}
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -285,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)
{
@@ -293,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)) {
@@ -321,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)) {
@@ -353,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);
}
/*
diff --git a/src/kpair.h b/src/kpair.h
@@ -73,6 +73,12 @@ inline TValue kget_dummy1(klisp_State *K)
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));
@@ -87,6 +93,12 @@ inline TValue kget_dummy2(klisp_State *K)
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));
@@ -101,6 +113,12 @@ inline TValue kget_dummy3(klisp_State *K)
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));
