sexp sexp_mutex_unlock (sexp ctx, sexp self, sexp_sint_t n, sexp mutex, sexp condvar, sexp timeout) {
sexp ls1, ls2;
/* first unlock and unblock threads */
if (sexp_truep(sexp_mutex_lockp(mutex))) {
sexp_mutex_lockp(mutex) = SEXP_FALSE;
sexp_mutex_thread(mutex) = ctx;
/* search for threads blocked on this mutex */
for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
if (sexp_context_event(sexp_car(ls2)) == mutex) {
if (ls1==SEXP_NULL)
sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
else
sexp_cdr(ls1) = sexp_cdr(ls2);
sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
if (! sexp_pairp(sexp_cdr(ls2)))
sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
sexp_context_waitp(sexp_car(ls2))
= sexp_context_timeoutp(sexp_car(ls2)) = 0;
break;
}
}
if (sexp_truep(condvar)) {
/* wait on condition var if specified */
sexp_context_waitp(ctx) = 1;
sexp_context_event(ctx) = condvar;
sexp_insert_timed(ctx, ctx, timeout);
return SEXP_FALSE;
}
return SEXP_TRUE;
}
sexp sexp_mutex_unlock (sexp ctx sexp_api_params(self, n), sexp mutex, sexp condvar, sexp timeout) {
sexp ls1, ls2;
if (sexp_not(condvar)) {
/* normal unlock - always succeeds, just need to unblock threads */
if (sexp_truep(sexp_mutex_lockp(mutex))) {
sexp_mutex_lockp(mutex) = SEXP_FALSE;
sexp_mutex_thread(mutex) = ctx;
/* search for threads blocked on this mutex */
for (ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
if (sexp_context_event(sexp_car(ls2)) == mutex) {
if (ls1==SEXP_NULL)
sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
else
sexp_cdr(ls1) = sexp_cdr(ls2);
sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
if (! sexp_pairp(sexp_cdr(ls2)))
sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
sexp_context_waitp(sexp_car(ls2))
= sexp_context_timeoutp(sexp_car(ls2)) = 0;
break;
}
}
return SEXP_TRUE;
} else {
/* wait on condition var */
sexp_context_waitp(ctx) = 1;
sexp_context_event(ctx) = condvar;
sexp_insert_timed(ctx, ctx, timeout);
return SEXP_FALSE;
}
}
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);
}
static sexp sexp_qsort_less (sexp ctx, sexp *vec,
sexp_sint_t lo, sexp_sint_t hi,
sexp less, sexp key) {
sexp_sint_t mid, i, j;
sexp tmp, res, args1;
sexp_gc_var3(a, b, args2);
sexp_gc_preserve3(ctx, a, b, args2);
args2 = sexp_list2(ctx, SEXP_VOID, SEXP_VOID);
args1 = sexp_cdr(args2);
loop:
if (lo >= hi) {
res = SEXP_VOID;
} else {
mid = lo + (hi-lo)/2;
swap(tmp, vec[mid], vec[hi]);
if (sexp_truep(key)) {
sexp_car(args1) = tmp;
b = sexp_apply(ctx, key, args1);
} else {
b = tmp;
}
for (i=j=lo; i < hi; i++) {
if (sexp_truep(key)) {
sexp_car(args1) = vec[i];
a = sexp_apply(ctx, key, args1);
} else {
a = vec[i];
}
sexp_car(args2) = a;
sexp_car(args1) = b;
res = sexp_apply(ctx, less, args2);
if (sexp_exceptionp(res))
goto done;
else if (sexp_truep(res))
swap(res, vec[i], vec[j]), j++;
}
swap(tmp, vec[j], vec[hi]);
res = sexp_qsort_less(ctx, vec, lo, j-1, less, key);
if (sexp_exceptionp(res))
goto done;
if (j < hi-1) {
lo = j;
goto loop; /* tail recurse on right side */
}
}
done:
sexp_gc_release3(ctx);
return res;
}
sexp sexp_thread_list (sexp ctx, sexp self, sexp_sint_t n) {
sexp ls;
sexp_gc_var1(res);
sexp_gc_preserve1(ctx, res);
res = SEXP_NULL;
#if SEXP_USE_GREEN_THREADS
for (ls=sexp_global(ctx, SEXP_G_THREADS_FRONT); sexp_pairp(ls); ls=sexp_cdr(ls))
sexp_push(ctx, res, sexp_car(ls));
for (ls=sexp_global(ctx, SEXP_G_THREADS_PAUSED); sexp_pairp(ls); ls=sexp_cdr(ls))
sexp_push(ctx, res, sexp_car(ls));
#endif
if (sexp_not(sexp_memq(ctx, ctx, res))) sexp_push(ctx, res, ctx);
sexp_gc_release1(ctx);
return res;
}
static int usedp (sexp lambda, sexp var, sexp x) {
sexp ls;
loop:
switch (sexp_pointerp(x) ? sexp_pointer_tag(x) : 0) {
case SEXP_REF:
return sexp_ref_name(x) == var && sexp_ref_loc(x) == lambda;
case SEXP_SET:
x = sexp_set_value(x);
goto loop;
case SEXP_LAMBDA:
x = sexp_lambda_body(x);
goto loop;
case SEXP_CND:
if (usedp(lambda, var, sexp_cnd_test(x))
|| usedp(lambda, var, sexp_cnd_pass(x)))
return 1;
x = sexp_cnd_fail(x);
goto loop;
case SEXP_SEQ:
x = sexp_seq_ls(x);
case SEXP_PAIR:
for (ls=x; sexp_pairp(ls); ls=sexp_cdr(ls))
if (usedp(lambda, var, sexp_car(ls)))
return 1;
}
return 0;
}
static void sexp_print_simple (sexp ctx, sexp x, sexp out, int depth) {
int i;
if ((!sexp_pointerp(x)) || sexp_symbolp(x) || sexp_stringp(x)
|| sexp_flonump(x) || sexp_bignump(x)) {
sexp_write(ctx, x, out);
} else if (depth <= 0) {
goto print_name;
} else if (sexp_synclop(x)) {
sexp_write_string(ctx, "#<sc ", out);
sexp_print_simple(ctx, sexp_synclo_expr(x), out, depth);
sexp_write_string(ctx, ">", out);
} else if (sexp_pairp(x)) {
sexp_write_char(ctx, '(', out);
sexp_print_simple(ctx, sexp_car(x), out, depth-1);
sexp_write_string(ctx, " . ", out);
sexp_print_simple(ctx, sexp_cdr(x), out, depth-1);
sexp_write_char(ctx, ')', out);
} else if (sexp_vectorp(x)) {
sexp_write_string(ctx, "#(", out);
for (i=0; i<SEXP_HEAP_VECTOR_DEPTH && i<(int)sexp_vector_length(x); i++) {
if (i>0)
sexp_write_char(ctx, ' ', out);
sexp_print_simple(ctx, sexp_vector_ref(x, i), out, depth-1);
}
if (i<(int)sexp_vector_length(x))
sexp_write_string(ctx, " ...", out);
sexp_write_char(ctx, ')', out);
} else {
print_name:
sexp_write_string(ctx, "#<", out);
sexp_write(ctx, sexp_object_type_name(ctx, x), out);
sexp_write_string(ctx, ">", out);
}
}
static sexp sexp_vector_copy_to_list (sexp ctx, sexp vec, sexp seq) {
sexp_sint_t i;
sexp ls, *data=sexp_vector_data(vec);
for (i=0, ls=seq; sexp_pairp(ls); i++, ls=sexp_cdr(ls))
sexp_car(ls) = data[i];
return seq;
}
sexp sexp_condition_variable_signal (sexp ctx, sexp self, sexp_sint_t n, sexp condvar) {
sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
for ( ; sexp_pairp(ls2); ls1=ls2, ls2=sexp_cdr(ls2))
if (sexp_context_event(sexp_car(ls2)) == condvar) {
if (ls1==SEXP_NULL)
sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
else
sexp_cdr(ls1) = sexp_cdr(ls2);
sexp_cdr(ls2) = sexp_global(ctx, SEXP_G_THREADS_FRONT);
sexp_global(ctx, SEXP_G_THREADS_FRONT) = ls2;
if (! sexp_pairp(sexp_cdr(ls2)))
sexp_global(ctx, SEXP_G_THREADS_BACK) = ls2;
sexp_context_waitp(sexp_car(ls2)) = sexp_context_timeoutp(sexp_car(ls2)) = 0;
return SEXP_TRUE;
}
return SEXP_FALSE;
}
sexp sexp_exec (sexp ctx, sexp self, sexp_sint_t n, sexp name, sexp args) {
int i, len = sexp_unbox_fixnum(sexp_length(ctx, args));
char **argv = malloc((len+1)*sizeof(char*));
for (i=0; i<len; i++, args=sexp_cdr(args))
argv[i] = sexp_string_data(sexp_car(args));
argv[len] = NULL;
exec(sexp_string_data(name), argv);
return SEXP_VOID; /* won't really return */
}
static int sexp_delete_list (sexp ctx, int global, sexp x) {
sexp ls1=NULL, ls2=sexp_global(ctx, global);
for ( ; sexp_pairp(ls2) && sexp_car(ls2) != x; ls1=ls2, ls2=sexp_cdr(ls2))
;
if (sexp_pairp(ls2)) {
if (ls1) sexp_cdr(ls1) = sexp_cdr(ls2);
else sexp_global(ctx, global) = sexp_cdr(ls2);
return 1;
} else {
return 0;
}
}
static sexp sexp_open_pipe_stub (sexp ctx, sexp self, sexp_sint_t n) {
int i, err;
int tmp0[2];
sexp res;
sexp_gc_var1(res0);
sexp_gc_preserve1(ctx, res0);
err = pipe(tmp0);
if (err) {
res = SEXP_FALSE;
} else {
res0 = SEXP_NULL;
for (i=2-1; i>=0; i--) {
sexp_push(ctx, res0, SEXP_VOID);
sexp_car(res0) = sexp_make_fileno(ctx, sexp_make_fixnum(tmp0[i]), SEXP_FALSE);
}
res = res0;
}
sexp_gc_release1(ctx);
return res;
}
static sexp simplify (sexp ctx, sexp ast, sexp init_substs, sexp lambda) {
int check;
sexp ls1, ls2, p1, p2, sv;
sexp_gc_var5(res, substs, tmp, app, ctx2);
sexp_gc_preserve5(ctx, res, substs, tmp, app, ctx2);
res = ast; /* return the ast as-is by default */
substs = init_substs;
loop:
switch (sexp_pointerp(res) ? sexp_pointer_tag(res) : 0) {
case SEXP_PAIR:
/* don't simplify the operator if it's a lambda because we
simplify that as a special case below, with the appropriate
substs list */
app = sexp_list1(ctx, sexp_lambdap(sexp_car(res)) ? sexp_car(res)
: (tmp=simplify(ctx, sexp_car(res), substs, lambda)));
sexp_pair_source(app) = sexp_pair_source(res);
for (ls1=sexp_cdr(res); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
sexp_push(ctx, app, tmp=simplify(ctx, sexp_car(ls1), substs, lambda));
if (sexp_pairp(app)) sexp_pair_source(app) = sexp_pair_source(ls1);
}
app = sexp_nreverse(ctx, app);
/* app now holds a copy of the list, and is the default result
(res = app below) if we don't replace it with a simplification */
if (sexp_opcodep(sexp_car(app))) {
/* opcode app - right now we just constant fold arithmetic */
if (sexp_opcode_class(sexp_car(app)) == SEXP_OPC_ARITHMETIC) {
for (check=1, ls1=sexp_cdr(app); sexp_pairp(ls1); ls1=sexp_cdr(ls1)) {
if (sexp_pointerp(sexp_car(ls1)) && ! sexp_litp(sexp_car(ls1))) {
check = 0;
break;
}
}
if (check) {
ctx2 = sexp_make_eval_context(ctx, NULL, sexp_context_env(ctx), 0, 0);
sexp_generate(ctx2, 0, 0, 0, app);
res = sexp_complete_bytecode(ctx2);
if (! sexp_exceptionp(res)) {
tmp = sexp_make_vector(ctx2, 0, SEXP_VOID);
tmp = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, tmp);
if (! sexp_exceptionp(tmp)) {
tmp = sexp_apply(ctx2, tmp, SEXP_NULL);
if (! sexp_exceptionp(tmp))
app = sexp_make_lit(ctx2, tmp);
}
}
}
}
} else if (lambda && sexp_lambdap(sexp_car(app))) { /* let */
p1 = NULL;
p2 = sexp_lambda_params(sexp_car(app));
ls1 = app;
ls2 = sexp_cdr(app);
sv = sexp_lambda_sv(sexp_car(app));
if (sexp_length(ctx, p2) == sexp_length(ctx, ls2)) {
for ( ; sexp_pairp(ls2); ls2=sexp_cdr(ls2), p2=sexp_cdr(p2)) {
if (sexp_not(sexp_memq(ctx, sexp_car(p2), sv))
&& (! sexp_pointerp(sexp_car(ls2)) || sexp_litp(sexp_car(ls2))
|| (sexp_refp(sexp_car(ls2))
&& sexp_lambdap(sexp_ref_loc(sexp_car(ls2)))
&& sexp_not(sexp_memq(ctx, sexp_ref_name(sexp_car(ls2)),
sexp_lambda_sv(sexp_ref_loc(sexp_car(ls2)))))))) {
tmp = sexp_cons(ctx, sexp_car(app), sexp_car(ls2));
tmp = sexp_cons(ctx, sexp_car(p2), tmp);
sexp_push(ctx, substs, tmp);
sexp_cdr(ls1) = sexp_cdr(ls2);
if (p1)
sexp_cdr(p1) = sexp_cdr(p2);
else
sexp_lambda_params(sexp_car(app)) = sexp_cdr(p2);
} else {
p1 = p2;
ls1 = ls2;
}
}
sexp_lambda_body(sexp_car(app))
= simplify(ctx, sexp_lambda_body(sexp_car(app)), substs, sexp_car(app));
if (sexp_nullp(sexp_cdr(app))
&& sexp_nullp(sexp_lambda_params(sexp_car(app)))
&& sexp_nullp(sexp_lambda_defs(sexp_car(app))))
app = sexp_lambda_body(sexp_car(app));
}
}
res = app;
break;
case SEXP_LAMBDA:
sexp_lambda_body(res) = simplify(ctx, sexp_lambda_body(res), substs, res);
break;
case SEXP_CND:
tmp = simplify(ctx, sexp_cnd_test(res), substs, lambda);
if (sexp_litp(tmp) || ! sexp_pointerp(tmp)) {
res = sexp_not((sexp_litp(tmp) ? sexp_lit_value(tmp) : tmp))
? sexp_cnd_fail(res) : sexp_cnd_pass(res);
goto loop;
} else {
sexp_cnd_test(res) = tmp;
simplify_it(sexp_cnd_pass(res));
simplify_it(sexp_cnd_fail(res));
}
break;
case SEXP_REF:
tmp = sexp_ref_name(res);
for (ls1=substs; sexp_pairp(ls1); ls1=sexp_cdr(ls1))
if ((sexp_caar(ls1) == tmp) && (sexp_cadar(ls1) == sexp_ref_loc(res))) {
res = sexp_cddar(ls1);
break;
}
break;
case SEXP_SET:
simplify_it(sexp_set_value(res));
break;
case SEXP_SEQ:
app = SEXP_NULL;
for (ls2=sexp_seq_ls(res); sexp_pairp(ls2); ls2=sexp_cdr(ls2)) {
tmp = simplify(ctx, sexp_car(ls2), substs, lambda);
if (! (sexp_pairp(sexp_cdr(ls2))
&& (sexp_litp(tmp) || ! sexp_pointerp(tmp) || sexp_refp(tmp)
|| sexp_lambdap(tmp))))
sexp_push(ctx, app, tmp);
}
if (sexp_pairp(app) && sexp_nullp(sexp_cdr(app)))
res = sexp_car(app);
else
sexp_seq_ls(res) = sexp_nreverse(ctx, app);
break;
}
sexp_gc_release5(ctx);
return res;
}
static sexp sexp_heap_stats (sexp ctx, sexp self, sexp_sint_t n) {
sexp res = sexp_heap_walk(ctx, 0, 0);
return sexp_pairp(res) ? sexp_car(res) : 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, 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;
}
void sexp_build_srv (sexp ctx, sexp_plan9_srv s, sexp ls) {
s->context = ctx;
s->auth = s->attach = s->walk = s->walk1 = s->clone = s->open
= s->create = s->remove = s->read = s->write = s->stat = s->wstat
= s->flush = s->destroyfid = s->destroyreq = s->end = SEXP_FALSE;
for ( ; sexp_pairp(ls) && sexp_pairp(sexp_cdr(ls)); ls=sexp_cddr(ls)) {
if (sexp_car(ls) == sexp_intern(ctx, "auth:", -1)) {
s->auth = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "attach:", -1)) {
s->attach = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "walk:", -1)) {
s->walk = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "walk1:", -1)) {
s->walk1 = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "clone:", -1)) {
s->clone = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "open:", -1)) {
s->open = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "create:", -1)) {
s->create = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "remove:", -1)) {
s->remove = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "read:", -1)) {
s->read = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "write:", -1)) {
s->write = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "stat:", -1)) {
s->stat = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "wstat:", -1)) {
s->wstat = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "flush:", -1)) {
s->flush = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "destroyfid:", -1)) {
s->destroyfid = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "destroyreq:", -1)) {
s->destroyreq = sexp_cadr(ls);
} else if (sexp_car(ls) == sexp_intern(ctx, "end:", -1)) {
s->end = sexp_cadr(ls);
}
}
}