diff --git a/eval.c b/eval.c index db81b9b0..272a7cd1 100644 --- a/eval.c +++ b/eval.c @@ -349,6 +349,7 @@ void sexp_init_eval_context_globals (sexp ctx) { #if SEXP_USE_GREEN_THREADS sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL; sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL; + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = SEXP_ZERO; #endif sexp_gc_release3(ctx); } @@ -1599,7 +1600,10 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); #endif #if SEXP_USE_UTF8_STRINGS - sexp_push(ctx, tmp, sym=sexp_intern(ctx, "boehm-gc", -1)); + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "utf-8", -1)); +#endif +#if SEXP_USE_GREEN_THREADS + sexp_push(ctx, tmp, sym=sexp_intern(ctx, "threads", -1)); #endif sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 11d9e0f7..dd3de98d 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -879,6 +879,7 @@ enum sexp_context_globals { SEXP_G_THREADS_BACK, SEXP_G_THREADS_PAUSED, SEXP_G_THREADS_LOCAL, + SEXP_G_THREADS_SIGNALS, #endif SEXP_G_NUM_GLOBALS }; diff --git a/lib/chibi/process.module b/lib/chibi/process.module index fe03c2e5..372b56e4 100644 --- a/lib/chibi/process.module +++ b/lib/chibi/process.module @@ -13,5 +13,6 @@ signal/stop signal/tty-stop signal/tty-input signal/tty-output) (import-immutable (scheme)) + (cond-expand (threads (import (srfi 18))) (else #f)) (include-shared "process")) diff --git a/lib/chibi/process.stub b/lib/chibi/process.stub index 44f27953..93b08d95 100644 --- a/lib/chibi/process.stub +++ b/lib/chibi/process.stub @@ -70,3 +70,4 @@ (define-c void exit (int)) (define-c int (execute execvp) (string (array string))) +(c-init "sexp_init_signals(ctx, env);") diff --git a/lib/chibi/signal.c b/lib/chibi/signal.c index ea23929f..ee82bb6c 100644 --- a/lib/chibi/signal.c +++ b/lib/chibi/signal.c @@ -1,40 +1,42 @@ -/* signal.c -- process signals interface */ -/* Copyright (c) 2009 Alex Shinn. All rights reserved. */ -/* BSD-style license: http://synthcode.com/license.txt */ +/* signal.c -- process signals interface */ +/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* BSD-style license: http://synthcode.com/license.txt */ #define SEXP_MAX_SIGNUM 32 static sexp sexp_signal_contexts[SEXP_MAX_SIGNUM]; +static struct sigaction call_sigaction, call_sigdefault, call_sigignore; + static void sexp_call_sigaction (int signum, siginfo_t *info, void *uctx) { - sexp ctx, sigctx, handler; + sexp ctx; +#if ! SEXP_USE_GREEN_THREADS + sexp sigctx, handler; sexp_gc_var1(args); +#endif ctx = sexp_signal_contexts[signum]; if (ctx) { +#if SEXP_USE_GREEN_THREADS + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = + (sexp) ((sexp_uint_t)sexp_global(ctx, SEXP_G_THREADS_SIGNALS) + | (sexp_uint_t)sexp_make_fixnum(signum)); +#else handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), sexp_make_fixnum(signum)); - if (sexp_truep(handler)) { + if (sexp_applicablep(handler)) { sigctx = sexp_make_child_context(ctx, NULL); sexp_gc_preserve1(sigctx, args); args = sexp_cons(sigctx, SEXP_FALSE, SEXP_NULL); sexp_car(args) = sexp_make_cpointer(sigctx, sexp_siginfo_t_type_id, info, SEXP_FALSE, 0); - args = sexp_cons(sigctx, SEXP_FALSE, args); - sexp_car(args) = sexp_make_fixnum(signum); + args = sexp_cons(sigctx, sexp_make_fixnum(signum), args); sexp_apply(sigctx, handler, args); sexp_gc_release1(sigctx); } +#endif } } -static struct sigaction call_sigaction = { - .sa_sigaction = sexp_call_sigaction, - .sa_flags = SA_SIGINFO | SA_NODEFER -}; - -static struct sigaction call_sigdefault = {.sa_handler = SIG_DFL}; -static struct sigaction call_sigignore = {.sa_handler = SIG_IGN}; - static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newaction) { int res; sexp oldaction; @@ -60,3 +62,15 @@ static sexp sexp_set_signal_action (sexp ctx, sexp self, sexp signum, sexp newac return oldaction; } +static void sexp_init_signals (sexp ctx, sexp env) { + call_sigaction.sa_sigaction = sexp_call_sigaction; +#if SEXP_USE_GREEN_THREADS + call_sigaction.sa_flags = SA_SIGINFO /* | SA_NODEFER */; + sigfillset(&call_sigaction.sa_mask); +#else + call_sigaction.sa_flags = SA_SIGINFO | SA_NODEFER; +#endif + call_sigdefault.sa_handler = SIG_DFL; + call_sigignore.sa_handler = SIG_IGN; + memset(sexp_signal_contexts, 0, sizeof(sexp_signal_contexts)); +} diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c index 046d8bf4..b638b1d9 100644 --- a/lib/srfi/18/threads.c +++ b/lib/srfi/18/threads.c @@ -264,12 +264,41 @@ void sexp_wait_on_single_thread (sexp ctx) { usleep(usecs); } +static const sexp_uint_t sexp_log2_lookup[32] = { + 0, 1, 28, 2, 29, 14, 24, 3, 30, 22, 20, 15, 25, 17, 4, 8, + 31, 27, 13, 23, 21, 19, 16, 7, 26, 12, 18, 6, 11, 5, 10, 9 +}; + +/* only works on powers of two */ +static sexp_uint_t sexp_log2_of_pow2 (sexp_uint_t n) { + return sexp_log2_lookup[(n * 0x077CB531U) >> 27]; +} + sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { struct timeval tval; - sexp res, ls1, ls2, tmp, paused, front=sexp_global(ctx, SEXP_G_THREADS_FRONT); + int allsigs, restsigs, signum; + sexp res, ls1, ls2, handler, paused, front; + 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); + /* run signal handlers */ + while (sexp_global(ctx, SEXP_G_THREADS_SIGNALS) != SEXP_ZERO) { + allsigs = sexp_unbox_fixnum(sexp_global(ctx, SEXP_G_THREADS_SIGNALS)); + restsigs = allsigs & (allsigs-1); + sexp_global(ctx, SEXP_G_THREADS_SIGNALS) = sexp_make_fixnum(restsigs); + signum = sexp_log2_of_pow2(allsigs-restsigs); + handler = sexp_vector_ref(sexp_global(ctx, SEXP_G_SIGNAL_HANDLERS), + sexp_make_fixnum(signum)); + if (sexp_applicablep(handler)) { + tmp = sexp_cons(ctx, SEXP_FALSE, SEXP_NULL); + tmp = sexp_cons(ctx, sexp_make_fixnum(signum), tmp); + sexp_apply(ctx, handler, tmp); + } + } + /* if we've terminated, check threads joining us */ if (sexp_context_refuel(ctx) <= 0) { for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ) { @@ -351,6 +380,7 @@ sexp sexp_scheduler (sexp ctx sexp_api_params(self, n), sexp root_thread) { sexp_context_waitp(res) = 0; } + sexp_gc_release1(ctx); return res; } diff --git a/tools/genstubs.scm b/tools/genstubs.scm index 89900c0d..e75d9a92 100755 --- a/tools/genstubs.scm +++ b/tools/genstubs.scm @@ -141,6 +141,7 @@ (define *types* '()) (define *funcs* '()) (define *consts* '()) +(define *inits* '()) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; type objects @@ -392,6 +393,9 @@ (define (c-system-include header) (cat "\n#include <" header ">\n")) +(define (c-init x) + (set! *inits* (cons x *inits*))) + (define (parse-struct-like ls) (let lp ((ls ls) (res '())) (cond @@ -1249,6 +1253,7 @@ (for-each write-const *consts*) (for-each write-type *types*) (for-each write-func-binding *funcs*) + (for-each (lambda (x) (cat " " x "\n")) (reverse *inits*)) (cat " sexp_gc_release2(ctx);\n" " return SEXP_VOID;\n" "}\n\n"))