Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-15 08:57:33 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

initial threading support (in-progress)

Browse source
This commit is contained in:
Alex Shinn 2010-07-04 07:43:41 +00:00
parent c1d5a6f709
commit 5b627880cb
15 changed files with 434 additions and 35 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

1
.hgignore
View file

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

10
Makefile
View file

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

9
eval.c
View file

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

1
include/chibi/eval.h
View file

@ -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

12
include/chibi/features.h
View file

@ -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

29
include/chibi/sexp.h
View file

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

17
lib/chibi/disasm.c
View file

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

23
lib/srfi/18.module Normal file
View file

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

16
lib/srfi/18/interface.scm Normal file
View file

@ -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!)))

244
lib/srfi/18/threads.c Normal file
View file

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

21
lib/srfi/18/types.scm Normal file
View file

@ -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!))

3
opcodes.c
View file

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

16
opt/opcode_names.h Normal file
View file

@ -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",
};

18
sexp.c
View file

@ -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, "#<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:

49
vm.c
View file

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