From 5b627880cb755404f03acd05c44028d581812264 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sun, 4 Jul 2010 07:43:41 +0000 Subject: [PATCH] initial threading support (in-progress) --- .hgignore | 1 + Makefile | 10 +- eval.c | 9 +- include/chibi/eval.h | 1 + include/chibi/features.h | 12 ++ include/chibi/sexp.h | 29 ++++- lib/chibi/disasm.c | 17 +-- lib/srfi/18.module | 23 ++++ lib/srfi/18/interface.scm | 16 +++ lib/srfi/18/threads.c | 244 ++++++++++++++++++++++++++++++++++++++ lib/srfi/18/types.scm | 21 ++++ opcodes.c | 3 + opt/opcode_names.h | 16 +++ sexp.c | 18 +-- vm.c | 49 +++++++- 15 files changed, 434 insertions(+), 35 deletions(-) create mode 100644 lib/srfi/18.module create mode 100644 lib/srfi/18/interface.scm create mode 100644 lib/srfi/18/threads.c create mode 100644 lib/srfi/18/types.scm create mode 100644 opt/opcode_names.h diff --git a/.hgignore b/.hgignore index e26cf91b..e8b8b309 100644 --- a/.hgignore +++ b/.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 diff --git a/Makefile b/Makefile index 7c641a4c..8f47357e 100644 --- a/Makefile +++ b/Makefile @@ -88,11 +88,11 @@ endif all: chibi-scheme$(EXE) libs -COMPILED_LIBS := lib/srfi/27/rand$(SO) lib/srfi/33/bit$(SO) \ - lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) lib/srfi/98/env$(SO) \ - lib/chibi/ast$(SO) lib/chibi/net$(SO) lib/chibi/filesystem$(SO) \ - lib/chibi/process$(SO) lib/chibi/time$(SO) lib/chibi/system$(SO) \ - lib/chibi/io/io$(SO) lib/chibi/stty$(SO) \ +COMPILED_LIBS := lib/srfi/18/threads$(SO) lib/srfi/27/rand$(SO) \ + lib/srfi/33/bit$(SO) lib/srfi/69/hash$(SO) lib/srfi/95/qsort$(SO) \ + lib/srfi/98/env$(SO) lib/chibi/ast$(SO) lib/chibi/net$(SO) \ + lib/chibi/filesystem$(SO) lib/chibi/process$(SO) lib/chibi/time$(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) diff --git a/eval.c b/eval.c index 862a6062..af6b7bde 100644 --- a/eval.c +++ b/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; } diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 54110607..4f98010a 100644 --- a/include/chibi/eval.h +++ b/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 diff --git a/include/chibi/features.h b/include/chibi/features.h index 562d0d49..b8aed237 100644 --- a/include/chibi/features.h +++ b/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 diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 6a0d44d2..d21ea569 100644 --- a/include/chibi/sexp.h +++ b/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; - sexp bc, lambda, stack, env, fv, parent, globals; +#if SEXP_USE_GREEN_THREADS + 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 }; diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index 38b3a61a..d4a7373c 100644 --- a/lib/chibi/disasm.c +++ b/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; diff --git a/lib/srfi/18.module b/lib/srfi/18.module new file mode 100644 index 00000000..930e800e --- /dev/null +++ b/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")) + diff --git a/lib/srfi/18/interface.scm b/lib/srfi/18/interface.scm new file mode 100644 index 00000000..80cf6566 --- /dev/null +++ b/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!))) + diff --git a/lib/srfi/18/threads.c b/lib/srfi/18/threads.c new file mode 100644 index 00000000..d606784a --- /dev/null +++ b/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 +#include +#include + +#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; +} + diff --git a/lib/srfi/18/types.scm b/lib/srfi/18/types.scm new file mode 100644 index 00000000..611c0670 --- /dev/null +++ b/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!)) diff --git a/opcodes.c b/opcodes.c index 4f11e7e0..3e74ce53 100644 --- a/opcodes.c +++ b/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 }; diff --git a/opt/opcode_names.h b/opt/opcode_names.h new file mode 100644 index 00000000..d4c44632 --- /dev/null +++ b/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", + }; diff --git a/sexp.c b/sexp.c index a1ff7949..b2390075 100644 --- a/sexp.c +++ b/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_depth(res) = 0; - sexp_context_pos(res) = 0; + sexp_context_saves(res) = NULL; + sexp_context_depth(res)=sexp_context_tracep(res)=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, "#", out); break; case SEXP_STRING: diff --git a/vm.c b/vm.c index aa60cf3a..f7544ddf 100644 --- a/vm.c +++ b/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); - top++; + stack[top++] = sexp_make_fixnum(len); stack[top++] = SEXP_ZERO; stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); stack[top++] = SEXP_ZERO;