static void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) { #if SEXP_USE_FLONUMS double d; #endif sexp ls1=SEXP_NULL, ls2; sexp_delete_list(ctx, SEXP_G_THREADS_PAUSED, thread); ls2 = sexp_global(ctx, SEXP_G_THREADS_PAUSED); if (sexp_realp(timeout)) gettimeofday(&sexp_context_timeval(thread), NULL); if (sexp_fixnump(timeout)) { sexp_context_timeval(thread).tv_sec += sexp_unbox_fixnum(timeout); #if SEXP_USE_FLONUMS } else if (sexp_flonump(timeout)) { d = sexp_flonum_value(timeout); sexp_context_timeval(thread).tv_sec += trunc(d); sexp_context_timeval(thread).tv_usec += (d-trunc(d))*1000000; if (sexp_context_timeval(thread).tv_usec > 1000000) { sexp_context_timeval(thread).tv_sec += 1; sexp_context_timeval(thread).tv_usec -= 1000000; } #endif #if SEXP_USE_RATIOS } else if (sexp_ratiop(timeout)) { d = sexp_ratio_to_double(timeout); sexp_context_timeval(thread).tv_sec += trunc(d); sexp_context_timeval(thread).tv_usec += (d-trunc(d))*1000000; if (sexp_context_timeval(thread).tv_usec > 1000000) { sexp_context_timeval(thread).tv_sec += 1; sexp_context_timeval(thread).tv_usec -= 1000000; } #endif } else if (sexp_contextp(timeout)) { sexp_context_timeval(thread).tv_sec = sexp_context_timeval(timeout).tv_sec; sexp_context_timeval(thread).tv_usec = sexp_context_timeval(timeout).tv_usec; } else { sexp_context_timeval(thread).tv_sec = 0; sexp_context_timeval(thread).tv_usec = 0; } if (sexp_realp(timeout) || sexp_contextp(timeout)) while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), sexp_context_timeval(thread))) ls1=ls2, ls2=sexp_cdr(ls2); else while (sexp_pairp(ls2) && sexp_context_timeval(sexp_car(ls2)).tv_sec) ls1=ls2, ls2=sexp_cdr(ls2); if (ls1 == SEXP_NULL) sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cons(ctx, thread, ls2); else sexp_cdr(ls1) = sexp_cons(ctx, thread, ls2); }
sexp sexp_thread_terminate (sexp ctx, sexp self, sexp_sint_t n, sexp thread) { sexp res = sexp_make_boolean(ctx == thread); for ( ; thread && sexp_contextp(thread); thread=sexp_context_child(thread)) sexp_context_refuel(thread) = 0; /* return true if terminating self */ return res; }
sexp sexp_mutex_state (sexp ctx sexp_api_params(self, n), sexp mutex) { sexp_assert_type(ctx, sexp_mutexp, sexp_mutex_id, mutex); if (sexp_truep(sexp_mutex_lockp(mutex))) { if (sexp_contextp(sexp_mutex_thread(mutex))) return sexp_mutex_thread(mutex); else return sexp_intern(ctx, "not-owned", -1); } else { return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1); } }
sexp sexp_mutex_state (sexp ctx, sexp self, sexp_sint_t n, sexp mutex) { if (!sexp_mutexp(ctx, mutex)) return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_POLLFDS_ID)), mutex); if (sexp_truep(sexp_mutex_lockp(mutex))) { if (sexp_contextp(sexp_mutex_thread(mutex))) return sexp_mutex_thread(mutex); else return sexp_intern(ctx, "not-owned", -1); } else { return sexp_intern(ctx, (sexp_mutex_thread(mutex) ? "not-abandoned" : "abandoned"), -1); } }
sexp sexp_thread_terminate (sexp ctx, sexp self, sexp_sint_t n, sexp thread) { sexp res = sexp_make_boolean(ctx == thread); /* terminate the thread and all children */ for ( ; thread && sexp_contextp(thread); thread=sexp_context_child(thread)) { /* zero the refuel - this tells the scheduler the thread is terminated */ sexp_context_refuel(thread) = 0; /* unblock the thread if needed so it can be scheduled and terminated */ if (sexp_delete_list(ctx, SEXP_G_THREADS_PAUSED, thread)) sexp_thread_start(ctx, self, 1, thread); } /* return true if terminating self, then we can yield */ return res; }
sexp run_main (int argc, char **argv) { #if SEXP_USE_MODULES char *impmod; #endif char *arg; const char *prefix=NULL, *suffix=NULL, *main_symbol=NULL, *main_module=NULL; sexp_sint_t i, j, c, quit=0, print=0, init_loaded=0, mods_loaded=0, fold_case=SEXP_DEFAULT_FOLD_CASE_SYMS, nonblocking=0; sexp_uint_t heap_size=0, heap_max_size=SEXP_MAXIMUM_HEAP_SIZE; sexp out=SEXP_FALSE, ctx=NULL, ls; sexp_gc_var4(tmp, sym, args, env); args = SEXP_NULL; env = NULL; /* SRFI 22: invoke `main` procedure by default if the interpreter is */ /* invoked as `scheme-r7rs`. */ arg = strrchr(argv[0], '/'); if (strncmp((arg == NULL ? argv[0] : arg + 1), "scheme-r7rs", strlen("scheme-r7rs")) == 0) { main_symbol = "main"; /* skip option parsing since we can't pass `--` before the name of script */ /* to avoid misinterpret the name as options when the interpreter is */ /* executed via `#!/usr/env/bin scheme-r7rs` shebang. */ i = 1; goto done_options; } /* parse options */ for (i=1; i < argc && argv[i][0] == '-'; i++) { switch ((c=argv[i][1])) { case 'D': init_context(); arg = (argv[i][2] == '\0') ? argv[++i] : argv[i]+2; sym = sexp_intern(ctx, arg, -1); ls = sexp_global(ctx, SEXP_G_FEATURES); if (sexp_pairp(ls)) { for (; sexp_pairp(sexp_cdr(ls)); ls=sexp_cdr(ls)) ; sexp_cdr(ls) = sexp_cons(ctx, sym, SEXP_NULL); } break; case 'e': case 'p': mods_loaded = 1; load_init(0); print = (argv[i][1] == 'p'); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('e', arg); tmp = check_exception(ctx, sexp_eval_string(ctx, arg, -1, env)); if (print) { if (! sexp_oportp(out)) out = sexp_eval_string(ctx, "(current-output-port)", -1, env); sexp_write(ctx, tmp, out); sexp_write_char(ctx, '\n', out); } quit = 1; break; case 'l': mods_loaded = 1; load_init(0); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('l', arg); check_exception(ctx, sexp_load_module_file(ctx, arg, env)); break; case 'x': prefix = sexp_environment_prefix; suffix = sexp_environment_suffix; case 'm': arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); if (c == 'x') { if (strcmp(arg, "chibi.primitive") == 0) { goto load_primitive; } else if (strcmp(arg, "scheme.small") == 0) { load_init(0); break; } } else { prefix = sexp_import_prefix; suffix = sexp_import_suffix; } mods_loaded = 1; load_init(c == 'x'); #if SEXP_USE_MODULES check_nonull_arg(c, arg); impmod = make_import(prefix, arg, suffix); tmp = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, (c=='x' ? sexp_global(ctx, SEXP_G_META_ENV) : env))); free(impmod); if (c == 'x') { sexp_set_parameter(ctx, sexp_global(ctx, SEXP_G_META_ENV), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), tmp); sexp_context_env(ctx) = env = tmp; sexp_add_import_binding(ctx, env); tmp = sexp_param_ref(ctx, env, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL)); if (tmp != NULL && !sexp_oportp(tmp)) { sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0); } } #endif break; load_primitive: case 'Q': init_context(); mods_loaded = 1; if (! init_loaded++) sexp_load_standard_ports(ctx, env, stdin, stdout, stderr, 0); handle_noarg(); break; case 'q': argv[i--] = (char*)"-xchibi"; break; case 'A': init_context(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('A', arg); sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_TRUE); break; case 'I': init_context(); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('I', arg); sexp_add_module_directory(ctx, tmp=sexp_c_string(ctx,arg,-1), SEXP_FALSE); break; #if SEXP_USE_GREEN_THREADS case 'b': nonblocking = 1; break; #endif case '-': if (argv[i][2] == '\0') { i++; goto done_options; } sexp_usage(1); case 'h': arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); check_nonull_arg('h', arg); #if ! SEXP_USE_BOEHM heap_size = strtoul(arg, &arg, 0); if (sexp_isalpha((unsigned char)*arg)) heap_size *= multiplier(*arg++); if (*arg == '/') { heap_max_size = strtoul(arg+1, &arg, 0); if (sexp_isalpha((unsigned char)*arg)) heap_max_size *= multiplier(*arg++); } #endif break; #if SEXP_USE_IMAGE_LOADING case 'i': arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); if (ctx) { fprintf(stderr, "-:i <file>: image files must be loaded first\n"); exit_failure(); } ctx = sexp_load_image(arg, 0, heap_size, heap_max_size); if (!ctx || !sexp_contextp(ctx)) { fprintf(stderr, "-:i <file>: couldn't open image file for reading: %s\n", arg); fprintf(stderr, " %s\n", sexp_load_image_err()); ctx = NULL; } else { env = sexp_load_standard_params(ctx, sexp_context_env(ctx), nonblocking); init_loaded++; } break; case 'd': if (! init_loaded++) { init_context(); env = sexp_load_standard_env(ctx, env, SEXP_SEVEN); } arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); if (sexp_save_image(ctx, arg) != SEXP_TRUE) { fprintf(stderr, "-d <file>: couldn't save image to file: %s\n", arg); fprintf(stderr, " %s\n", sexp_load_image_err()); exit_failure(); } quit = 1; break; #endif case 'V': load_init(1); if (! sexp_oportp(out)) out = sexp_eval_string(ctx, "(current-output-port)", -1, env); sexp_write_string(ctx, sexp_version_string, out); tmp = sexp_env_ref(ctx, env, sym=sexp_intern(ctx, "*features*", -1), SEXP_NULL); sexp_write(ctx, tmp, out); sexp_newline(ctx, out); return SEXP_TRUE; #if SEXP_USE_FOLD_CASE_SYMS case 'f': fold_case = 1; init_context(); sexp_global(ctx, SEXP_G_FOLD_CASE_P) = SEXP_TRUE; handle_noarg(); break; #endif case 'R': main_module = argv[i][2] != '\0' ? argv[i]+2 : (i+1 < argc && argv[i+1][0] != '-') ? argv[++i] : "chibi.repl"; if (main_symbol == NULL) main_symbol = "main"; break; case 'r': main_symbol = argv[i][2] == '\0' ? "main" : argv[i]+2; break; case 's': init_context(); sexp_global(ctx, SEXP_G_STRICT_P) = SEXP_TRUE; handle_noarg(); break; case 'T': init_context(); sexp_global(ctx, SEXP_G_NO_TAIL_CALLS_P) = SEXP_TRUE; handle_noarg(); break; case 't': mods_loaded = 1; load_init(1); arg = ((argv[i][2] == '\0') ? argv[++i] : argv[i]+2); #if SEXP_USE_MODULES check_nonull_arg('t', arg); suffix = strrchr(arg, '.'); sym = sexp_intern(ctx, suffix + 1, -1); *(char*)suffix = '\0'; impmod = make_import(sexp_trace_prefix, arg, sexp_trace_suffix); tmp = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, sexp_meta_env(ctx))); if (!(tmp && sexp_envp(tmp))) { fprintf(stderr, "couldn't find library to trace: %s\n", impmod); } else if (!((sym = sexp_env_cell(ctx, tmp, sym, 0)))) { fprintf(stderr, "couldn't find binding to trace: %s in %s\n", suffix + 1, impmod); } else { sym = sexp_list1(ctx, sym); tmp = check_exception(ctx, sexp_eval_string(ctx, "(environment '(chibi trace))", -1, sexp_meta_env(ctx))); tmp = sexp_env_ref(ctx, tmp, sexp_intern(ctx, "trace-cell", -1), 0); if (tmp && sexp_procedurep(tmp)) check_exception(ctx, sexp_apply(ctx, tmp, sym)); } free(impmod); #endif break; default: fprintf(stderr, "unknown option: %s\n", argv[i]); /* ... FALLTHROUGH ... */ case '?': sexp_usage(1); } } done_options: if (!quit || main_symbol != NULL) { init_context(); /* build argument list */ if (i < argc) for (j=argc-1; j>=i; j--) args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[j],-1), args); if (i >= argc || main_symbol != NULL) args = sexp_cons(ctx, tmp=sexp_c_string(ctx,argv[0],-1), args); load_init(i < argc || main_symbol != NULL); sexp_set_parameter(ctx, sexp_meta_env(ctx), sym=sexp_intern(ctx, sexp_argv_symbol, -1), args); if (i >= argc && main_symbol == NULL) { /* no script or main, run interactively */ repl(ctx, env); } else { #if SEXP_USE_MODULES /* load the module or script */ if (main_module != NULL) { impmod = make_import("(load-module '(", main_module, "))"); env = check_exception(ctx, sexp_eval_string(ctx, impmod, -1, sexp_meta_env(ctx))); if (sexp_vectorp(env)) env = sexp_vector_ref(env, SEXP_ONE); free(impmod); check_exception(ctx, env); if (!sexp_envp(env)) { fprintf(stderr, "couldn't find module: %s\n", main_module); exit_failure(); } } else #endif if (i < argc) { /* script usage */ #if SEXP_USE_MODULES /* reset the environment to have only the `import' and */ /* `cond-expand' bindings */ if (!mods_loaded) { env = sexp_make_env(ctx); sexp_set_parameter(ctx, sexp_meta_env(ctx), sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), env); sexp_context_env(ctx) = env; sym = sexp_intern(ctx, "repl-import", -1); tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_VOID); sym = sexp_intern(ctx, "import", -1); check_exception(ctx, sexp_env_define(ctx, env, sym, tmp)); sym = sexp_intern(ctx, "cond-expand", -1); tmp = sexp_env_cell(ctx, sexp_meta_env(ctx), sym, 0); #if SEXP_USE_RENAME_BINDINGS sexp_env_rename(ctx, env, sym, tmp); #endif sexp_env_define(ctx, env, sym, sexp_cdr(tmp)); } #endif sexp_context_tracep(ctx) = 1; tmp = sexp_env_bindings(env); #if SEXP_USE_MODULES /* use scheme load if possible for better stack traces */ sym = sexp_intern(ctx, "load", -1); tmp = sexp_env_ref(ctx, sexp_meta_env(ctx), sym, SEXP_FALSE); if (sexp_procedurep(tmp)) { sym = sexp_c_string(ctx, argv[i], -1); sym = sexp_list2(ctx, sym, env); tmp = check_exception(ctx, sexp_apply(ctx, tmp, sym)); } else #endif tmp = check_exception(ctx, sexp_load(ctx, sym=sexp_c_string(ctx, argv[i], -1), env)); #if SEXP_USE_WARN_UNDEFS sexp_warn_undefs(ctx, env, tmp, SEXP_VOID); #endif #ifdef EMSCRIPTEN if (sexp_applicablep(tmp)) { sexp_resume_ctx = ctx; sexp_resume_proc = tmp; sexp_preserve_object(ctx, sexp_resume_proc); emscripten_exit_with_live_runtime(); } #endif } /* SRFI-22: run main if specified */ if (main_symbol) { sym = sexp_intern(ctx, main_symbol, -1); tmp = sexp_env_ref(ctx, env, sym, SEXP_FALSE); if (sexp_procedurep(tmp)) { args = sexp_list1(ctx, sexp_cdr(args)); check_exception(ctx, sexp_apply(ctx, tmp, args)); } else { fprintf(stderr, "couldn't find main binding: %s in %s\n", main_symbol, main_module ? main_module : argv[i]); } } } } sexp_gc_release4(ctx); if (sexp_destroy_context(ctx) == SEXP_FALSE) { fprintf(stderr, "destroy_context error\n"); return SEXP_FALSE; } return SEXP_TRUE; }
sexp sexp_scheduler (sexp ctx, sexp self, sexp_sint_t n, sexp root_thread) { int i, k; struct timeval tval; struct pollfd *pfds; useconds_t usecs = 0; sexp res, ls1, ls2, evt, runner, paused, front, pollfds; sexp_gc_var1(tmp); sexp_gc_preserve1(ctx, tmp); front = sexp_global(ctx, SEXP_G_THREADS_FRONT); paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); /* check signals */ if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER); if (! sexp_contextp(runner)) { /* ensure the runner exists */ if (sexp_envp(runner)) { tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1)), 0); if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) { runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE); sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner; sexp_thread_start(ctx, self, 1, runner); if (!sexp_pairp(front)) front = sexp_global(ctx, SEXP_G_THREADS_FRONT); } } } else if (sexp_context_waitp(runner)) { /* wake it if it's sleeping */ sexp_context_waitp(runner) = 0; sexp_thread_start(ctx, self, 1, runner); } } /* check blocked fds */ pollfds = sexp_global(ctx, SEXP_G_THREADS_POLL_FDS); if (sexp_pollfdsp(ctx, pollfds) && sexp_pollfds_num_fds(pollfds) > 0) { pfds = sexp_pollfds_fds(pollfds); k = poll(sexp_pollfds_fds(pollfds), sexp_pollfds_num_fds(pollfds), 0); for (i=sexp_pollfds_num_fds(pollfds)-1; i>=0 && k>0; --i) { if (pfds[i].revents > 0) { /* free all threads blocked on this fd */ k--; /* maybe unblock the current thread */ evt = sexp_context_event(ctx); if ((sexp_portp(evt) && (sexp_port_fileno(evt) == pfds[i].fd)) || (sexp_fixnump(evt) && (sexp_unbox_fixnum(evt) == pfds[i].fd))) { sexp_context_waitp(ctx) = 0; sexp_context_timeoutp(ctx) = 0; sexp_context_event(ctx) = SEXP_FALSE; } /* maybe unblock paused threads */ for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { /* TODO: distinguish input and output on the same fd? */ evt = sexp_context_event(sexp_car(ls2)); if ((sexp_portp(evt) && sexp_port_fileno(evt) == pfds[i].fd) || (sexp_fixnump(evt) && sexp_unbox_fixnum(evt) == pfds[i].fd)) { sexp_context_waitp(sexp_car(ls2)) = 0; sexp_context_timeoutp(sexp_car(ls2)) = 0; sexp_context_event(sexp_car(ls2)) = SEXP_FALSE; if (ls1==SEXP_NULL) sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); else sexp_cdr(ls1) = sexp_cdr(ls2); tmp = sexp_cdr(ls2); sexp_cdr(ls2) = SEXP_NULL; if (sexp_car(ls2) != ctx) { if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; } else { sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; } sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; } ls2 = tmp; } else { ls1 = ls2; ls2 = sexp_cdr(ls2); } } if (i < (sexp_pollfds_num_fds(pollfds) - 1)) { pfds[i] = pfds[sexp_pollfds_num_fds(pollfds) - 1]; } sexp_pollfds_num_fds(pollfds) -= 1; } } } /* if we've terminated, check threads joining us */ if (sexp_context_refuel(ctx) <= 0) { for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { if (sexp_context_event(sexp_car(ls2)) == ctx) { sexp_context_waitp(sexp_car(ls2)) = 0; sexp_context_timeoutp(sexp_car(ls2)) = 0; if (ls1==SEXP_NULL) sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); else sexp_cdr(ls1) = sexp_cdr(ls2); tmp = sexp_cdr(ls2); sexp_cdr(ls2) = SEXP_NULL; if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; } else { sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; } sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; ls2 = tmp; } else { ls1 = ls2; ls2 = sexp_cdr(ls2); } } } /* check timeouts */ if (sexp_pairp(paused)) { if (gettimeofday(&tval, NULL) == 0) { ls1 = SEXP_NULL; ls2 = paused; while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), tval)) { sexp_context_timeoutp(sexp_car(ls2)) = 1; sexp_context_waitp(sexp_car(ls2)) = 0; ls1 = ls2; ls2 = sexp_cdr(ls2); } if (sexp_pairp(ls1)) { sexp_cdr(ls1) = SEXP_NULL; if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused; } else { sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = paused; } sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = ls2; } } } /* dequeue next thread */ if (sexp_pairp(front)) { res = sexp_car(front); if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) { /* orig ctx is either terminated or paused */ sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front); if (! sexp_pairp(sexp_cdr(front))) sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; if (sexp_context_refuel(ctx) > 0 && sexp_not(sexp_memq(ctx, ctx, paused))) sexp_insert_timed(ctx, ctx, SEXP_FALSE); paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); } else { /* swap with front of queue */ sexp_car(sexp_global(ctx, SEXP_G_THREADS_FRONT)) = ctx; /* rotate front of queue to back */ sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_FRONT)); sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)); sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = SEXP_NULL; } } else { /* no threads to dequeue */ res = ctx; /* prefer a thread we can wait on instead of spinning */ if (sexp_context_refuel(ctx) <= 0) { for (ls1=paused; sexp_pairp(ls1); ls1=sexp_cdr(ls1)) { evt = sexp_context_event(sexp_car(ls1)); if (sexp_fixnump(evt) || sexp_portp(evt)) { res = sexp_car(ls1); break; } } } } if (sexp_context_waitp(res)) { /* the only thread available was waiting */ if (sexp_pairp(paused) && sexp_context_before(sexp_car(paused), sexp_context_timeval(res))) { tmp = res; res = sexp_car(paused); paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(paused); if (sexp_not(sexp_memq(ctx, tmp, paused))) sexp_insert_timed(ctx, tmp, tmp); } else { sexp_delete_list(ctx, SEXP_G_THREADS_PAUSED, res); } paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); usecs = 0; if ((sexp_context_timeval(res).tv_sec == 0) && (sexp_context_timeval(res).tv_usec == 0)) { /* no timeout, wait for default 10ms */ usecs = 10*1000; } else { /* wait until the next timeout */ gettimeofday(&tval, NULL); if (tval.tv_sec <= sexp_context_timeval(res).tv_sec) { usecs = (sexp_context_timeval(res).tv_sec - tval.tv_sec) * 1000000; if (tval.tv_usec < sexp_context_timeval(res).tv_usec || usecs > 0) usecs += sexp_context_timeval(res).tv_usec - tval.tv_usec; } } /* take a nap to avoid busy looping */ usleep(usecs); sexp_context_waitp(res) = 0; sexp_context_timeoutp(res) = 1; } sexp_gc_release1(ctx); return res; }
sexp sexp_scheduler (sexp ctx, sexp self, sexp_sint_t n, sexp root_thread) { int i, k; struct timeval tval; struct pollfd *pfds; useconds_t usecs = 0; sexp res, ls1, ls2, runner, paused, front, pollfds; sexp_gc_var1(tmp); sexp_gc_preserve1(ctx, tmp); front = sexp_global(ctx, SEXP_G_THREADS_FRONT); paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED); /* check signals */ if (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { runner = sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER); if (! sexp_contextp(runner)) { /* ensure the runner exists */ if (sexp_envp(runner)) { tmp = sexp_env_cell(runner, (tmp=sexp_intern(ctx, "signal-runner", -1)), 0); if (sexp_pairp(tmp) && sexp_procedurep(sexp_cdr(tmp))) { runner = sexp_make_thread(ctx, self, 2, sexp_cdr(tmp), SEXP_FALSE); sexp_global(ctx, SEXP_G_THREADS_SIGNAL_RUNNER) = runner; sexp_thread_start(ctx, self, 1, runner); } } } else if (sexp_context_waitp(runner)) { /* wake it if it's sleeping */ sexp_context_waitp(runner) = 0; sexp_thread_start(ctx, self, 1, runner); } } /* check blocked fds */ pollfds = sexp_global(ctx, SEXP_G_THREADS_POLL_FDS); if (sexp_pollfdsp(ctx, pollfds) && sexp_pollfds_num_fds(pollfds) > 0) { pfds = sexp_pollfds_fds(pollfds); k = poll(sexp_pollfds_fds(pollfds), sexp_pollfds_num_fds(pollfds), 0); unblock_io_threads: for (i=sexp_pollfds_num_fds(pollfds)-1; i>=0 && k>0; --i) { if (pfds[i].revents > 0) { /* free all threads blocked on this fd */ k--; pfds[i].events = 0; /* FIXME: delete from queue completely */ for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { /* FIXME distinguish input and output on the same fd */ if (sexp_portp(sexp_context_event(sexp_car(ls2))) && sexp_port_fileno(sexp_context_event(sexp_car(ls2))) == pfds[i].fd) { sexp_context_waitp(sexp_car(ls2)) = 0; sexp_context_timeoutp(sexp_car(ls2)) = 0; if (ls1==SEXP_NULL) sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); else sexp_cdr(ls1) = sexp_cdr(ls2); tmp = sexp_cdr(ls2); sexp_cdr(ls2) = SEXP_NULL; if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; } else { sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; } sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; ls2 = tmp; } else { ls1 = ls2; ls2 = sexp_cdr(ls2); } } } } } /* if we've terminated, check threads joining us */ if (sexp_context_refuel(ctx) <= 0) { for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { if (sexp_context_event(sexp_car(ls2)) == ctx) { sexp_context_waitp(sexp_car(ls2)) = 0; sexp_context_timeoutp(sexp_car(ls2)) = 0; if (ls1==SEXP_NULL) sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = sexp_cdr(ls2); else sexp_cdr(ls1) = sexp_cdr(ls2); tmp = sexp_cdr(ls2); sexp_cdr(ls2) = SEXP_NULL; if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2; } else { sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = ls2; } sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2; ls2 = tmp; } else { ls1 = ls2; ls2 = sexp_cdr(ls2); } } } /* check timeouts */ if (sexp_pairp(paused)) { if (gettimeofday(&tval, NULL) == 0) { ls1 = SEXP_NULL; ls2 = paused; while (sexp_pairp(ls2) && sexp_context_before(sexp_car(ls2), tval)) { sexp_context_timeoutp(sexp_car(ls2)) = 1; sexp_context_waitp(ctx) = 0; ls1 = ls2; ls2 = sexp_cdr(ls2); } if (sexp_pairp(ls1)) { sexp_cdr(ls1) = SEXP_NULL; if (! sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) { sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused; } else { sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = paused; } sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1; sexp_global(ctx, SEXP_G_THREADS_PAUSED) = paused = ls2; } } } /* dequeue next thread */ if (sexp_pairp(front)) { res = sexp_car(front); if ((sexp_context_refuel(ctx) <= 0) || sexp_context_waitp(ctx)) { /* either terminated or paused */ sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(front); if (! sexp_pairp(sexp_cdr(front))) sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; } else { /* swap with front of queue */ sexp_car(sexp_global(ctx, SEXP_G_THREADS_FRONT)) = ctx; /* rotate front of queue to back */ sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_FRONT)); sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)); sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = SEXP_NULL; } } else { res = ctx; } if (sexp_context_waitp(res)) { /* the only thread available was waiting */ if (sexp_pairp(paused) && sexp_context_before(sexp_car(paused), sexp_context_timeval(res))) { tmp = res; res = sexp_car(paused); sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(paused); if (sexp_not(sexp_memq(ctx, tmp, paused))) sexp_insert_timed(ctx, tmp, tmp); } usecs = 0; if ((sexp_context_timeval(res).tv_sec == 0) && (sexp_context_timeval(res).tv_usec == 0)) { /* no timeout, wait for default 10ms */ usecs = 10*1000; } else { /* wait until the next timeout */ gettimeofday(&tval, NULL); if (tval.tv_sec <= sexp_context_timeval(res).tv_sec) { usecs = (sexp_context_timeval(res).tv_sec - tval.tv_sec) * 1000000; if (tval.tv_usec < sexp_context_timeval(res).tv_usec || usecs > 0) usecs += sexp_context_timeval(res).tv_usec - tval.tv_usec; } } /* either wait on an fd, or just sleep */ pollfds = sexp_global(res, SEXP_G_THREADS_POLL_FDS); if (sexp_portp(sexp_context_event(res)) && sexp_pollfdsp(ctx, pollfds)) { if ((k = poll(sexp_pollfds_fds(pollfds), sexp_pollfds_num_fds(pollfds), usecs/1000)) > 0) { pfds = sexp_pollfds_fds(pollfds); goto unblock_io_threads; } } else { usleep(usecs); sexp_context_waitp(res) = 0; sexp_context_timeoutp(res) = 1; } } sexp_gc_release1(ctx); return res; }