commit 8fa3393714a288ee551677ffc56f3283012a2ec3
parent 45618126610235b0c40d2cb2000345b9f0c59965
Author: Andres Navarro <canavarro82@gmail.com>
Date: Tue, 15 Mar 2011 16:52:23 -0300
Added interception code for continuations. Basic functionality working but it isn't tested yet.
Diffstat:
3 files changed, 177 insertions(+), 7 deletions(-)
diff --git a/src/Makefile b/src/Makefile
@@ -51,7 +51,7 @@ kwrite.o: kwrite.c kwrite.h kobject.h kpair.h kstring.h kstate.h kerror.h \
klisp.h
kstate.o: kstate.c kstate.h klisp.h kobject.h kmem.h kstring.h klisp.h \
kground.h kenvironment.h kpair.h keval.h koperative.h kground.h \
- krepl.h
+ krepl.h kcontinuation.h
kmem.o: kmem.c kmem.h klisp.h kerror.h klisp.h
kerror.o: kerror.c kerror.h klisp.h kstate.h klisp.h kmem.h kstring.h
kauxlib.o: kauxlib.c kauxlib.h klisp.h kstate.h klisp.h
diff --git a/src/kgcontinuations.c b/src/kgcontinuations.c
@@ -116,7 +116,9 @@ inline TValue check_copy_single_entry(klisp_State *K, char *name,
}
/* GC: save intermediate pair */
- return kcons(K, cont, kcons(K, app, KNIL));
+ /* save the operative directly, don't waste space/time
+ with a list, use just a pair */
+ return kcons(K, cont, kunwrap(app));
}
/* the guards are probably generated on the spot so we don't check
@@ -156,7 +158,6 @@ TValue check_copy_guards(klisp_State *K, char *name, TValue obj)
void guard_continuation(klisp_State *K, TValue *xparams, TValue ptree,
TValue denv)
{
- UNUSED(denv);
UNUSED(xparams);
bind_3tp(K, "guard-continuation", ptree, "any", anytype, entry_guards,
@@ -169,11 +170,11 @@ void guard_continuation(klisp_State *K, TValue *xparams, TValue ptree,
exit_guards);
TValue outer_cont = kmake_continuation(K, cont, KNIL, KNIL, pass_value,
- 1, entry_guards);
+ 2, entry_guards, denv);
/* mark it as an outer continuation */
kset_outer_cont(outer_cont);
TValue inner_cont = kmake_continuation(K, outer_cont, KNIL, KNIL,
- pass_value, 1, exit_guards);
+ pass_value, 2, exit_guards, denv);
/* mark it as an outer continuation */
kset_inner_cont(inner_cont);
kapply_cc(K, inner_cont);
diff --git a/src/kstate.c b/src/kstate.c
@@ -19,6 +19,7 @@
#include "kmem.h"
#include "keval.h"
#include "koperative.h"
+#include "kcontinuation.h"
#include "kenvironment.h"
#include "kground.h"
#include "krepl.h"
@@ -120,13 +121,181 @@ klisp_State *klisp_newstate (klisp_Alloc f, void *ud) {
return K;
}
+/*
+**
+** This is for handling interceptions
+** TODO: move to a different file
+**
+*/
+
+/*
+** This is used to determine if cont is in the dynamic extent of
+** some other continuation. That's the case iff that continuation
+** was marked by the call to mark_iancestors(cont)
+*/
+
+/* TODO: maybe add some inlines here, profile first and check size difference */
+void mark_iancestors(TValue cont)
+{
+ while(!ttisnil(cont)) {
+ kmark(cont);
+ cont = tv2cont(cont)->parent;
+ }
+}
+
+void unmark_iancestors(TValue cont)
+{
+ while(!ttisnil(cont)) {
+ kunmark(cont);
+ cont = tv2cont(cont)->parent;
+ }
+}
+
+/*
+** Returns the first interceptor whose dynamic extent includes cont
+** or nil if there isn't any. The cont is implicitly passed because
+** all of its improper ancestors are marked.
+*/
+TValue select_interceptor(TValue guard_ls)
+{
+ /* the guard list can't be cyclic, that case is
+ replaced by a simple list while copyng guards */
+ while(!ttisnil(guard_ls)) {
+ /* entry is (selector . interceptor-op) */
+ TValue entry = kcar(guard_ls);
+ TValue selector = kcar(entry);
+ if (kis_marked(selector))
+ return kcdr(entry); /* only interceptor is important */
+ guard_ls = kcdr(guard_ls);
+ }
+ return KNIL;
+}
+
+/*
+** 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,
+ TValue dst_cont)
+{
+ /* GC: root intermediate pairs */
+ mark_iancestors(dst_cont);
+ TValue dummy = kcons(K, KINERT, KNIL);
+ TValue tail = dummy;
+ TValue cont = src_cont;
+
+ /* exit guards are from the inside to the outside, and
+ selected by destination */
+
+ /* the loop is until we find the common ancestor, that has to be marked */
+ while(!kis_marked(cont)) {
+ /* only inner conts have exit guards */
+ if (kis_inner_cont(cont)) {
+ TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */
+
+ TValue interceptor = select_interceptor(entries);
+ if (!ttisnil(interceptor)) {
+ /* 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 new_pair = kcons(K, new_entry, KNIL);
+ kset_cdr(tail, new_pair);
+ tail = new_pair;
+ }
+ }
+ cont = tv2cont(cont)->parent;
+ }
+ unmark_iancestors(dst_cont);
+
+ /* entry guards are from the outside to the inside, and
+ selected by source, we create the list from the outside
+ by cons and then append it to the exit list to avoid
+ reversing */
+ mark_iancestors(src_cont);
+
+ cont = dst_cont;
+ TValue entry_int = KNIL;
+
+ while(!kis_marked(cont)) {
+ /* only outer conts have entry guards */
+ if (kis_outer_cont(cont)) {
+ TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */
+ TValue interceptor = select_interceptor(entries);
+ if (!ttisnil(interceptor)) {
+ /* TODO make macros */
+ TValue denv = tv2cont(cont)->extra[1];
+ TValue outer = cont;
+ TValue new_entry = kcons(K, interceptor,
+ kcons(K, outer, denv));
+ entry_int = kcons(K, new_entry, entry_int);
+ }
+ }
+ cont = tv2cont(cont)->parent;
+ }
+
+ unmark_iancestors(src_cont);
+
+ /* all interceptions collected, append the two lists and return */
+ kset_cdr(tail, entry_int);
+ return kcdr(dummy);
+}
+
+void do_interception(klisp_State *K, TValue *xparams, TValue obj)
+{
+ /*
+ ** xparams[0]:
+ ** xparams[1]: dst cont
+ */
+ TValue ls = xparams[0];
+ if (ttisnil(ls)) {
+ /* all interceptors returned normally */
+ TValue dst_cont = xparams[1];
+ /* TODO: this is the same code as the standard case of
+ call_cont, merge */
+ Continuation *cont = tv2cont(dst_cont);
+ K->next_func = cont->fn;
+ K->next_value = obj;
+ /* NOTE: this is needed to differentiate a return from a tail call */
+ K->next_env = KNIL;
+ K->next_xparams = cont->extra;
+ K->curr_cont = cont->parent;
+
+ longjmp(K->error_jb, 1);
+ } else {
+ TValue first = kcar(ls);
+ TValue op = kcar(first);
+ TValue outer = kcadr(first);
+ TValue denv = kcddr(first);
+ /* call the operative with the passed obj as ptree in
+ the dynamic environment of the corresponding call
+ to guard-continuation in the dynamic extent of the
+ associated outer continuation */
+ kset_cc(K, outer);
+ ktail_call(K, op, obj, 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 */
void kcall_cont(klisp_State *K, TValue dst_cont, TValue obj)
{
- /* TODO: interceptions */
- Continuation *cont = tv2cont(dst_cont);
+ TValue src_cont = kget_cc(K);
+ TValue int_ls = create_interception_list(K, src_cont, dst_cont);
+ TValue new_cont;
+ if (ttisnil(int_ls)) {
+ new_cont = dst_cont; /* no interceptions */
+ } else {
+ /* 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);
+
+ }
+ Continuation *cont = tv2cont(new_cont);
K->next_func = cont->fn;
K->next_value = obj;
/* NOTE: this is needed to differentiate a return from a tail call */
