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; }