commit ef556787976bb4372172b6573797efaf0c75f5f1
parent 2bc2c7c73f76a36c715c90584cdd080dd8fa8eb3
Author: Andres Navarro <canavarro82@gmail.com>
Date: Sat, 16 Apr 2011 22:18:08 -0300
branched bugfix to klist
Diffstat:
44 files changed, 734 insertions(+), 423 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -60,8 +60,8 @@ 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 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
+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 kgc.h
diff --git a/src/kcontinuation.c b/src/kcontinuation.c
@@ -12,54 +12,30 @@
#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, ...)
+TValue kmake_continuation(klisp_State *K, TValue parent, 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);
/* 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;
- /* 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/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
@@ -11,27 +11,17 @@
#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)
{
- 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);
/* 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/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/keval.c b/src/keval.c
@@ -39,9 +39,8 @@ void eval_ls_cfn(klisp_State *K, TValue *xparams, TValue obj)
} 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);
+ 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);
}
@@ -111,13 +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);
- TValue comb_cont = kmake_continuation(
- K, kget_cc(K), KNIL, KNIL, &combine_cfn, 2, arg_ls, env);
+ krooted_tvs_push(K, arg_ls);
+ TValue comb_cont = kmake_continuation(K, kget_cc(K), &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");
@@ -135,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
@@ -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
@@ -148,9 +148,8 @@ 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 */
krooted_tvs_push(K, ls);
- TValue new_cont =
- kmake_continuation(K, kget_cc(K), KNIL, KNIL, do_Sandp_Sorp,
- 4, sname, term_bool, ls, denv);
+ 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 */
diff --git a/src/kgc.c b/src/kgc.c
@@ -18,6 +18,10 @@
#include "kport.h"
#include "imath.h"
+/* XXX */
+#include "kwrite.h"
+/* XXX */
+
#define GCSTEPSIZE 1024u
#define GCSWEEPMAX 40
#define GCSWEEPCOST 10
@@ -50,12 +54,12 @@
TValue *array_ = (a); \
int32_t size_ = (s); \
for(int32_t i_ = 0; i_ < size_; i_++, array_++) { \
- TValue o_ = *array_; \
- markvalue(k, o_); \
+ TValue mva_obj_ = *array_; \
+ markvalue(k, mva_obj_); \
}})
-#define markvalue(k,o) { checkconsistency(o); \
- if (iscollectable(o) && iswhite(gcvalue(o))) \
+#define markvalue(k,o) { checkconsistency(o); \
+ if (iscollectable(o) && iswhite(gcvalue(o))) \
reallymarkobject(k,gcvalue(o)); }
#define markobject(k,t) { if (iswhite(obj2gco(t))) \
@@ -232,6 +236,7 @@ static void traverseproto (global_State *g, Proto *f) {
*/
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;
@@ -700,7 +705,6 @@ void klispC_step (klisp_State *K) {
}
}
-
void klispC_fullgc (klisp_State *K) {
if (K->gcstate <= GCSpropagate) {
/* reset sweep marks to sweep all elements (returning them to white) */
diff --git a/src/kgcombiners.c b/src/kgcombiners.c
@@ -93,7 +93,7 @@ void do_vau(klisp_State *K, TValue *xparams, TValue obj, TValue denv)
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);
}
@@ -449,7 +449,7 @@ void do_map(klisp_State *K, TValue *xparams, TValue obj)
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);
@@ -478,7 +478,7 @@ 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);
@@ -486,7 +486,7 @@ void do_map_cycle(klisp_State *K, TValue *xparams, TValue obj)
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);
@@ -532,8 +532,8 @@ void map(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
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);
@@ -543,7 +543,7 @@ void map(klisp_State *K, TValue *xparams, TValue ptree, TValue denv)
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);
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,30 +171,39 @@ 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 */
+ /* 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);
}
@@ -234,7 +247,8 @@ void Slet_cc(klisp_State *K, TValue *xparams, TValue ptree,
} else {
TValue new_env = kmake_environment(K, denv);
- /* add binding may allocate, protect env */
+ /* 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));
@@ -242,16 +256,17 @@ void Slet_cc(klisp_State *K, TValue *xparams, TValue ptree,
/* 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);
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);
}
}
@@ -268,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);
+ 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
@@ -97,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
@@ -230,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
@@ -88,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;
@@ -127,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;
}
}
@@ -183,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);
}
@@ -191,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);
}
@@ -213,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? */
@@ -262,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);
}
@@ -306,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);
}
}
@@ -340,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* */
@@ -364,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);
}
}
@@ -408,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);
}
@@ -427,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);
}
@@ -451,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 */
@@ -473,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);
@@ -515,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,
diff --git a/src/kghelpers.h b/src/kghelpers.h
@@ -234,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);
@@ -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);
}
/*
@@ -394,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, do_set_pass,
3, key, old_flag, old_value);
- TValue entry_int = kmake_operative(K, 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);
+ 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);
- TValue ls = kcons(K, b, kcons(K, a, KNIL));
+ 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
@@ -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);
+ 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);
- TValue ls = kcons(K, b, kcons(K, a, KNIL));
+ 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,15 +900,15 @@ 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);
}
@@ -964,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);
@@ -980,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);
- TValue args = kcons(K, new_port, kcons(K, comb, KNIL));
+ krooted_tvs_push(K, op);
+
+ TValue args = klist(K, 2, new_port, comb);
+
+ krooted_tvs_pop(K);
+
/* 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, 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/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
@@ -67,7 +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 */
-/* assumes tv_bigint is rooted */
+/* GC: Assumes tv_bigint is rooted */
void kbigint_add_digit(klisp_State *K, TValue tv_bigint, int32_t base,
int32_t digit)
{
@@ -78,7 +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 */
-/* assumes tv_bigint is rooted */
+/* GC: Assumes tv_bigint is rooted */
int32_t kbigint_remove_digit(klisp_State *K, TValue tv_bigint, int32_t base)
{
UNUSED(K);
@@ -97,7 +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*/
-/* assumes tv_bigint is rooted */
+/* GC: Assumes tv_bigint is rooted */
void kbigint_invert_sign(klisp_State *K, TValue tv_bigint)
{
Bigint *bigint = tv2bigint(tv_bigint);
diff --git a/src/klispconf.h b/src/klispconf.h
@@ -13,6 +13,10 @@
#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)
@@ -30,7 +34,10 @@
** mean larger pauses which mean slower collection.) You can also change
** this value dynamically.
*/
-#define KLISPI_GCPAUSE 200 /* 200% (wait memory to double before next GC) */
+
+/* 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) */
/*
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,7 +45,21 @@
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 */
diff --git a/src/kobject.h b/src/kobject.h
@@ -209,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)
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));
diff --git a/src/kport.c b/src/kport.c
@@ -20,8 +20,9 @@
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");
@@ -29,22 +30,18 @@ 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)
{
- krooted_tvs_push(K, filename);
- krooted_tvs_push(K, name);
- krooted_tvs_push(K, si);
Port *new_port = klispM_new(K, Port);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
/* header + gc_fields */
klispC_link(K, (GCObject *) new_port, K_TPORT,
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
@@ -11,25 +11,17 @@
#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)
{
- krooted_tvs_push(K, name);
- krooted_tvs_push(K, si);
- krooted_tvs_push(K, exp);
- krooted_tvs_push(K, maybe_env);
Promise *new_prom = klispM_new(K, Promise);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
- krooted_tvs_pop(K);
/* header + gc_fields */
klispC_link(K, (GCObject *) new_prom, K_TPROMISE, 0);
/* promise specific fields */
- new_prom->name = name;
- new_prom->si = si;
+ new_prom->name = KNIL;
+ new_prom->si = KNIL;
new_prom->node = KNIL; /* temp in case of GC */
krooted_tvs_push(K, gc2prom(new_prom));
new_prom->node = kcons(K, exp, maybe_env);
diff --git a/src/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
@@ -117,8 +117,10 @@ void try_shared_def(klisp_State *K, TValue def_token, TValue value)
tail = kcdr(tail);
}
- K->shared_dict = kcons(K, kcons(K, kcdr(def_token), value),
- K->shared_dict); /* value is protected by cons */
+ 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;
}
@@ -417,12 +419,14 @@ TValue kread_fsm(klisp_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;
}
@@ -462,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,18 +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 rooted */
+/* GC: assumes denv is NOT 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(
- 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);
}
@@ -121,19 +122,13 @@ 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 root_cont = kmake_continuation(K, 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);
-
-
+ 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 */
@@ -151,8 +146,8 @@ void kinit_repl(klisp_State *K)
krooted_tvs_pop(K);
krooted_tvs_pop(K);
+ krooted_tvs_pop(K);
- /* don't yet pop std_env */
+ /* GC: create_loop will root std_env */
create_loop(K, std_env);
- krooted_tvs_pop(K);
}
diff --git a/src/kstate.c b/src/kstate.c
@@ -304,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
@@ -328,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;
}
@@ -347,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 */
@@ -357,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;
@@ -369,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 */
@@ -406,18 +416,19 @@ void do_interception(klisp_State *K, TValue *xparams, TValue obj)
TValue outer = kcadr(first);
TValue denv = kcddr(first);
TValue app = kmake_applicative(K, 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);
+ 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);
@@ -426,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);
}
/*
diff --git a/src/kstate.h b/src/kstate.h
@@ -341,6 +341,9 @@ 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;
@@ -370,6 +373,9 @@ 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;
diff --git a/src/ksymbol.c b/src/ksymbol.c
@@ -50,7 +50,9 @@ TValue ksymbol_new_g(klisp_State *K, const char *buf, int32_t size,
new_sym->str = new_str;
TValue new_symv = gc2sym(new_sym);
+ krooted_tvs_push(K, new_symv);
K->symbol_table = kcons(K, new_symv, K->symbol_table);
+ krooted_tvs_pop(K);
return new_symv;
}
@@ -68,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,9 +107,7 @@ TValue ksymbol_new_check_i(klisp_State *K, TValue str)
size = kstring_size(str);
buf = kstring_buf(str);
- krooted_tvs_push(K, str);
TValue new_sym = ksymbol_new_g(K, buf, size, identifierp);
- krooted_tvs_pop(K);
return new_sym;
}
diff --git a/src/ktoken.c b/src/ktoken.c
@@ -192,9 +192,11 @@ TValue ktok_get_source_info(klisp_State *K)
strlen(K->ktok_source_info.saved_filename));
krooted_tvs_push(K, filename_str);
/* TEMP: for now, lines and column names are fixints */
- TValue res = kcons(K, 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;
}
diff --git a/src/kwrite.c b/src/kwrite.c
@@ -49,7 +49,6 @@ void kw_print_bigint(klisp_State *K, TValue bigint)
/* write backwards so we can use printf later */
char *buf = kstring_buf(buf_str) + size - 1;
- krooted_tvs_push(K, buf_str);
TValue copy = kbigint_copy(K, bigint);
krooted_vars_push(K, ©);
@@ -69,9 +68,9 @@ void kw_print_bigint(klisp_State *K, TValue bigint)
kw_printf(K, "%s", buf+1);
- krooted_vars_pop(K);
krooted_tvs_pop(K);
krooted_tvs_pop(K);
+ krooted_vars_pop(K);
}
/*
