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 }