sexp sexp_string_count (sexp ctx, sexp self, sexp ch, sexp str, sexp start, sexp end) {
const unsigned char *s, *e;
sexp_sint_t c, count = 0;
#if SEXP_USE_UTF8_STRINGS
sexp_sint_t i;
#endif
sexp_assert_type(ctx, sexp_charp, SEXP_CHAR, ch);
sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, str);
sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, start);
if (sexp_not(end)) end = sexp_make_fixnum(sexp_string_size(str));
else sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, end);
c = sexp_unbox_character(ch);
#if SEXP_USE_UTF8_STRINGS
if (c < 128) {
#endif
s = (unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(start);
e = (unsigned char*)sexp_string_data(str) + sexp_unbox_fixnum(end);
if (e > (unsigned char*)sexp_string_data(str) + sexp_string_size(str))
return sexp_user_exception(ctx, self, "string-count: end index out of range", end);
/* fast case for ASCII chars */
while (s < e) if (*s++ == c) count++;
#if SEXP_USE_UTF8_STRINGS
} else {
/* decode utf8 chars */
s = (unsigned char*)sexp_string_data(str);
for (i = sexp_unbox_fixnum(start); i < sexp_unbox_fixnum(end);
i += sexp_utf8_initial_byte_count(s[i]))
if (sexp_string_utf8_ref(ctx, str, sexp_make_fixnum(i)) == ch) count++;
}
#endif
return sexp_make_fixnum(count);
}
sexp sexp_mutex_unlock (sexp ctx, sexp self, sexp_sint_t 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 int sexp_basic_comparator (sexp op) {
if (sexp_not(op))
return 1;
if (! sexp_opcodep(op))
return 0;
if (sexp_opcode_class(op) == SEXP_OPC_ARITHMETIC_CMP)
return 1;
return 0;
}
sexp sexp_mutex_lock (sexp ctx, sexp self, sexp_sint_t n, sexp mutex, sexp timeout, sexp thread) {
if (thread == SEXP_TRUE)
thread = ctx;
if (sexp_not(sexp_mutex_lockp(mutex))) {
sexp_mutex_lockp(mutex) = SEXP_TRUE;
sexp_mutex_thread(mutex) = thread;
return SEXP_TRUE;
} else {
sexp_context_waitp(ctx) = 1;
sexp_context_event(ctx) = mutex;
sexp_insert_timed(ctx, ctx, timeout);
return SEXP_FALSE;
}
}
static sexp sexp_sort_x (sexp ctx sexp_api_params(self, n), sexp seq,
sexp less, sexp key) {
sexp_sint_t len;
sexp res, *data;
sexp_gc_var1(vec);
if (sexp_nullp(seq)) return seq;
sexp_gc_preserve1(ctx, vec);
vec = (sexp_truep(sexp_listp(ctx, seq)) ? sexp_list_to_vector(ctx, seq) : seq);
if (! sexp_vectorp(vec)) {
res = sexp_type_exception(ctx, self, SEXP_VECTOR, vec);
} else {
data = sexp_vector_data(vec);
len = sexp_vector_length(vec);
if (sexp_not(key) && sexp_basic_comparator(less)) {
sexp_qsort(ctx, data, 0, len-1);
if (sexp_opcodep(less) && sexp_opcode_inverse(less))
sexp_vector_nreverse(ctx, vec);
res = vec;
} else if (! (sexp_procedurep(less) || sexp_opcodep(less))) {
res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, less);
} else if (! (sexp_procedurep(key) || sexp_opcodep(key) || sexp_not(key))) {
res = sexp_type_exception(ctx, self, SEXP_PROCEDURE, key);
} else {
res = sexp_qsort_less(ctx, data, 0, len-1, less, key);
}
}
if (sexp_pairp(seq) && ! sexp_exceptionp(res))
res = sexp_vector_copy_to_list(ctx, vec, seq);
sexp_gc_release1(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 sexp sexp_set_time_of_day_x_stub (sexp ctx, sexp self, sexp_sint_t n, sexp arg0, sexp arg1) {
int err;
sexp res;
if (! (sexp_pointerp(arg0) && (sexp_pointer_tag(arg0) == sexp_unbox_fixnum(sexp_opcode_arg1_type(self)))))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg1_type(self)), arg0);
if (! ((sexp_pointerp(arg1) && (sexp_pointer_tag(arg1) == sexp_unbox_fixnum(sexp_opcode_arg2_type(self)))) || sexp_not(arg1)))
return sexp_type_exception(ctx, self, sexp_unbox_fixnum(sexp_opcode_arg2_type(self)), arg1);
err = settimeofday((struct timeval*)sexp_cpointer_value(arg0), (struct timezone*)sexp_cpointer_maybe_null_value(arg1));
if (err) {
res = SEXP_FALSE;
} else {
res = SEXP_TRUE;
}
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, 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;
}
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;
}
