kstate.c (19953B)
1 /* 2 ** kstate.c 3 ** klisp vm state 4 ** See Copyright Notice in klisp.h 5 */ 6 7 /* 8 ** SOURCE NOTE: this is mostly from Lua. 9 ** The algorithm for testing if a continuation is within the dynamic extent 10 ** of another continuation using marks is by John Shutt. The implementation 11 ** he uses (see SINK) is in scheme and is under the GPL but I think this is 12 ** different enough (and the algorithm simple/small enough) to avoid any 13 ** problem. ASK John. 14 */ 15 16 #include <stdlib.h> 17 #include <stddef.h> 18 #include <setjmp.h> 19 #include <string.h> 20 #include <pthread.h> 21 22 #include "klisp.h" 23 #include "klimits.h" 24 #include "kstate.h" 25 #include "kobject.h" 26 #include "kpair.h" 27 #include "kmem.h" 28 #include "keval.h" 29 #include "koperative.h" 30 #include "kapplicative.h" 31 #include "kcontinuation.h" 32 #include "kenvironment.h" 33 #include "kground.h" 34 #include "krepl.h" 35 #include "ksymbol.h" 36 #include "kstring.h" 37 #include "kport.h" 38 #include "ktable.h" 39 #include "kbytevector.h" 40 #include "kvector.h" 41 42 #include "kghelpers.h" /* for creating list_app & memoize_app */ 43 #include "kgerrors.h" /* for creating error hierarchy */ 44 45 #include "kgc.h" /* for memory freeing & gc init */ 46 47 48 /* in lua state size can have an extra space here to save 49 some user data, for now we don't have that in klisp */ 50 #define state_size(x) (sizeof(x) + 0) 51 #define fromstate(k) (cast(uint8_t *, (k)) - 0) 52 #define tostate(k) (cast(klisp_State *, cast(uint8_t *, k) + 0)) 53 54 /* 55 ** Main thread combines a thread state and the global state 56 */ 57 typedef struct KG { 58 klisp_State k; 59 global_State g; 60 } KG; 61 62 /* 63 ** open parts that may cause memory-allocation errors 64 */ 65 /* TODO move other stuff that cause allocs here */ 66 static void f_klispopen (klisp_State *K, void *ud) { 67 global_State *g = G(K); 68 UNUSED(ud); 69 klispS_resize(K, MINSTRTABSIZE); /* initial size of string table */ 70 71 void *s = (*g->frealloc)(ud, NULL, 0, KS_ISSIZE * sizeof(TValue)); 72 if (s == NULL) { 73 return; /* XXX throw error somehow & free mem */ 74 } 75 void *b = (*g->frealloc)(ud, NULL, 0, KS_ITBSIZE); 76 if (b == NULL) { 77 return; /* XXX throw error somehow & free mem */ 78 } 79 80 /* initialize temp stacks */ 81 ks_ssize(K) = KS_ISSIZE; 82 ks_stop(K) = 0; /* stack is empty */ 83 ks_sbuf(K) = (TValue *)s; 84 85 ks_tbsize(K) = KS_ITBSIZE; 86 ks_tbidx(K) = 0; /* buffer is empty */ 87 ks_tbuf(K) = (char *)b; 88 89 /* (at least for now) we'll use a non recursive mutex for the GIL */ 90 /* XXX/TODO check return code */ 91 pthread_mutex_init(&g->gil, NULL); 92 93 /* This is here in lua, but in klisp we still need to alloc 94 a bunch of objects: 95 g->GCthreshold = 4*g->totalbytes; 96 */ 97 } 98 99 100 static void preinit_state (klisp_State *K, global_State *g) { 101 G(K) = g; 102 103 K->status = KLISP_THREAD_CREATED; 104 K->gil_count = 0; 105 K->curr_cont = KNIL; 106 K->next_obj = KINERT; 107 K->next_func = NULL; 108 K->next_value = KINERT; 109 K->next_env = KNIL; 110 K->next_xparams = NULL; 111 K->next_si = KNIL; 112 113 /* current input and output */ 114 K->curr_port = KINERT; /* set on each call to read/write */ 115 116 /* init the stacks used to protect variables & values from gc, 117 this should be done before any new object is created because 118 they are used by them */ 119 K->rooted_tvs_top = 0; 120 K->rooted_vars_top = 0; 121 122 /* initialize tokenizer */ 123 124 /* WORKAROUND: for stdin line buffering & reading of EOF */ 125 K->ktok_seen_eof = false; 126 127 /* TEMP: For now just hardcode it to 8 spaces tab-stop */ 128 K->ktok_source_info.tab_width = 8; 129 /* all three are set on each call to read */ 130 K->ktok_source_info.filename = KINERT; 131 K->ktok_source_info.line = 1; 132 K->ktok_source_info.col = 0; 133 134 K->ktok_nested_comments = 0; 135 136 /* initialize reader */ 137 K->shared_dict = KNIL; 138 K->read_mconsp = false; /* set on each call to read */ 139 140 /* initialize writer */ 141 K->write_displayp = false; /* set on each call to write */ 142 143 /* put zeroes first, in case alloc fails */ 144 ks_stop(K) = 0; 145 ks_ssize(K) = 0; 146 ks_sbuf(K) = NULL; 147 148 ks_tbidx(K) = 0; 149 ks_tbsize(K) = 0; 150 ks_tbuf(K) = NULL; 151 } 152 153 /* LOCK: GIL should be acquired */ 154 static void close_state(klisp_State *K) 155 { 156 global_State *g = G(K); 157 158 /* collect all objects */ 159 klispC_freeall(K); 160 klisp_assert(g->rootgc == obj2gco(K)); 161 klisp_assert(g->strt.nuse == 0); 162 163 /* free helper buffers */ 164 klispM_freemem(K, ks_sbuf(K), ks_ssize(K) * sizeof(TValue)); 165 klispM_freemem(K, ks_tbuf(K), ks_tbsize(K)); 166 /* free string/symbol table */ 167 klispM_freearray(K, g->strt.hash, g->strt.size, GCObject *); 168 169 /* destroy the GIL */ 170 pthread_mutex_destroy(&g->gil); 171 172 /* only remaining mem should be of the state struct */ 173 klisp_assert(g->totalbytes == sizeof(KG)); 174 /* NOTE: this needs to be done "by hand" */ 175 (*g->frealloc)(g->ud, fromstate(K), state_size(KG), 0); 176 } 177 178 /* 179 ** State creation and destruction 180 */ 181 klisp_State *klisp_newstate(klisp_Alloc f, void *ud) 182 { 183 klisp_State *K; 184 global_State *g; 185 186 void *k = (*f)(ud, NULL, 0, state_size(KG)); 187 if (k == NULL) return NULL; 188 K = tostate(k); 189 g = &((KG *)K)->g; 190 /* Init klisp_State object header (for GC) */ 191 K->next = NULL; 192 K->tt = K_TTHREAD; 193 K->kflags = 0; 194 K->si = NULL; 195 g->currentwhite = bit2mask(WHITE0BIT, FIXEDBIT); 196 K->gct = klispC_white(g); 197 set2bits(K->gct, FIXEDBIT, SFIXEDBIT); 198 199 preinit_state(K, g); 200 201 ktok_init(K); /* initialize tokenizer tables */ 202 g->frealloc = f; 203 g->ud = ud; 204 g->mainthread = K; 205 206 g->GCthreshold = 0; /* mark it as unfinished state */ 207 208 /* these will be properly initialized later */ 209 g->strt.size = 0; 210 g->strt.nuse = 0; 211 g->strt.hash = NULL; 212 g->name_table = KINERT; 213 g->cont_name_table = KINERT; 214 g->thread_table = KINERT; 215 216 g->empty_string = KINERT; 217 g->empty_bytevector = KINERT; 218 g->empty_vector = KINERT; 219 220 g->ktok_lparen = KINERT; 221 g->ktok_rparen = KINERT; 222 g->ktok_dot = KINERT; 223 g->ktok_sexp_comment = KINERT; 224 225 g->require_path = KINERT; 226 g->require_table = KINERT; 227 g->libraries_registry = KINERT; 228 229 g->eval_op = KINERT; 230 g->list_app = KINERT; 231 g->memoize_app = KINERT; 232 g->ground_env = KINERT; 233 g->module_params_sym = KINERT; 234 g->root_cont = KINERT; 235 g->error_cont = KINERT; 236 g->system_error_cont = KINERT; 237 238 /* input / output for dynamic keys */ 239 /* these are init later */ 240 g->kd_in_port_key = KINERT; 241 g->kd_out_port_key = KINERT; 242 g->kd_error_port_key = KINERT; 243 244 /* strict arithmetic dynamic key */ 245 /* this is init later */ 246 g->kd_strict_arith_key = KINERT; 247 248 g->gcstate = GCSpause; 249 g->rootgc = obj2gco(K); /* was NULL in unithread klisp... CHECK */ 250 g->sweepstrgc = 0; 251 g->sweepgc = &g->rootgc; 252 g->gray = NULL; 253 g->grayagain = NULL; 254 g->weak = NULL; 255 g->tmudata = NULL; 256 g->totalbytes = sizeof(KG); 257 g->gcpause = KLISPI_GCPAUSE; 258 g->gcstepmul = KLISPI_GCMUL; 259 g->gcdept = 0; 260 261 /* GC */ 262 g->totalbytes = state_size(KG) + KS_ISSIZE * sizeof(TValue) + 263 KS_ITBSIZE; 264 g->GCthreshold = UINT32_MAX; /* we still have a lot of allocation 265 to do, put a very high value to 266 avoid collection */ 267 g->estimate = 0; /* doesn't matter, it is set by gc later */ 268 /* XXX Things start being ugly from here on... 269 I have to think about the whole init procedure, for now 270 I am mostly following lua, but the differences between it and 271 klisp show... We still have to allocate a lot of objects and 272 it isn't really clear what happens if we run out of space before 273 all objects are allocated. For now let's suppose that will not 274 happen... */ 275 /* TODO handle errors, maybe with longjmp, also see lua 276 luaD_rawrunprotected */ 277 f_klispopen(K, NULL); /* this touches GCthreshold */ 278 279 g->GCthreshold = UINT32_MAX; /* we still have a lot of allocation 280 to do, put a very high value to 281 avoid collection */ 282 283 /* TEMP: err */ 284 /* THIS MAY CRASH THE INTERPRETER IF THERE IS AN ERROR IN THE INIT */ 285 /* do nothing for now */ 286 287 /* initialize strings */ 288 289 /* initialize name info table */ 290 /* needs weak keys, otherwise every named object would 291 be fixed! */ 292 g->name_table = klispH_new(K, 0, MINNAMETABSIZE, 293 K_FLAG_WEAK_KEYS); 294 /* here the keys are uncollectable */ 295 g->cont_name_table = klispH_new(K, 0, MINCONTNAMETABSIZE, 296 K_FLAG_WEAK_NOTHING); 297 /* here the keys are uncollectable */ 298 g->thread_table = klispH_new(K, 0, MINTHREADTABSIZE, 299 K_FLAG_WEAK_NOTHING); 300 301 /* Empty string */ 302 /* MAYBE: fix it so we can remove empty_string from roots */ 303 g->empty_string = kstring_new_b_imm(K, ""); 304 305 /* Empty bytevector */ 306 /* MAYBE: fix it so we can remove empty_bytevector from roots */ 307 /* XXX: find a better way to do this */ 308 g->empty_bytevector = KNIL; /* trick constructor to create empty bytevector */ 309 g->empty_bytevector = kbytevector_new_bs_imm(K, NULL, 0); 310 311 /* Empty vector */ 312 /* MAYBE: see above */ 313 g->empty_vector = kvector_new_bs_g(K, false, NULL, 0); 314 315 /* Special Tokens */ 316 g->ktok_lparen = kcons(K, ch2tv('('), KNIL); 317 g->ktok_rparen = kcons(K, ch2tv(')'), KNIL); 318 g->ktok_dot = kcons(K, ch2tv('.'), KNIL); 319 g->ktok_sexp_comment = kcons(K, ch2tv(';'), KNIL); 320 321 /* initialize require facilities */ 322 { 323 char *str = getenv(KLISP_PATH); 324 if (str == NULL) 325 str = KLISP_PATH_DEFAULT; 326 327 g->require_path = kstring_new_b_imm(K, str); 328 /* replace dirsep with forward slashes, 329 windows will happily accept forward slashes */ 330 str = kstring_buf(g->require_path); 331 while ((str = strchr(str, *KLISP_DIRSEP)) != NULL) 332 *str++ = '/'; 333 } 334 g->require_table = klispH_new(K, 0, MINREQUIRETABSIZE, 0); 335 336 /* initialize library facilities */ 337 g->libraries_registry = KNIL; 338 339 /* the dynamic ports and the keys for the dynamic ports */ 340 TValue in_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDIN*"), 341 false, false, stdin); 342 TValue out_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDOUT*"), 343 true, false, stdout); 344 TValue error_port = kmake_std_fport(K, kstring_new_b_imm(K, "*STDERR*"), 345 true, false, stderr); 346 g->kd_in_port_key = kcons(K, KTRUE, in_port); 347 g->kd_out_port_key = kcons(K, KTRUE, out_port); 348 g->kd_error_port_key = kcons(K, KTRUE, error_port); 349 350 /* strict arithmetic key, (starts as false) */ 351 g->kd_strict_arith_key = kcons(K, KTRUE, KFALSE); 352 353 /* create the ground environment and the eval operative */ 354 int32_t line_number; 355 TValue si; 356 g->eval_op = kmake_operative(K, keval_ofn, 0), line_number = __LINE__; 357 #if KTRACK_SI 358 si = kcons(K, kstring_new_b_imm(K, __FILE__), 359 kcons(K, i2tv(line_number), i2tv(0))); 360 kset_source_info(K, g->eval_op, si); 361 #endif 362 /* TODO: si */ 363 TValue eval_name = ksymbol_new_b(K, "eval", KNIL); 364 ktry_set_name(K, g->eval_op, eval_name); 365 366 g->list_app = kmake_applicative(K, list, 0), line_number = __LINE__; 367 #if KTRACK_SI 368 si = kcons(K, kstring_new_b_imm(K, __FILE__), 369 kcons(K, i2tv(__LINE__), i2tv(0))); 370 kset_source_info(K, g->list_app, si); 371 kset_source_info(K, kunwrap(g->list_app), si); 372 #endif 373 374 g->memoize_app = kmake_applicative(K, memoize, 0), line_number = __LINE__; 375 #if KTRACK_SI 376 si = kcons(K, kstring_new_b_imm(K, __FILE__), 377 kcons(K, i2tv(__LINE__), i2tv(0))); 378 kset_source_info(K, g->memoize_app, si); 379 kset_source_info(K, kunwrap(g->memoize_app), si); 380 #endif 381 /* ground environment has a hashtable for bindings */ 382 g->ground_env = kmake_table_environment(K, KNIL); 383 // g->ground_env = kmake_empty_environment(K); 384 385 /* MAYBE: fix it so we can remove module_params_sym from roots */ 386 /* TODO si */ 387 g->module_params_sym = ksymbol_new_b(K, "module-parameters", KNIL); 388 389 kinit_ground_env(K); 390 kinit_cont_names(K); 391 392 /* put the main thread in the thread table */ 393 TValue *node = klispH_set(K, tv2table(g->thread_table), gc2th(K)); 394 *node = KTRUE; 395 396 /* create a std environment and leave it in g->next_env */ 397 K->next_env = kmake_table_environment(K, g->ground_env); 398 399 /* set the threshold for gc start now that we have allocated all mem */ 400 g->GCthreshold = 4*g->totalbytes; 401 402 /* luai_userstateopen(L); */ 403 return K; 404 } 405 406 /* this is in api.c in lua */ 407 klisp_State *klisp_newthread(klisp_State *K) 408 { 409 /* TODO */ 410 return NULL; 411 } 412 413 klisp_State *klispT_newthread(klisp_State *K) 414 { 415 klisp_State *K1 = tostate(klispM_malloc(K, state_size(klisp_State))); 416 klispC_link(K, (GCObject *) K1, K_TTHREAD, 0); 417 418 preinit_state(K1, G(K)); 419 420 /* protect from gc */ 421 krooted_tvs_push(K, gc2th(K1)); 422 423 /* initialize temp stacks */ 424 ks_sbuf(K1) = (TValue *) klispM_malloc(K, KS_ISSIZE * sizeof(TValue)); 425 ks_ssize(K1) = KS_ISSIZE; 426 ks_stop(K1) = 0; /* stack is empty */ 427 428 ks_tbuf(K1) = (char *) klispM_malloc(K, KS_ITBSIZE); 429 ks_tbsize(K1) = KS_ITBSIZE; 430 ks_tbidx(K1) = 0; /* buffer is empty */ 431 432 /* initialize condition variable for joining */ 433 int32_t ret = pthread_cond_init(&K1->joincond, NULL); 434 435 if (ret != 0) { 436 klispE_throw_simple_with_irritants(K, "Error creating joincond for " 437 "new thread", 1, i2tv(ret)); 438 return NULL; 439 } 440 441 /* everything went well, put the thread in the thread table */ 442 TValue *node = klispH_set(K, tv2table(G(K)->thread_table), gc2th(K1)); 443 *node = KTRUE; 444 krooted_tvs_pop(K); 445 446 klisp_assert(iswhite((GCObject *) (K1))); 447 return K1; 448 } 449 450 451 void klispT_freethread (klisp_State *K, klisp_State *K1) 452 { 453 /* main thread can't come here, so it's safe to remove the 454 condvar here */ 455 int32_t ret = pthread_cond_destroy(&K1->joincond); 456 klisp_assert(ret == 0); /* shouldn't happen */ 457 458 klispM_freemem(K, ks_sbuf(K1), ks_ssize(K1) * sizeof(TValue)); 459 klispM_freemem(K, ks_tbuf(K1), ks_tbsize(K1)); 460 /* userstatefree() */ 461 klispM_freemem(K, fromstate(K1), state_size(klisp_State)); 462 } 463 464 void klisp_close (klisp_State *K) 465 { 466 K = G(K)->mainthread; /* only the main thread can be closed */ 467 468 klisp_lock(K); 469 /* XXX lua does the following */ 470 #if 0 471 lua_lock(L); 472 luaF_close(L, L->stack); /* close all upvalues for this thread */ 473 luaC_separateudata(L, 1); /* separate udata that have GC metamethods */ 474 L->errfunc = 0; /* no error function during GC metamethods */ /* free all collectable objects */ 475 do { /* repeat until no more errors */ 476 L->ci = L->base_ci; 477 L->base = L->top = L->ci->base; 478 L->nCcalls = L->baseCcalls = 0; 479 } while (luaD_rawrunprotected(L, callallgcTM, NULL) != 0); 480 lua_assert(G(L)->tmudata == NULL); 481 luai_userstateclose(L); 482 #endif 483 484 /* luai_userstateclose(L); */ 485 close_state(K); 486 } 487 488 /* 489 ** Stacks memory management 490 */ 491 492 /* LOCK: All these functions should be called with the GIL already acquired */ 493 /* TODO test this */ 494 void ks_sgrow(klisp_State *K, int32_t new_top) 495 { 496 size_t old_size = ks_ssize(K); 497 /* should be powers of two multiple of KS_ISIZE */ 498 /* TEMP: do it naively for now */ 499 size_t new_size = old_size * 2; 500 while(new_top > new_size) 501 new_size *= 2; 502 503 ks_sbuf(K) = klispM_realloc_(K, ks_sbuf(K), old_size*sizeof(TValue), 504 new_size*sizeof(TValue)); 505 ks_ssize(K) = new_size; 506 } 507 508 void ks_sshrink(klisp_State *K, int32_t new_top) 509 { 510 /* NOTE: may shrink more than once, take it to a multiple of 511 KS_ISSIZE that is a power of 2 and no smaller than (size * 4) */ 512 size_t old_size = ks_ssize(K); 513 /* TEMP: do it naively for now */ 514 size_t new_size = old_size; 515 while(new_size > KS_ISSIZE && new_top * 4 < new_size) 516 new_size /= 2; 517 518 /* NOTE: shrink can't fail */ 519 ks_sbuf(K) = klispM_realloc_(K, ks_sbuf(K), old_size*sizeof(TValue), 520 new_size*sizeof(TValue)); 521 ks_ssize(K) = new_size; 522 } 523 524 525 /* TODO test this */ 526 void ks_tbgrow(klisp_State *K, int32_t new_top) 527 { 528 size_t old_size = ks_tbsize(K); 529 /* should be powers of two multiple of KS_ISIZE */ 530 /* TEMP: do it naively for now */ 531 size_t new_size = old_size * 2; 532 while(new_top > new_size) 533 new_size *= 2; 534 535 ks_tbuf(K) = klispM_realloc_(K, ks_tbuf(K), old_size*sizeof(TValue), 536 new_size*sizeof(TValue)); 537 ks_tbsize(K) = new_size; 538 } 539 540 void ks_tbshrink(klisp_State *K, int32_t new_top) 541 { 542 /* NOTE: may shrink more than once, take it to a multiple of 543 KS_ISSIZE that is a power of 2 and no smaller than (size * 4) */ 544 size_t old_size = ks_tbsize(K); 545 /* TEMP: do it naively for now */ 546 size_t new_size = old_size; 547 while(new_size > KS_ISSIZE && new_top * 4 < new_size) 548 new_size /= 2; 549 550 /* NOTE: shrink can't fail */ 551 ks_tbuf(K) = klispM_realloc_(K, ks_tbuf(K), old_size*sizeof(TValue), 552 new_size*sizeof(TValue)); 553 ks_tbsize(K) = new_size; 554 } 555 556 /* GC: Don't assume anything about obj & dst_cont, they may not be rooted. 557 In the most common case of apply-continuation & continuation->applicative 558 they are rooted, but in general there's no way to protect them, because 559 this ends in a setjmp */ 560 void kcall_cont(klisp_State *K, TValue dst_cont, TValue obj) 561 { 562 krooted_tvs_push(K, dst_cont); 563 krooted_tvs_push(K, obj); 564 TValue src_cont = kget_cc(K); 565 TValue int_ls = create_interception_list(K, src_cont, dst_cont); 566 TValue new_cont; 567 if (ttisnil(int_ls)) { 568 new_cont = dst_cont; /* no interceptions */ 569 } else { 570 krooted_tvs_push(K, int_ls); 571 /* we have to contruct a continuation to do the interceptions 572 in order and finally call dst_cont if no divert occurs */ 573 new_cont = kmake_continuation(K, kget_cc(K), do_interception, 574 2, int_ls, dst_cont); 575 krooted_tvs_pop(K); 576 } 577 /* no more allocation from this point */ 578 krooted_tvs_pop(K); 579 krooted_tvs_pop(K); 580 581 /* 582 ** This may come from an error detected by the interpreter, so we can't 583 ** do just a return (like kapply_cc does), maybe we could somehow 584 ** differentiate to avoid the longjmp when return would suffice 585 ** TODO: do that 586 */ 587 kset_cc(K, new_cont); 588 klispT_apply_cc(K, obj); 589 longjmp(K->error_jb, 1); 590 } 591 592 void klispT_init_repl(klisp_State *K) 593 { 594 /* this is in krepl.c */ 595 kinit_repl(K); 596 } 597 598 /* 599 ** TEMP/LOCK: put lock here, until all operatives and continuations do locking directly 600 ** or a new interface (like lua api) does it for them. 601 ** This has the problem that nothing can be done in parallel (but still has the advantage 602 ** that (unlike coroutines) when one thread is blocked (e.g. waiting for IO) the others 603 ** may continue (provided that the blocked thread unlocks the GIL before blocking...) 604 */ 605 void klispT_run(klisp_State *K) 606 { 607 while(true) { 608 if (setjmp(K->error_jb)) { 609 /* continuation called */ 610 /* TEMP: do nothing, the loop will call the continuation */ 611 klisp_unlock_all(K); 612 } else { 613 klisp_lock(K); 614 /* all ok, continue with next func */ 615 while (K->next_func) { 616 /* next_func is either operative or continuation 617 but in any case the call is the same */ 618 (*(K->next_func))(K); 619 klispi_threadyield(K); 620 } 621 /* K->next_func is NULL, this means we should exit already */ 622 klisp_unlock(K); 623 break; 624 } 625 } 626 }