working on handling signals via threads

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

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

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"))
 

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);")

lib/chibi/signal.c

@@ -1,40 +1,42 @@
-/*  signal.c -- process signals interface                */
+/*  signal.c -- process signals interface                     */
-/*  Copyright (c) 2009 Alex Shinn.  All rights reserved. */
+/*  Copyright (c) 2009-2010 Alex Shinn.  All rights reserved. */
-/*  BSD-style license: http://synthcode.com/license.txt  */
+/*  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);
+      args = sexp_cons(sigctx, sexp_make_fixnum(signum), args);
-      sexp_car(args) = sexp_make_fixnum(signum);
       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));
+}

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

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"))