kgcombiners.c (19426B)
1 /* 2 ** kgcombiners.c 3 ** Combiners features for the ground environment 4 ** See Copyright Notice in klisp.h 5 */ 6 7 #include <assert.h> 8 #include <stdio.h> 9 #include <stdlib.h> 10 #include <stdbool.h> 11 #include <stdint.h> 12 13 #include "kstate.h" 14 #include "kobject.h" 15 #include "kpair.h" 16 #include "kenvironment.h" 17 #include "kcontinuation.h" 18 #include "ksymbol.h" 19 #include "koperative.h" 20 #include "kapplicative.h" 21 #include "kerror.h" 22 23 #include "kghelpers.h" 24 #include "kgcombiners.h" 25 26 /* continuations */ 27 void do_vau(klisp_State *K); 28 29 void do_map(klisp_State *K); 30 void do_map_ret(klisp_State *K); 31 void do_map_encycle(klisp_State *K); 32 void do_map_cycle(klisp_State *K); 33 34 void do_array_map_ret(klisp_State *K); 35 36 /* 4.10.1 operative? */ 37 /* uses typep */ 38 39 /* 4.10.2 applicative? */ 40 /* uses typep */ 41 42 /* 4.10.3 $vau */ 43 /* 5.3.1 $vau */ 44 void Svau(klisp_State *K) 45 { 46 TValue *xparams = K->next_xparams; 47 TValue ptree = K->next_value; 48 TValue denv = K->next_env; 49 klisp_assert(ttisenvironment(K->next_env)); 50 (void) xparams; 51 bind_al2p(K, ptree, vptree, vpenv, vbody); 52 53 /* The ptree & body are copied to avoid mutation */ 54 vptree = check_copy_ptree(K, vptree, vpenv); 55 56 krooted_tvs_push(K, vptree); 57 58 /* the body should be a list */ 59 check_list(K, true, vbody, NULL, NULL); 60 vbody = copy_es_immutable_h(K, vbody, false); 61 62 krooted_tvs_push(K, vbody); 63 64 TValue new_op = kmake_operative(K, do_vau, 4, vptree, vpenv, vbody, denv); 65 66 #if KTRACK_SI 67 /* save as source code info the info from the expression whose evaluation 68 got us here */ 69 TValue si = kget_csi(K); 70 if (!ttisnil(si)) { 71 krooted_tvs_push(K, new_op); 72 kset_source_info(K, new_op, si); 73 krooted_tvs_pop(K); 74 } 75 #endif 76 77 krooted_tvs_pop(K); 78 krooted_tvs_pop(K); 79 kapply_cc(K, new_op); 80 } 81 82 void do_vau(klisp_State *K) 83 { 84 TValue *xparams = K->next_xparams; 85 TValue ptree = K->next_value; 86 TValue denv = K->next_env; 87 klisp_assert(ttisenvironment(K->next_env)); 88 89 UNUSED(denv); 90 91 /* 92 ** xparams[0]: op_ptree 93 ** xparams[1]: penv 94 ** xparams[2]: body 95 ** xparams[3]: senv 96 */ 97 TValue op_ptree = xparams[0]; 98 TValue penv = xparams[1]; 99 TValue body = xparams[2]; 100 TValue senv = xparams[3]; 101 102 /* bindings in an operative are in a child of the static env */ 103 TValue env = kmake_environment(K, senv); 104 105 /* protect env */ 106 krooted_tvs_push(K, env); 107 108 match(K, env, op_ptree, ptree); 109 if (!ttisignore(penv)) 110 kadd_binding(K, env, penv, denv); 111 112 /* keep env in stack in case a cont has to be constructed */ 113 114 if (ttisnil(body)) { 115 krooted_tvs_pop(K); 116 kapply_cc(K, KINERT); 117 } else { 118 /* this is needed because seq continuation doesn't check for 119 nil sequence */ 120 TValue tail = kcdr(body); 121 if (ttispair(tail)) { 122 TValue new_cont = kmake_continuation(K, kget_cc(K), 123 do_seq, 2, tail, env); 124 kset_cc(K, new_cont); 125 #if KTRACK_SI 126 /* put the source info of the list including the element 127 that we are about to evaluate */ 128 kset_source_info(K, new_cont, ktry_get_si(K, body)); 129 #endif 130 } 131 krooted_tvs_pop(K); 132 ktail_eval(K, kcar(body), env); 133 } 134 } 135 136 /* 4.10.4 wrap */ 137 void wrap(klisp_State *K) 138 { 139 TValue *xparams = K->next_xparams; 140 TValue ptree = K->next_value; 141 TValue denv = K->next_env; 142 klisp_assert(ttisenvironment(K->next_env)); 143 UNUSED(denv); 144 UNUSED(xparams); 145 146 bind_1tp(K, ptree, "combiner", ttiscombiner, comb); 147 TValue new_app = kwrap(K, comb); 148 #if KTRACK_SI 149 /* save as source code info the info from the expression whose evaluation 150 got us here */ 151 TValue si = kget_csi(K); 152 if (!ttisnil(si)) { 153 krooted_tvs_push(K, new_app); 154 kset_source_info(K, new_app, si); 155 krooted_tvs_pop(K); 156 } 157 #endif 158 kapply_cc(K, new_app); 159 } 160 161 /* 4.10.5 unwrap */ 162 void unwrap(klisp_State *K) 163 { 164 TValue *xparams = K->next_xparams; 165 TValue ptree = K->next_value; 166 TValue denv = K->next_env; 167 klisp_assert(ttisenvironment(K->next_env)); 168 (void) denv; 169 (void) xparams; 170 bind_1tp(K, ptree, "applicative", ttisapplicative, app); 171 TValue underlying = kunwrap(app); 172 kapply_cc(K, underlying); 173 } 174 175 /* 5.3.1 $vau */ 176 /* DONE: above, together with 4.10.4 */ 177 /* 5.3.2 $lambda */ 178 void Slambda(klisp_State *K) 179 { 180 TValue *xparams = K->next_xparams; 181 TValue ptree = K->next_value; 182 TValue denv = K->next_env; 183 klisp_assert(ttisenvironment(K->next_env)); 184 (void) xparams; 185 bind_al1p(K, ptree, vptree, vbody); 186 187 /* The ptree & body are copied to avoid mutation */ 188 vptree = check_copy_ptree(K, vptree, KIGNORE); 189 krooted_tvs_push(K, vptree); 190 /* the body should be a list */ 191 check_list(K, true, vbody, NULL, NULL); 192 vbody = copy_es_immutable_h(K, vbody, false); 193 194 krooted_tvs_push(K, vbody); 195 196 TValue new_app = kmake_applicative(K, do_vau, 4, vptree, KIGNORE, vbody, 197 denv); 198 #if KTRACK_SI 199 /* save as source code info the info from the expression whose evaluation 200 got us here, both for the applicative and the underlying combiner */ 201 TValue si = kget_csi(K); 202 203 if (!ttisnil(si)) { 204 krooted_tvs_push(K, new_app); 205 kset_source_info(K, new_app, si); 206 kset_source_info(K, kunwrap(new_app), si); 207 krooted_tvs_pop(K); 208 } 209 #endif 210 211 krooted_tvs_pop(K); 212 krooted_tvs_pop(K); 213 kapply_cc(K, new_app); 214 } 215 216 /* 5.5.1 apply */ 217 void apply(klisp_State *K) 218 { 219 TValue *xparams = K->next_xparams; 220 TValue ptree = K->next_value; 221 TValue denv = K->next_env; 222 klisp_assert(ttisenvironment(K->next_env)); 223 UNUSED(denv); 224 UNUSED(xparams); 225 226 bind_al2tp(K, ptree, 227 "applicative", ttisapplicative, app, 228 "any", anytype, obj, 229 maybe_env); 230 231 TValue env = (get_opt_tpar(K, maybe_env, "environment", ttisenvironment))? 232 maybe_env : kmake_empty_environment(K); 233 234 krooted_tvs_push(K, env); 235 TValue expr = kcons(K, kunwrap(app), obj); 236 krooted_tvs_pop(K); 237 /* TODO track source code info */ 238 ktail_eval(K, expr, env); 239 } 240 241 /* Continuation helpers for map */ 242 243 /* For acyclic input lists: Return the mapped list */ 244 void do_map_ret(klisp_State *K) 245 { 246 TValue *xparams = K->next_xparams; 247 TValue obj = K->next_value; 248 klisp_assert(ttisnil(K->next_env)); 249 /* 250 ** xparams[0]: (dummy . complete-ls) 251 */ 252 UNUSED(obj); 253 /* copy the list to avoid problems with continuations 254 captured from within the dynamic extent to map 255 and later mutation of the result */ 256 /* XXX: the check isn't necessary really, but there is 257 no list_copy */ 258 TValue copy = check_copy_list(K, kcdr(xparams[0]), false, NULL, NULL); 259 kapply_cc(K, copy); 260 } 261 262 /* For cyclic input list: close the cycle and return the mapped list */ 263 void do_map_encycle(klisp_State *K) 264 { 265 TValue *xparams = K->next_xparams; 266 TValue obj = K->next_value; 267 klisp_assert(ttisnil(K->next_env)); 268 /* 269 ** xparams[0]: (dummy . complete-ls) 270 ** xparams[1]: last non-cycle pair 271 */ 272 /* obj: (rem-ls . last-pair) */ 273 TValue lp = kcdr(obj); 274 TValue lap = xparams[1]; 275 276 TValue fcp = kcdr(lap); 277 TValue lcp = lp; 278 kset_cdr(lcp, fcp); 279 280 /* copy the list to avoid problems with continuations 281 captured from within the dynamic extent to map 282 and later mutation of the result */ 283 /* XXX: the check isn't necessary really, but there is 284 no list_copy */ 285 TValue copy = check_copy_list(K, kcdr(xparams[0]), false, NULL, NULL); 286 kapply_cc(K, copy); 287 } 288 289 void do_map(klisp_State *K) 290 { 291 TValue *xparams = K->next_xparams; 292 TValue obj = K->next_value; 293 klisp_assert(ttisnil(K->next_env)); 294 /* 295 ** xparams[0]: app 296 ** xparams[1]: rem-ls 297 ** xparams[2]: last-pair 298 ** xparams[3]: n 299 ** xparams[4]: denv 300 ** xparams[5]: dummyp 301 */ 302 TValue app = xparams[0]; 303 TValue ls = xparams[1]; 304 TValue last_pair = xparams[2]; 305 int32_t n = ivalue(xparams[3]); 306 TValue denv = xparams[4]; 307 bool dummyp = bvalue(xparams[5]); 308 309 /* this case is used to kick start the mapping of both 310 the acyclic and cyclic part, avoiding code duplication */ 311 if (!dummyp) { 312 TValue np = kcons(K, obj, KNIL); 313 kset_cdr(last_pair, np); 314 last_pair = np; 315 } 316 317 if (n == 0) { 318 /* pass the rest of the list and last pair for cycle handling */ 319 kapply_cc(K, kcons(K, ls, last_pair)); 320 } else { 321 /* copy the ptree to avoid problems with mutation */ 322 /* XXX: no check necessary, could just use copy_list if there 323 was such a procedure */ 324 TValue first_ptree = check_copy_list(K, kcar(ls), false, NULL, NULL); 325 ls = kcdr(ls); 326 n = n-1; 327 krooted_tvs_push(K, first_ptree); 328 /* have to unwrap the applicative to avoid extra evaluation of first */ 329 TValue new_expr = kcons(K, kunwrap(app), first_ptree); 330 krooted_tvs_push(K, new_expr); 331 TValue new_cont = 332 kmake_continuation(K, kget_cc(K), do_map, 6, app, 333 ls, last_pair, i2tv(n), denv, KFALSE); 334 krooted_tvs_pop(K); 335 krooted_tvs_pop(K); 336 kset_cc(K, new_cont); 337 ktail_eval(K, new_expr, denv); 338 } 339 } 340 341 void do_map_cycle(klisp_State *K) 342 { 343 TValue *xparams = K->next_xparams; 344 TValue obj = K->next_value; 345 klisp_assert(ttisnil(K->next_env)); 346 /* 347 ** xparams[0]: app 348 ** xparams[1]: (dummy . res-list) 349 ** xparams[2]: cpairs 350 ** xparams[3]: denv 351 */ 352 353 TValue app = xparams[0]; 354 TValue dummy = xparams[1]; 355 int32_t cpairs = ivalue(xparams[2]); 356 TValue denv = xparams[3]; 357 358 /* obj: (cycle-part . last-result-pair) */ 359 TValue ls = kcar(obj); 360 TValue last_apair = kcdr(obj); 361 362 /* this continuation will close the cycle and return the list */ 363 TValue encycle_cont = 364 kmake_continuation(K, kget_cc(K), do_map_encycle, 2, 365 dummy, last_apair); 366 367 krooted_tvs_push(K, encycle_cont); 368 /* schedule the mapping of the elements of the cycle, 369 signal dummyp = true to avoid creating a pair for 370 the inert value passed to the first continuation */ 371 TValue new_cont = 372 kmake_continuation(K, encycle_cont, do_map, 6, app, ls, 373 last_apair, i2tv(cpairs), denv, KTRUE); 374 klisp_assert(ttisenvironment(denv)); 375 376 krooted_tvs_pop(K); 377 kset_cc(K, new_cont); 378 /* this will be like a nop and will continue with do_map */ 379 kapply_cc(K, KINERT); 380 } 381 382 /* 5.9.1 map */ 383 void map(klisp_State *K) 384 { 385 TValue *xparams = K->next_xparams; 386 TValue ptree = K->next_value; 387 TValue denv = K->next_env; 388 klisp_assert(ttisenvironment(K->next_env)); 389 UNUSED(xparams); 390 391 bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss); 392 393 if (ttisnil(lss)) { 394 klispE_throw_simple(K, "no lists"); 395 return; 396 } 397 398 /* get the metrics of the ptree of each call to app and 399 of the result list */ 400 int32_t app_pairs, app_apairs, app_cpairs; 401 int32_t res_pairs, res_apairs, res_cpairs; 402 403 map_for_each_get_metrics(K, lss, &app_apairs, &app_cpairs, 404 &res_apairs, &res_cpairs); 405 app_pairs = app_apairs + app_cpairs; 406 res_pairs = res_apairs + res_cpairs; 407 UNUSED(app_pairs); 408 UNUSED(res_pairs); 409 410 /* create the list of parameters to app */ 411 lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs, 412 res_apairs, res_cpairs); 413 414 /* ASK John: the semantics when this is mixed with continuations, 415 isn't all that great..., but what are the expectations considering 416 there is no prescribed order? */ 417 418 krooted_tvs_push(K, lss); 419 /* This will be the list to be returned, but it will be copied 420 before to play a little nicer with continuations */ 421 TValue dummy = kcons(K, KINERT, KNIL); 422 423 krooted_tvs_push(K, dummy); 424 425 TValue ret_cont = (res_cpairs == 0)? 426 kmake_continuation(K, kget_cc(K), do_map_ret, 1, dummy) 427 : kmake_continuation(K, kget_cc(K), do_map_cycle, 4, 428 app, dummy, i2tv(res_cpairs), denv); 429 430 krooted_tvs_push(K, ret_cont); 431 432 /* schedule the mapping of the elements of the acyclic part. 433 signal dummyp = true to avoid creating a pair for 434 the inert value passed to the first continuation */ 435 TValue new_cont = 436 kmake_continuation(K, ret_cont, do_map, 6, app, lss, dummy, 437 i2tv(res_apairs), denv, KTRUE); 438 439 krooted_tvs_pop(K); 440 krooted_tvs_pop(K); 441 krooted_tvs_pop(K); 442 443 kset_cc(K, new_cont); 444 445 /* this will be a nop, and will continue with do_map */ 446 kapply_cc(K, KINERT); 447 } 448 449 /* 450 ** These are from r7rs (except bytevector). For now just follow 451 ** Kernel version of (list) map. That means that the objects should 452 ** all have the same size, and that the dynamic environment is passed 453 ** to the applicatives. Continuation capturing interaction is still 454 ** an open issue (see comment in map). 455 */ 456 457 /* NOTE: the type error on the result of app are only checked after 458 all values are collected. This could be changed if necessary, by 459 having map continuations take an additional typecheck param */ 460 /* Helpers for array_map */ 461 462 /* copy the resulting list to a new vector */ 463 void do_array_map_ret(klisp_State *K) 464 { 465 TValue *xparams = K->next_xparams; 466 TValue obj = K->next_value; 467 klisp_assert(ttisnil(K->next_env)); 468 /* 469 ** xparams[0]: (dummy . complete-ls) 470 ** xparams[1]: list->array 471 ** xparams[2]: length 472 */ 473 UNUSED(obj); 474 475 TValue ls = kcdr(xparams[0]); 476 TValue (*list_to_array)(klisp_State *K, TValue array, int32_t size) = 477 pvalue(xparams[1]); 478 int32_t length = ivalue(xparams[2]); 479 480 /* This will also avoid some problems with continuations 481 captured from within the dynamic extent to map 482 and later mutation of the result */ 483 TValue copy = list_to_array(K, ls, length); 484 kapply_cc(K, copy); 485 } 486 487 /* 5.9.? string-map */ 488 /* 5.9.? vector-map */ 489 /* 5.9.? bytevector-map */ 490 void array_map(klisp_State *K) 491 { 492 TValue *xparams = K->next_xparams; 493 TValue ptree = K->next_value; 494 TValue denv = K->next_env; 495 klisp_assert(ttisenvironment(K->next_env)); 496 497 /* 498 ** xparams[0]: list->array fn 499 ** xparams[1]: array->list fn (with type check and size ret) 500 */ 501 502 TValue list_to_array_tv = xparams[0]; 503 TValue (*array_to_list)(klisp_State *K, TValue array, int32_t *size) = 504 pvalue(xparams[1]); 505 506 bind_al1tp(K, ptree, "applicative", ttisapplicative, app, lss); 507 508 /* check that lss is a non empty list, and copy it */ 509 if (ttisnil(lss)) { 510 klispE_throw_simple(K, "no arguments after applicative"); 511 return; 512 } 513 514 int32_t app_pairs, app_apairs, app_cpairs; 515 /* the copied list should be protected from gc, and will host 516 the lists resulting from the conversion */ 517 lss = check_copy_list(K, lss, true, &app_pairs, &app_cpairs); 518 app_apairs = app_pairs - app_cpairs; 519 krooted_tvs_push(K, lss); 520 521 /* check that all elements have the correct type and same size, 522 and convert them to lists */ 523 int32_t res_pairs; 524 TValue head = kcar(lss); 525 TValue tail = kcdr(lss); 526 TValue ls = array_to_list(K, head, &res_pairs); 527 kset_car(lss, ls); /* save the first */ 528 /* all array will produce acyclic lists */ 529 530 for(int32_t i = 1 /* jump over first */; i < app_pairs; ++i) { 531 head = kcar(tail); 532 int32_t pairs; 533 ls = array_to_list(K, head, &pairs); 534 /* in klisp all arrays should have the same length */ 535 if (pairs != res_pairs) { 536 klispE_throw_simple(K, "arguments of different length"); 537 return; 538 } 539 kset_car(tail, ls); 540 tail = kcdr(tail); 541 } 542 543 /* create the list of parameters to app */ 544 lss = map_for_each_transpose(K, lss, app_apairs, app_cpairs, 545 res_pairs, 0); /* cycle pairs is always 0 */ 546 547 /* ASK John: the semantics when this is mixed with continuations, 548 isn't all that great..., but what are the expectations considering 549 there is no prescribed order? */ 550 551 krooted_tvs_pop(K); 552 krooted_tvs_push(K, lss); 553 /* This will be the list to be returned, but it will be transformed 554 to an array before returning (making it also play a little nicer 555 with continuations) */ 556 TValue dummy = kcons(K, KINERT, KNIL); 557 558 krooted_tvs_push(K, dummy); 559 560 TValue ret_cont = 561 kmake_continuation(K, kget_cc(K), do_array_map_ret, 3, dummy, 562 list_to_array_tv, i2tv(res_pairs)); 563 krooted_tvs_push(K, ret_cont); 564 565 /* schedule the mapping of the elements of the acyclic part. 566 signal dummyp = true to avoid creating a pair for 567 the inert value passed to the first continuation */ 568 TValue new_cont = 569 kmake_continuation(K, ret_cont, do_map, 6, app, lss, dummy, 570 i2tv(res_pairs), denv, KTRUE); 571 572 krooted_tvs_pop(K); 573 krooted_tvs_pop(K); 574 krooted_tvs_pop(K); 575 576 kset_cc(K, new_cont); 577 578 /* this will be a nop, and will continue with do_map */ 579 kapply_cc(K, KINERT); 580 } 581 582 /* 6.2.1 combiner? */ 583 /* uses ftypedp */ 584 585 /* init ground */ 586 void kinit_combiners_ground_env(klisp_State *K) 587 { 588 TValue ground_env = G(K)->ground_env; 589 TValue symbol, value; 590 591 /* 4.10.1 operative? */ 592 add_applicative(K, ground_env, "operative?", typep, 2, symbol, 593 i2tv(K_TOPERATIVE)); 594 /* 4.10.2 applicative? */ 595 add_applicative(K, ground_env, "applicative?", typep, 2, symbol, 596 i2tv(K_TAPPLICATIVE)); 597 /* 4.10.3 $vau */ 598 /* 5.3.1 $vau */ 599 add_operative(K, ground_env, "$vau", Svau, 0); 600 /* 4.10.4 wrap */ 601 add_applicative(K, ground_env, "wrap", wrap, 0); 602 /* 4.10.5 unwrap */ 603 add_applicative(K, ground_env, "unwrap", unwrap, 0); 604 /* 5.3.2 $lambda */ 605 add_operative(K, ground_env, "$lambda", Slambda, 0); 606 /* 5.5.1 apply */ 607 add_applicative(K, ground_env, "apply", apply, 0); 608 /* 5.9.1 map */ 609 add_applicative(K, ground_env, "map", map, 0); 610 /* 5.9.? string-map, vector-map, bytevector-map */ 611 add_applicative(K, ground_env, "string-map", array_map, 2, 612 p2tv(list_to_string_h), p2tv(string_to_list_h)); 613 add_applicative(K, ground_env, "vector-map", array_map, 2, 614 p2tv(list_to_vector_h), p2tv(vector_to_list_h)); 615 add_applicative(K, ground_env, "bytevector-map", array_map, 2, 616 p2tv(list_to_bytevector_h), p2tv(bytevector_to_list_h)); 617 /* 6.2.1 combiner? */ 618 add_applicative(K, ground_env, "combiner?", ftypep, 2, symbol, 619 p2tv(kcombinerp)); 620 } 621 622 /* XXX lock? */ 623 /* init continuation names */ 624 void kinit_combiners_cont_names(klisp_State *K) 625 { 626 Table *t = tv2table(G(K)->cont_name_table); 627 628 add_cont_name(K, t, do_vau, "$vau-bind!-eval"); 629 630 add_cont_name(K, t, do_map, "map-acyclic-part"); 631 add_cont_name(K, t, do_map_encycle, "map-encycle!"); 632 add_cont_name(K, t, do_map_ret, "map-ret"); 633 add_cont_name(K, t, do_map_cycle, "map-cyclic-part"); 634 635 add_cont_name(K, t, do_array_map_ret, "array-map-ret"); 636 }