klisp

an open source interpreter for the Kernel Programming Language.
git clone http://git.hanabi.in/repos/klisp.git
Log | Files | Refs | README

kcontinuation.c (7896B)


      1 /*
      2 ** kcontinuation.c
      3 ** Kernel Continuations
      4 ** See Copyright Notice in klisp.h
      5 */
      6 
      7 #include <stdarg.h>
      8 
      9 #include "kcontinuation.h"
     10 #include "kpair.h"
     11 #include "kapplicative.h"
     12 #include "kobject.h"
     13 #include "kstate.h"
     14 #include "kmem.h"
     15 #include "kgc.h"
     16 
     17 TValue kmake_continuation(klisp_State *K, TValue parent, klisp_CFunction fn, 
     18                           int32_t xcount, ...)
     19 {
     20     va_list argp;
     21 
     22     Continuation *new_cont = (Continuation *)
     23         klispM_malloc(K, sizeof(Continuation) + sizeof(TValue) * xcount);
     24 
     25     /* header + gc_fields */
     26     klispC_link(K, (GCObject *) new_cont, K_TCONTINUATION, 
     27                 K_FLAG_CAN_HAVE_NAME);
     28 
     29 
     30     /* continuation specific fields */
     31     new_cont->mark = KFALSE;    
     32     new_cont->parent = parent;
     33 
     34     TValue comb = K->next_obj;
     35     if (ttiscontinuation(comb))
     36         comb = tv2cont(comb)->comb;
     37     new_cont->comb = comb;
     38 
     39     new_cont->fn = fn;
     40     new_cont->extra_size = xcount;
     41 
     42     va_start(argp, xcount);
     43     for (int i = 0; i < xcount; i++) {
     44         new_cont->extra[i] = va_arg(argp, TValue);
     45     }
     46     va_end(argp);
     47 
     48     TValue res = gc2cont(new_cont);
     49     /* Add the current source info as source info (may be changed later) */
     50     /* TODO: find all the places where this should be changed (like $and?, 
     51        $sequence), and change it */
     52     kset_source_info(K, res, kget_csi(K));
     53     return res;
     54 }
     55 
     56 /*
     57 **
     58 ** Interception Handling
     59 **
     60 */
     61 
     62 /* Helper for continuation->applicative */
     63 /* this passes the operand tree to the continuation */
     64 void cont_app(klisp_State *K)
     65 {
     66     TValue *xparams = K->next_xparams;
     67     TValue ptree = K->next_value;
     68     TValue denv = K->next_env;
     69     klisp_assert(ttisenvironment(K->next_env));
     70     UNUSED(denv);
     71     TValue cont = xparams[0];
     72     /* guards and dynamic variables are handled in kcall_cont() */
     73     kcall_cont(K, cont, ptree);
     74 }
     75 
     76 /* 
     77 ** This is used to determine if cont is in the dynamic extent of
     78 ** some other continuation. That's the case iff that continuation
     79 ** was marked by the call to mark_iancestors(cont) 
     80 */
     81 
     82 /* TODO: maybe add some inlines here, profile first and check size difference */
     83 /* LOCK: GIL should be acquired */
     84 static void mark_iancestors(TValue cont) 
     85 {
     86     while(!ttisnil(cont)) {
     87         kmark(cont);
     88         cont = tv2cont(cont)->parent;
     89     }
     90 }
     91 
     92 /* LOCK: GIL should be acquired */
     93 static void unmark_iancestors(TValue cont) 
     94 {
     95     while(!ttisnil(cont)) {
     96         kunmark(cont);
     97         cont = tv2cont(cont)->parent;
     98     }
     99 }
    100 
    101 /* 
    102 ** Returns the first interceptor whose dynamic extent includes cont
    103 ** or nil if there isn't any. The cont is implicitly passed because
    104 ** all of its improper ancestors are marked.
    105 */   
    106 /* LOCK: GIL should be acquired */
    107 static TValue select_interceptor(TValue guard_ls)
    108 {
    109     /* the guard list can't be cyclic, that case is 
    110        replaced by a simple list while copyng guards */
    111     while(!ttisnil(guard_ls)) {
    112         /* entry is (selector . interceptor-op) */
    113         TValue entry = kcar(guard_ls);
    114         TValue selector = kcar(entry);
    115         if (kis_marked(selector))
    116             return kcdr(entry); /* only interceptor is important */
    117         guard_ls = kcdr(guard_ls);
    118     }
    119     return KNIL;
    120 }
    121 
    122 /* 
    123 ** Returns a list of entries like the following:
    124 ** (interceptor-op outer_cont . denv)
    125 */
    126 
    127 /* GC: assume src_cont & dst_cont are rooted */
    128 TValue create_interception_list(klisp_State *K, TValue src_cont, 
    129                                        TValue dst_cont)
    130 {
    131     mark_iancestors(dst_cont);
    132     TValue ilist = kcons(K, KNIL, KNIL);
    133     krooted_vars_push(K, &ilist);
    134     TValue tail = ilist;
    135     TValue cont = src_cont;
    136 
    137     /* exit guards are from the inside to the outside, and
    138        selected by destination */
    139 
    140     /* the loop is until we find the common ancestor, that has to be marked */
    141     while(!kis_marked(cont)) {
    142         /* only inner conts have exit guards */
    143         if (kis_inner_cont(cont)) {
    144             klisp_assert(tv2cont(cont)->extra_size > 1);
    145             TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */ 
    146 
    147             TValue interceptor = select_interceptor(entries);
    148             if (!ttisnil(interceptor)) {
    149                 /* TODO make macros */
    150                 TValue denv = tv2cont(cont)->extra[1]; 
    151                 TValue outer = tv2cont(cont)->parent;
    152                 TValue outer_denv = kcons(K, outer, denv);
    153                 krooted_tvs_push(K, outer_denv);
    154                 TValue new_entry = kcons(K, interceptor, outer_denv);
    155                 krooted_tvs_pop(K); /* already in entry */
    156                 krooted_tvs_push(K, new_entry);
    157                 TValue new_pair = kcons(K, new_entry, KNIL);
    158                 krooted_tvs_pop(K);
    159                 kset_cdr(tail, new_pair);
    160                 tail = new_pair;
    161             }
    162         }
    163         cont = tv2cont(cont)->parent;
    164     }
    165     unmark_iancestors(dst_cont);
    166 
    167     /* entry guards are from the outside to the inside, and
    168        selected by source, we create the list from the outside
    169        by cons and then append it to the exit list to avoid
    170        reversing */
    171     mark_iancestors(src_cont);
    172 
    173     cont = dst_cont;
    174     TValue entry_int = KNIL;
    175     krooted_vars_push(K, &entry_int);
    176 
    177     while(!kis_marked(cont)) {
    178         /* only outer conts have entry guards */
    179         if (kis_outer_cont(cont)) {
    180             klisp_assert(tv2cont(cont)->extra_size > 1);
    181             TValue entries = tv2cont(cont)->extra[0]; /* TODO make a macro */
    182             /* this is rooted because it's a substructure of entries */
    183             TValue interceptor = select_interceptor(entries);
    184             if (!ttisnil(interceptor)) {
    185                 /* TODO make macros */
    186                 TValue denv = tv2cont(cont)->extra[1]; 
    187                 TValue outer = cont;
    188                 TValue outer_denv = kcons(K, outer, denv);
    189                 krooted_tvs_push(K, outer_denv);
    190                 TValue new_entry = kcons(K, interceptor, outer_denv);
    191                 krooted_tvs_pop(K); /* already in entry */
    192                 krooted_tvs_push(K, new_entry);
    193                 entry_int = kcons(K, new_entry, entry_int);
    194                 krooted_tvs_pop(K);
    195             }
    196         }
    197         cont = tv2cont(cont)->parent;
    198     }
    199 
    200     unmark_iancestors(src_cont);
    201     
    202     /* all interceptions collected, append the two lists and return */
    203     kset_cdr(tail, entry_int);
    204 
    205     krooted_vars_pop(K);
    206     krooted_vars_pop(K);
    207     return kcdr(ilist);
    208 }
    209 
    210 void do_interception(klisp_State *K)
    211 {
    212     TValue *xparams = K->next_xparams;
    213     TValue obj = K->next_value;
    214     klisp_assert(ttisnil(K->next_env));
    215     /* 
    216     ** xparams[0]: 
    217     ** xparams[1]: dst cont
    218     */
    219     TValue ls = xparams[0];
    220     TValue dst_cont = xparams[1];
    221     if (ttisnil(ls)) {
    222         /* all interceptors returned normally */
    223         /* this is a normal pass/not subject to interception */
    224         kset_cc(K, dst_cont);
    225         kapply_cc(K, obj);
    226     } else {
    227         /* call the operative with the passed obj and applicative
    228            for outer cont as ptree in the dynamic environment of 
    229            the corresponding call to guard-continuation in the 
    230            dynamic extent of the associated outer continuation.
    231            If the operative normally returns a value, others
    232            interceptions should be scheduled */
    233         TValue first = kcar(ls);
    234         TValue op = kcar(first);
    235         TValue outer = kcadr(first);
    236         TValue denv = kcddr(first);
    237         TValue app = kmake_applicative(K, cont_app, 1, outer);
    238         krooted_tvs_push(K, app);
    239         TValue ptree = klist(K, 2, obj, app);
    240         krooted_tvs_pop(K); /* already in ptree */
    241         krooted_tvs_push(K, ptree);
    242         TValue new_cont = kmake_continuation(K, outer, do_interception,
    243                                              2, kcdr(ls), dst_cont);
    244         kset_cc(K, new_cont);
    245         krooted_tvs_pop(K);
    246         /* XXX: what to pass as si? */
    247         ktail_call(K, op, ptree, denv);
    248     }
    249 }