initial threading support (in-progress)

.hgignore

@@ -27,3 +27,4 @@ lib/chibi/net.c
 lib/chibi/process.c
 lib/chibi/system.c
 lib/chibi/time.c
+lib/chibi/stty.c

Makefile

@@ -88,11 +88,11 @@ endif
 
 all: chibi-scheme$(EXE) libs
 
-COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \
+COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \
-	lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \
+	lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \
-	lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \
+	lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/net$(SO) \
-	lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \
+	lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(SO) \
-	lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \
+	lib/chibi/system$(SO) lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \
 	lib/chibi/heap-stats$(SO) lib/chibi/disasm$(SO)
 
 libs: $(COMPILED_LIBS)

eval.c

@@ -391,6 +391,10 @@ void sexp_init_eval_context_globals (sexp ctx) {
   sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp);
   tmp = sexp_c_string(ctx, ".", 1);
   sexp_push(ctx, sexp_global(ctx, SEXP_G_MODULE_PATH), tmp);
+#if SEXP_USE_GREEN_THREADS
+  sexp_global(ctx, SEXP_G_THREADS_FRONT) = SEXP_NULL;
+  sexp_global(ctx, SEXP_G_THREADS_BACK) = SEXP_NULL;
+#endif
   sexp_gc_release3(ctx);
 }
 
@@ -410,7 +414,10 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size) {
   sexp_context_stack(res) = stack;
   sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_FIVE));
   if (! ctx) sexp_init_eval_context_globals(res);
-  if (ctx) sexp_gc_release1(ctx);
+  if (ctx) {
+    sexp_context_tracep(res) = sexp_context_tracep(ctx);
+    sexp_gc_release1(ctx);
+  }
   return res;
 }
 

include/chibi/eval.h

@@ -116,6 +116,7 @@ enum sexp_opcode_names {
   SEXP_OP_NEWLINE,
   SEXP_OP_READ_CHAR,
   SEXP_OP_PEEK_CHAR,
+  SEXP_OP_YIELD,
   SEXP_OP_RET,
   SEXP_OP_DONE,
   SEXP_OP_NUM_OPCODES

include/chibi/features.h

@@ -7,6 +7,9 @@
 /*   option will disable any not explicitly enabled. */
 /* #define SEXP_USE_NO_FEATURES 1 */
 
+/* uncomment this to disable interpreter-based threads */
+/* #define SEXP_USE_GREEN_THREADS 0 */
+
 /* uncomment this to enable the experimental native x86 backend */
 /* #define SEXP_USE_NATIVE_X86 1 */
 
@@ -193,6 +196,11 @@
 #define SEXP_GROW_HEAP_RATIO 0.75
 #endif
 
+/* the default number of opcodes to run each thread for */
+#ifndef SEXP_DEFAULT_QUANTUM
+#define SEXP_DEFAULT_QUANTUM 1000
+#endif
+
 /************************************************************************/
 /*         DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE            */
 /************************************************************************/
@@ -218,6 +226,10 @@
 #define SEXP_USE_NO_FEATURES 0
 #endif
 
+#ifndef SEXP_USE_GREEN_THREADS
+#define SEXP_USE_GREEN_THREADS 1
+#endif
+
 #ifndef SEXP_USE_NATIVE_X86
 #define SEXP_USE_NATIVE_X86 0
 #endif

include/chibi/sexp.h

@@ -296,8 +296,15 @@ struct sexp_struct {
     struct {
       sexp_heap heap;
       struct sexp_gc_var_t *saves;
-      sexp_uint_t pos, depth, tailp, tracep, last_fp;
+#if SEXP_USE_GREEN_THREADS
-      sexp bc, lambda, stack, env, fv, parent, globals;
+      sexp_sint_t refuel;
+      unsigned char* ip;
+      struct timeval tval;
+#endif
+      char tailp, tracep, timeoutp, waitp;
+      sexp_uint_t pos, depth, last_fp;
+      sexp bc, lambda, stack, env, fv, parent, globals,
+        proc, name, specific, event;
     } context;
   } value;
 };
@@ -480,6 +487,8 @@ sexp sexp_make_flonum(sexp ctx, double f);
 #define sexp_litp(x)        (sexp_check_tag(x, SEXP_LIT))
 #define sexp_contextp(x)    (sexp_check_tag(x, SEXP_CONTEXT))
 
+#define sexp_applicablep(x) (sexp_procedurep(x) || sexp_opcodep(x))
+
 #if SEXP_USE_HUFF_SYMS
 #define sexp_symbolp(x)     (sexp_isymbolp(x) || sexp_lsymbolp(x))
 #else
@@ -688,6 +697,15 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #define sexp_context_tracep(x)  ((x)->value.context.tailp)
 #define sexp_context_globals(x) ((x)->value.context.globals)
 #define sexp_context_last_fp(x) ((x)->value.context.last_fp)
+#define sexp_context_refuel(x)  ((x)->value.context.refuel)
+#define sexp_context_ip(x)      ((x)->value.context.ip)
+#define sexp_context_proc(x)    ((x)->value.context.proc)
+#define sexp_context_timeval(x) ((x)->value.context.tval)
+#define sexp_context_name(x)    ((x)->value.context.name)
+#define sexp_context_specific(x) ((x)->value.context.specific)
+#define sexp_context_event(x)    ((x)->value.context.event)
+#define sexp_context_timeoutp(x) ((x)->value.context.timeoutp)
+#define sexp_context_waitp(x)    ((x)->value.context.waitp)
 
 #if SEXP_USE_ALIGNED_BYTECODE
 #define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx))
@@ -806,6 +824,13 @@ enum sexp_context_globals {
   SEXP_G_ERR_HANDLER,
   SEXP_G_RESUMECC_BYTECODE,
   SEXP_G_FINAL_RESUMER,
+#if SEXP_USE_GREEN_THREADS
+  SEXP_G_THREADS_SCHEDULER,
+  SEXP_G_THREADS_FRONT,
+  SEXP_G_THREADS_BACK,
+  SEXP_G_THREADS_PAUSED,
+  SEXP_G_THREADS_LOCAL,
+#endif
   SEXP_G_NUM_GLOBALS
 };
 

lib/chibi/disasm.c

@@ -3,26 +3,11 @@
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
 #include "chibi/eval.h"
+#include "../../opt/opcode_names.h"
 
 #define SEXP_DISASM_MAX_DEPTH 8
 #define SEXP_DISASM_PAD_WIDTH 4
 
-static const char* reverse_opcode_names[] =
-  {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL",
-   "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6",
-   "JUMP-UNLESS", "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF",
-   "STACK-REF", "LOCAL-REF", "LOCAL-SET",
-   "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF",
-   "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR",
-   "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?",
-   "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR",
-   "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
-   "MUL", "DIV", "QUOTIENT", "REMAINDER",
-   "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT",
-   "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
-   "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "RET", "DONE",
-  };
-
 static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) {
   sexp tmp;
   unsigned char *ip, opcode, i;

lib/srfi/18.module

@@ -0,0 +1,23 @@
+
+(define-module (srfi 18)
+  (export
+   current-thread thread? make-thread thread-name
+   thread-specific thread-specific-set! thread-start!
+   thread-yield! thread-sleep! thread-terminate!
+   thread-join! mutex? make-mutex mutex-name
+   mutex-specific mutex-specific-set! mutex-state
+   mutex-lock! mutex-unlock! condition-variable?
+   make-condition-variable condition-variable-name
+   condition-variable-specific condition-variable-specific-set!
+   condition-variable-signal! condition-variable-broadcast!
+   current-time time? time->seconds seconds->time
+   current-exception-handler with-exception-handler raise
+   join-timeout-exception? abandoned-mutex-exception?
+   terminated-thread-exception? uncaught-exception?
+   uncaught-exception-reason)
+  (import-immutable (scheme)
+                    (srfi 9)
+                    (chibi time))
+  (include-shared "18/threads")
+  (include "18/types.scm" "18/interface.scm"))
+

lib/srfi/18/interface.scm

@@ -0,0 +1,16 @@
+
+(define (thread-join! thread . o)
+  (let ((timeout (if (pair? o) (car o) #f)))
+    (cond
+     ((%thread-join! thread timeout))
+     (else
+      (thread-yield!)
+      (if (thread-timeout?)
+          (if (and (pair? o) (pair? (cdr o)))
+              (cadr o)
+              (error "timed out waiting for thread" thread)))))))
+
+(define (thread-terminate! thread)
+  (if (%thread-terminate! thread) ;; need to yield if terminating ourself
+      (thread-yield!)))
+

lib/srfi/18/threads.c

@@ -0,0 +1,244 @@
+/*  threads.c -- SRFI-18 thread primitives                    */
+/*  Copyright (c) 2010 Alex Shinn.  All rights reserved.      */
+/*  BSD-style license: http://synthcode.com/license.txt       */
+
+#include <chibi/eval.h>
+#include <time.h>
+#include <sys/time.h>
+
+#define sexp_mutex_name(x)       sexp_slot_ref(x, 0)
+#define sexp_mutex_specific(x)   sexp_slot_ref(x, 1)
+#define sexp_mutex_thread(x)     sexp_slot_ref(x, 2)
+#define sexp_mutex_lock(x)       sexp_slot_ref(x, 3)
+
+#define sexp_condvar_name(x)     sexp_slot_ref(x, 0)
+#define sexp_condvar_specific(x) sexp_slot_ref(x, 1)
+#define sexp_condvar_threads(x)  sexp_slot_ref(x, 2)
+
+#define timeval_le(a, b) (((a).tv_sec < (b).tv_sec) || (((a).tv_sec == (b).tv_sec) && ((a).tv_usec < (b).tv_usec)))
+#define sexp_context_before(c, t) ((sexp_context_timeval(c).tv_sec != 0) && timeval_le(sexp_context_timeval(c), t))
+
+/* static int mutex_id, condvar_id; */
+
+static void sexp_define_type_predicate (sexp ctx, sexp env, char *cname, sexp_uint_t type) {
+  sexp_gc_var2(name, op);
+  sexp_gc_preserve2(ctx, name, op);
+  name = sexp_c_string(ctx, cname, -1);
+  op = sexp_make_type_predicate(ctx, name, sexp_make_fixnum(type));
+  sexp_env_define(ctx, env, name=sexp_intern(ctx, cname, -1), op);
+  sexp_gc_release2(ctx);
+}
+
+sexp sexp_thread_timeoutp (sexp ctx sexp_api_params(self, n)) {
+  return sexp_make_boolean(sexp_context_timeoutp(ctx));
+}
+
+sexp sexp_thread_name (sexp ctx sexp_api_params(self, n), sexp thread) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  return sexp_context_name(thread);
+}
+
+sexp sexp_thread_specific (sexp ctx sexp_api_params(self, n), sexp thread) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  return sexp_context_specific(thread);
+}
+
+sexp sexp_thread_specific_set (sexp ctx sexp_api_params(self, n), sexp thread, sexp val) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  sexp_context_specific(thread) = val;
+  return SEXP_VOID;
+}
+
+sexp sexp_current_thread (sexp ctx sexp_api_params(self, n)) {
+  return ctx;
+}
+
+sexp sexp_make_thread (sexp ctx sexp_api_params(self, n), sexp thunk, sexp name) {
+  sexp res, *stack;
+  sexp_assert_type(ctx, sexp_procedurep, SEXP_PROCEDURE, thunk);
+  res = sexp_make_eval_context(ctx, SEXP_FALSE, sexp_context_env(ctx), 0);
+  sexp_context_proc(res) = thunk;
+  sexp_context_ip(res) = sexp_bytecode_data(sexp_procedure_code(thunk));
+  stack = sexp_stack_data(sexp_context_stack(res));
+  stack[0] = stack[1] = stack[3] = SEXP_ZERO;
+  stack[2] = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
+  sexp_context_top(res) = 4;
+  sexp_context_last_fp(res) = 0;
+  return res;
+}
+
+sexp sexp_thread_start (sexp ctx sexp_api_params(self, n), sexp thread) {
+  sexp cell;
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  if (sexp_pairp(sexp_global(ctx, SEXP_G_THREADS_BACK))) {
+    cell = sexp_cons(ctx, thread, SEXP_NULL);
+    sexp_cdr(sexp_global(ctx, SEXP_G_THREADS_BACK)) = cell;
+    sexp_global(ctx, SEXP_G_THREADS_BACK) = cell;
+  } else {			/* init queue */
+    sexp_global(ctx, SEXP_G_THREADS_BACK) = sexp_global(ctx, SEXP_G_THREADS_FRONT)
+      = sexp_cons(ctx, thread, SEXP_NULL);
+  }
+  return SEXP_VOID;
+}
+
+sexp sexp_thread_terminate (sexp ctx sexp_api_params(self, n), sexp thread) {
+  sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_FRONT);
+  sexp_context_refuel(thread) = 0;
+  for ( ; sexp_pairp(ls2) && (sexp_car(ls2) != thread); ls2=sexp_cdr(ls2))
+    ls1 = ls2;
+  if (sexp_pairp(ls2)) {
+    if (ls1 == SEXP_NULL)
+      sexp_global(ctx, SEXP_G_THREADS_FRONT) = sexp_cdr(ls2);
+    else			/* splice */
+      sexp_cdr(ls1) = sexp_cdr(ls2);
+    if (ls2 == sexp_global(ctx, SEXP_G_THREADS_BACK))
+      sexp_global(ctx, SEXP_G_THREADS_BACK) = ls1;
+  } else {                      /* check for paused threads */
+    ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+    for ( ; sexp_pairp(ls2) && (sexp_car(ls2) != thread); ls2=sexp_cdr(ls2))
+      ls1 = ls2;
+    if (sexp_pairp(ls2)) {
+      if (ls1 == SEXP_NULL)
+        sexp_global(ctx, SEXP_G_THREADS_PAUSED) = sexp_cdr(ls2);
+      else			/* splice */
+        sexp_cdr(ls1) = sexp_cdr(ls2);
+    }
+  }
+  /* return true if terminating self */
+  return sexp_make_boolean(ctx == thread);
+}
+
+void sexp_insert_timed (sexp ctx, sexp thread, sexp timeout) {
+#if SEXP_USE_FLONUMS
+  double d;
+#endif
+  sexp ls1=SEXP_NULL, ls2=sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+  if (sexp_integerp(timeout)) {
+    sexp_context_timeval(ctx).tv_sec = sexp_unbox_fixnum(timeout);
+    sexp_context_timeval(ctx).tv_usec = 0;
+#if SEXP_USE_FLONUMS
+  } else if (sexp_flonump(timeout)) {
+    d = sexp_flonum_value(timeout);
+    sexp_context_timeval(ctx).tv_sec = trunc(d);
+    sexp_context_timeval(ctx).tv_usec = (d-trunc(d))*1000000;
+#endif
+  } else {
+    sexp_context_timeval(ctx).tv_sec = 0;
+    sexp_context_timeval(ctx).tv_usec = 0;
+  }
+  if (sexp_numberp(timeout))
+    while (sexp_pairp(ls2)
+           && sexp_context_before(sexp_car(ls2), sexp_context_timeval(ctx)))
+      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);
+}
+
+sexp sexp_thread_join (sexp ctx sexp_api_params(self, n), sexp thread, sexp timeout) {
+  sexp_assert_type(ctx, sexp_contextp, SEXP_CONTEXT, thread);
+  if (sexp_context_refuel(thread) <= 0) /* return true if already terminated */
+    return SEXP_TRUE;
+  sexp_context_waitp(ctx) = 1;
+  sexp_context_event(ctx) = thread;
+  sexp_insert_timed(ctx, ctx, timeout);
+  return SEXP_FALSE;
+}
+
+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);
+
+  paused = sexp_global(ctx, SEXP_G_THREADS_PAUSED);
+
+  /* if we've terminated, check threads joining us */
+  if (sexp_context_refuel(ctx) <= 0) {
+    for (ls1=SEXP_NULL, ls2=paused; sexp_pairp(ls2); ls2=sexp_cdr(ls2))
+      if (sexp_context_event(sexp_car(ls2)) == ctx) {
+        sexp_context_waitp(ctx) = 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) = front;
+        sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = ls2;
+        ls2 = tmp;
+      } else {
+        ls1 = ls2;
+        ls2 = sexp_cdr(ls2);
+      }
+  }
+
+  /* TODO: check threads blocked on I/O */
+  /* ... */
+
+  /* check timeouts (must be _after_ previous checks) */
+  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) = front;
+        sexp_global(ctx, SEXP_G_THREADS_FRONT) = front = paused;
+        sexp_global(ctx, SEXP_G_THREADS_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 (ctx == sexp_car(sexp_global(ctx, SEXP_G_THREADS_BACK)))
+        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;
+  }
+
+  return res;
+}
+
+sexp sexp_init_library (sexp ctx sexp_api_params(self, n), sexp env) {
+
+  sexp_define_type_predicate(ctx, env, "thread?", SEXP_CONTEXT);
+  sexp_define_foreign(ctx, env, "thread-timeout?", 0, sexp_thread_timeoutp);
+  sexp_define_foreign(ctx, env, "current-thread", 0, sexp_current_thread);
+  sexp_define_foreign_opt(ctx, env, "make-thread", 2, sexp_make_thread, SEXP_FALSE);
+  sexp_define_foreign(ctx, env, "thread-start!", 1, sexp_thread_start);
+  sexp_define_foreign(ctx, env, "%thread-terminate!", 1, sexp_thread_terminate);
+  sexp_define_foreign(ctx, env, "%thread-join!", 2, sexp_thread_join);
+  sexp_define_foreign(ctx, env, "thread-name", 1, sexp_thread_name);
+  sexp_define_foreign(ctx, env, "thread-specific", 1, sexp_thread_specific);
+  sexp_define_foreign(ctx, env, "thread-specific-set!", 2, sexp_thread_specific_set);
+
+  sexp_global(ctx, SEXP_G_THREADS_SCHEDULER)
+    = sexp_make_foreign(ctx, "scheduler", 0, 0, (sexp_proc1)sexp_scheduler, SEXP_FALSE);
+
+  return SEXP_VOID;
+}
+

lib/srfi/18/types.scm

@@ -0,0 +1,21 @@
+;; types.scm -- thread types
+;; Copyright (c) 2010 Alex Shinn.  All rights reserved.
+;; BSD-style license: http://synthcode.com/license.txt
+
+(define-record-type mutex
+  (%make-mutex name specific thread lock)
+  mutex?
+  (name mutex-name)
+  (specific mutex-specific mutex-specific-set!)
+  (thread %mutex-thread %mutex-thread-set!)
+  (lock %mutex-lock %mutex-lock-set!))
+
+(define (make-mutex . o)
+  (%make-mutex (and (pair? o) (car o)) #f #f #f))
+
+(define-record-type condition-variable
+  (%make-condition-variable name specific threads)
+  condition-variable?
+  (name condition-variable-name)
+  (specific condition-variable-specific condition-variable-specific-set!)
+  (threads %condition-variable-threads %condition-variable-threads-set!))

opcodes.c

@@ -150,5 +150,8 @@ _FN1(SEXP_STRING, "find-module-file", 0, sexp_find_module_file_op),
 _FN2(SEXP_STRING, SEXP_ENV, "load-module-file", 0, sexp_load_module_file_op),
 _FN2(SEXP_STRING, SEXP_BOOLEAN, "add-module-directory", 0, sexp_add_module_directory_op),
 #endif
+#if SEXP_USE_GREEN_THREADS
+_OP(SEXP_OPC_GENERIC, SEXP_OP_YIELD, 0, 0, 0, 0, 0, "thread-yield!", 0, NULL),
+#endif
 };
 

opt/opcode_names.h

@@ -0,0 +1,16 @@
+
+static const char* reverse_opcode_names[] =
+  {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL",
+   "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6",
+   "JUMP-UNLESS", "JUMP", "PUSH", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF",
+   "STACK-REF", "LOCAL-REF", "LOCAL-SET",
+   "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", "STRING-REF",
+   "STRING-SET", "STRING-LENGTH", "MAKE-PROCEDURE", "MAKE-VECTOR",
+   "MAKE-EXCEPTION", "AND", "NULL?", "FIXNUM?", "SYMBOL?", "CHAR?",
+   "EOF?", "TYPEP", "MAKE", "SLOT-REF", "SLOT-SET", "CAR", "CDR",
+   "SET-CAR", "SET-CDR", "CONS", "ADD", "SUB",
+   "MUL", "DIV", "QUOTIENT", "REMAINDER",
+   "LT", "LE", "EQN", "EQ", "EXACT->INEXACT", "INEXACT->EXACT",
+   "CHAR->INTEGER", "INTEGER->CHAR", "CHAR-UPCASE", "CHAR-DOWNCASE",
+   "WRITE-CHAR", "NEWLINE", "READ-CHAR", "PEEK-CHAR", "YIELD", "RET", "DONE",
+  };

sexp.c

@@ -110,7 +110,7 @@ static struct sexp_struct _sexp_type_specs[] = {
   _DEF_TYPE(SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, "sequence", NULL),
   _DEF_TYPE(SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, "literal", NULL),
   _DEF_TYPE(SEXP_STACK, sexp_offsetof(stack, data), 1, 1, sexp_offsetof(stack, top), 1, sexp_sizeof(stack), offsetof(struct sexp_struct, value.stack.length), sizeof(sexp), "stack", NULL),
-  _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 7, 7, 0, 0, sexp_sizeof(context), 0, 0, "context", NULL),
+  _DEF_TYPE(SEXP_CONTEXT, sexp_offsetof(context, bc), 11, 11, 0, 0, sexp_sizeof(context), 0, 0, "context", NULL),
 };
 #undef _DEF_TYPE
 
@@ -285,12 +285,14 @@ sexp sexp_make_context (sexp ctx, size_t size) {
     }
   sexp_context_parent(res) = ctx;
   sexp_context_lambda(res) = SEXP_FALSE;
+  sexp_context_name(res) = sexp_context_specific(res) = SEXP_FALSE;
   sexp_context_fv(res) = SEXP_NULL;
-  sexp_context_saves(res) = 0;
+  sexp_context_saves(res) = NULL;
-  sexp_context_depth(res) = 0;
+  sexp_context_depth(res)=sexp_context_tracep(res)=sexp_context_pos(res)=0;
-  sexp_context_pos(res) = 0;
   sexp_context_tailp(res) = 1;
-  sexp_context_tracep(res) = 0;
+#if SEXP_USE_GREEN_THREADS
+  sexp_context_refuel(res) = SEXP_DEFAULT_QUANTUM;
+#endif
   if (ctx) {
     sexp_context_globals(res) = sexp_context_globals(ctx);
     sexp_gc_release1(ctx);
@@ -418,7 +420,8 @@ sexp sexp_print_exception_op (sexp ctx sexp_api_params(self, n), sexp exn, sexp
       }
     }
     ls = sexp_exception_source(exn);
-    if ((! (ls && sexp_pairp(ls))) && sexp_exception_procedure(exn))
+    if ((! (ls && sexp_pairp(ls)))
+        && sexp_procedurep(sexp_exception_procedure(exn)))
       ls = sexp_bytecode_source(sexp_procedure_code(sexp_exception_procedure(exn)));
     if (ls && sexp_pairp(ls)) {
       if (sexp_fixnump(sexp_cdr(ls)) && (sexp_cdr(ls) >= SEXP_ZERO)) {
@@ -1165,7 +1168,8 @@ sexp sexp_write_one (sexp ctx, sexp obj, sexp out) {
 #endif
     case SEXP_PROCEDURE:
       sexp_write_string(ctx, "#<procedure: ", out);
-      sexp_write_one(ctx, sexp_bytecode_name(sexp_procedure_code(obj)), out);
+      x = sexp_bytecode_name(sexp_procedure_code(obj));
+      sexp_write_one(ctx, sexp_synclop(x) ? sexp_synclo_expr(x): x, out);
       sexp_write_string(ctx, ">", out);
       break;
     case SEXP_STRING:

vm.c

@@ -2,6 +2,8 @@
 /*  Copyright (c) 2009-2010 Alex Shinn.  All rights reserved. */
 /*  BSD-style license: http://synthcode.com/license.txt       */
 
+static sexp sexp_apply1 (sexp ctx, sexp f, sexp x);
+
 /************************* code generation ****************************/
 
 static void emit_word (sexp ctx, sexp_uint_t val)  {
@@ -449,11 +451,19 @@ static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) {
       goto call_error_handler;}}                               \
     while (0)
 
+#if SEXP_USE_DEBUG_VM
+#include "opt/opcode_names.h"
+#endif
+
 sexp sexp_vm (sexp ctx, sexp proc) {
   sexp bc = sexp_procedure_code(proc), cp = sexp_procedure_vars(proc);
   sexp *stack = sexp_stack_data(sexp_context_stack(ctx));
   unsigned char *ip = sexp_bytecode_data(bc);
   sexp_sint_t i, j, k, fp, top = sexp_stack_top(sexp_context_stack(ctx));
+#if SEXP_USE_GREEN_THREADS
+  sexp root_thread = ctx;
+  sexp_sint_t fuel = sexp_context_refuel(ctx);
+#endif
 #if SEXP_USE_BIGNUMS
   sexp_lsint_t prod;
 #endif
@@ -463,6 +473,29 @@ sexp sexp_vm (sexp ctx, sexp proc) {
   self = proc;
 
  loop:
+#if SEXP_USE_GREEN_THREADS
+  if (--fuel <= 0) {
+    tmp1 = sexp_global(ctx, SEXP_G_THREADS_SCHEDULER);
+    if (sexp_applicablep(tmp1)) {
+      /* save thread */
+      sexp_context_top(ctx) = top;
+      sexp_context_ip(ctx) = ip;
+      sexp_context_last_fp(ctx) = fp;
+      sexp_context_proc(ctx) = self;
+      /* run scheduler */
+      ctx = sexp_apply1(ctx, tmp1, root_thread);
+      /* restore thread */
+      stack = sexp_stack_data(sexp_context_stack(ctx));
+      top = sexp_context_top(ctx);
+      fp = sexp_context_last_fp(ctx);
+      ip = sexp_context_ip(ctx);
+      self = sexp_context_proc(ctx);
+      bc = sexp_procedure_code(self);
+      cp = sexp_procedure_vars(self);
+    }
+    fuel = sexp_context_refuel(ctx);
+  }
+#endif
 #if SEXP_USE_DEBUG_VM
   if (sexp_context_tracep(ctx)) {
     sexp_print_stack(ctx, stack, top, fp, SEXP_FALSE);
@@ -1163,17 +1196,20 @@ sexp sexp_vm (sexp ctx, sexp proc) {
     break;
   case SEXP_OP_READ_CHAR:
     if (! sexp_iportp(_ARG1))
-      sexp_raise("read-char: not an intput-port", sexp_list1(ctx, _ARG1));
+      sexp_raise("read-char: not an input-port", sexp_list1(ctx, _ARG1));
     i = sexp_read_char(ctx, _ARG1);
     _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i);
     break;
   case SEXP_OP_PEEK_CHAR:
     if (! sexp_iportp(_ARG1))
-      sexp_raise("peek-char: not an intput-port", sexp_list1(ctx, _ARG1));
+      sexp_raise("peek-char: not an input-port", sexp_list1(ctx, _ARG1));
     i = sexp_read_char(ctx, _ARG1);
     sexp_push_char(ctx, i, _ARG1);
     _ARG1 = (i == EOF) ? SEXP_EOF : sexp_make_character(i);
     break;
+  case SEXP_OP_YIELD:
+    fuel = 0;
+    break;
   case SEXP_OP_RET:
     i = sexp_unbox_fixnum(stack[fp]);
     stack[fp-i] = _ARG1;
@@ -1192,6 +1228,12 @@ sexp sexp_vm (sexp ctx, sexp proc) {
   goto loop;
 
  end_loop:
+#if SEXP_USE_GREEN_THREADS
+  if (ctx != root_thread) { /* don't return from child threads */
+    sexp_context_refuel(ctx) = fuel = 0;
+    goto loop;
+  }
+#endif
   sexp_gc_release3(ctx);
   sexp_context_top(ctx) = top;
   return _ARG1;
@@ -1225,8 +1267,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
     offset = top + len;
     for (ls=args; sexp_pairp(ls); ls=sexp_cdr(ls), top++)
       stack[--offset] = sexp_car(ls);
-    stack[top] = sexp_make_fixnum(len);
+    stack[top++] = sexp_make_fixnum(len);
-    top++;
     stack[top++] = SEXP_ZERO;
     stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
     stack[top++] = SEXP_ZERO;