diff --git a/README b/README index 9e203db2..4357c8b3 100644 --- a/README +++ b/README @@ -43,16 +43,27 @@ The essential functions to remember are: #include - sexp_make_context(NULL, NULL, NULL) - returns a new context + sexp_make_eval_context(NULL, NULL, NULL) + returns a new context with a fresh stack and standard environment - sexp_eval(context, expr) - evaluates an s-expression + sexp_destroy_context(context) + free a context and all associated memory + + sexp_eval(context, expr, env) + evaluates an s-expression in an environment + env can be NULL to use the context's default env sexp_eval_string(context, str) reads an s-expression from str and evaluates it + sexp_load(context, file, env) + read and eval all top-level forms from file + + sexp_context_env(context) + a macro returning the environment associated with a context + sexp_env_define(context, env, symbol, value) + define a variable in an environment A minimal module system is provided by default. Currently you can load the following SRFIs with (import (srfi N)): diff --git a/eval.c b/eval.c index f4a74b3b..118127a0 100644 --- a/eval.c +++ b/eval.c @@ -8,14 +8,6 @@ static int scheme_initialized_p = 0; -sexp continuation_resumer, final_resumer; -static sexp the_interaction_env_symbol; -static sexp the_err_handler_symbol, the_compile_error_symbol; -static sexp the_cur_in_symbol, the_cur_out_symbol, the_cur_err_symbol; - -#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),the_cur_out_symbol,SEXP_FALSE) -#define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx))) - #if USE_DEBUG #include "opt/debug.c" #else @@ -31,14 +23,14 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version); static sexp sexp_compile_error (sexp ctx, char *message, sexp obj) { sexp exn; - sexp_gc_var2(irritants, msg); - sexp_gc_preserve2(ctx, irritants, msg); + sexp_gc_var3(sym, irritants, msg); + sexp_gc_preserve3(ctx, sym, irritants, msg); irritants = sexp_list1(ctx, obj); msg = sexp_c_string(ctx, message, -1); - exn = sexp_make_exception(ctx, the_compile_error_symbol, msg, irritants, + exn = sexp_make_exception(ctx, sym = sexp_intern(ctx, "compile"), msg, irritants, SEXP_FALSE, (sexp_pairp(obj) ? sexp_pair_source(obj) : SEXP_FALSE)); - sexp_gc_release2(ctx); + sexp_gc_release3(ctx); return exn; } @@ -156,7 +148,7 @@ static int sexp_param_index (sexp lambda, sexp name) { /************************* bytecode utilities ***************************/ -static void shrink_bcode(sexp ctx, sexp_uint_t i) { +static void shrink_bcode (sexp ctx, sexp_uint_t i) { sexp tmp; if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { tmp = sexp_alloc_tagged(ctx, sexp_sizeof(bytecode) + i, SEXP_BYTECODE); @@ -171,7 +163,7 @@ static void shrink_bcode(sexp ctx, sexp_uint_t i) { } } -static void expand_bcode(sexp ctx, sexp_uint_t size) { +static void expand_bcode (sexp ctx, sexp_uint_t size) { sexp tmp; if (sexp_bytecode_length(sexp_context_bc(ctx)) < (sexp_context_pos(ctx))+size) { @@ -191,12 +183,12 @@ static void expand_bcode(sexp ctx, sexp_uint_t size) { } } -static void emit(sexp ctx, char c) { +static void emit (sexp ctx, char c) { expand_bcode(ctx, 1); sexp_bytecode_data(sexp_context_bc(ctx))[sexp_context_pos(ctx)++] = c; } -static void emit_word(sexp ctx, sexp_uint_t val) { +static void emit_word (sexp ctx, sexp_uint_t val) { unsigned char *data; expand_bcode(ctx, sizeof(sexp)); data = sexp_bytecode_data(sexp_context_bc(ctx)); @@ -204,15 +196,21 @@ static void emit_word(sexp ctx, sexp_uint_t val) { sexp_context_pos(ctx) += sizeof(sexp); } -static void emit_push(sexp ctx, sexp obj) { +static void emit_push (sexp ctx, sexp obj) { emit(ctx, OP_PUSH); emit_word(ctx, (sexp_uint_t)obj); if (sexp_pointerp(obj)) sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); } -static sexp sexp_make_procedure(sexp ctx, sexp flags, sexp num_args, - sexp bc, sexp vars) { +static sexp finalize_bytecode (sexp ctx) { + emit(ctx, OP_RET); + shrink_bcode(ctx, sexp_context_pos(ctx)); + return sexp_context_bc(ctx); +} + +static sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, + sexp bc, sexp vars) { sexp proc = sexp_alloc_type(ctx, procedure, SEXP_PROCEDURE); sexp_procedure_flags(proc) = (char) (sexp_uint_t) flags; sexp_procedure_num_args(proc) = (unsigned short) (sexp_uint_t) num_args; @@ -241,7 +239,7 @@ static sexp sexp_make_synclo (sexp ctx, sexp env, sexp fv, sexp expr) { /* internal AST */ -static sexp sexp_make_lambda(sexp ctx, sexp params) { +static sexp sexp_make_lambda (sexp ctx, sexp params) { sexp res = sexp_alloc_type(ctx, lambda, SEXP_LAMBDA); sexp_lambda_name(res) = SEXP_FALSE; sexp_lambda_params(res) = params; @@ -252,21 +250,21 @@ static sexp sexp_make_lambda(sexp ctx, sexp params) { return res; } -static sexp sexp_make_set(sexp ctx, sexp var, sexp value) { +static sexp sexp_make_set (sexp ctx, sexp var, sexp value) { sexp res = sexp_alloc_type(ctx, set, SEXP_SET); sexp_set_var(res) = var; sexp_set_value(res) = value; return res; } -static sexp sexp_make_ref(sexp ctx, sexp name, sexp cell) { +static sexp sexp_make_ref (sexp ctx, sexp name, sexp cell) { sexp res = sexp_alloc_type(ctx, ref, SEXP_REF); sexp_ref_name(res) = name; sexp_ref_cell(res) = cell; return res; } -static sexp sexp_make_cnd(sexp ctx, sexp test, sexp pass, sexp fail) { +static sexp sexp_make_cnd (sexp ctx, sexp test, sexp pass, sexp fail) { sexp res = sexp_alloc_type(ctx, cnd, SEXP_CND); sexp_cnd_test(res) = test; sexp_cnd_pass(res) = pass; @@ -274,57 +272,68 @@ static sexp sexp_make_cnd(sexp ctx, sexp test, sexp pass, sexp fail) { return res; } -static sexp sexp_make_lit(sexp ctx, sexp value) { +static sexp sexp_make_lit (sexp ctx, sexp value) { sexp res = sexp_alloc_type(ctx, lit, SEXP_LIT); sexp_lit_value(res) = value; return res; } -#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*INIT_STACK_SIZE) +/****************************** contexts ******************************/ -sexp sexp_make_context(sexp ctx, sexp stack, sexp env) { +#define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) + +void sexp_init_eval_context_globals (sexp ctx) { + ctx = sexp_make_child_context(ctx, NULL); + emit(ctx, OP_RESUMECC); + sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); + ctx = sexp_make_child_context(ctx, NULL); + emit(ctx, OP_DONE); + sexp_global(ctx, SEXP_G_FINAL_RESUMER) + = sexp_make_procedure(ctx, + sexp_make_fixnum(0), + sexp_make_fixnum(0), + finalize_bytecode(ctx), + sexp_make_vector(ctx, 0, SEXP_VOID)); + sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) + = sexp_intern(ctx, "final-resumer"); +} + +sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env) { sexp_gc_var1(res); if (ctx) sexp_gc_preserve1(ctx, res); - res = sexp_alloc_type(ctx, context, SEXP_CONTEXT); - sexp_context_parent(res) = ctx; - sexp_context_lambda(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_tailp(res) = 1; - sexp_context_tracep(res) = 0; + res = sexp_make_context(ctx); + sexp_context_bc(res) + = sexp_alloc_tagged(res, sexp_sizeof(bytecode)+SEXP_INIT_BCODE_SIZE, + SEXP_BYTECODE); + sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; + sexp_bytecode_length(sexp_context_bc(res)) = SEXP_INIT_BCODE_SIZE; + sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; if ((! stack) || (stack == SEXP_FALSE)) { - stack = sexp_alloc_tagged(ctx, SEXP_STACK_SIZE, SEXP_STACK); - sexp_stack_length(stack) = INIT_STACK_SIZE; + stack = sexp_alloc_tagged(res, SEXP_STACK_SIZE, SEXP_STACK); + sexp_stack_length(stack) = SEXP_INIT_STACK_SIZE; sexp_stack_top(stack) = 0; } sexp_context_stack(res) = stack; + if (! ctx) sexp_init_eval_context_globals(res); sexp_context_env(res) = (env ? env : sexp_make_standard_env(res, sexp_make_fixnum(5))); - sexp_context_bc(res) - = sexp_alloc_tagged(ctx, sexp_sizeof(bytecode)+INIT_BCODE_SIZE, - SEXP_BYTECODE); - sexp_bytecode_name(sexp_context_bc(res)) = SEXP_FALSE; - sexp_bytecode_length(sexp_context_bc(res)) = INIT_BCODE_SIZE; - sexp_bytecode_literals(sexp_context_bc(res)) = SEXP_NULL; if (ctx) sexp_gc_release1(ctx); return res; } -sexp sexp_make_child_context(sexp context, sexp lambda) { - sexp ctx = sexp_make_context(context, - sexp_context_stack(context), - sexp_context_env(context)); - sexp_context_parent(ctx) = context; - sexp_context_lambda(ctx) = lambda; - sexp_context_env(ctx) = sexp_context_env(context); - sexp_context_top(ctx) = sexp_context_top(context); - sexp_context_fv(ctx) = sexp_context_fv(context); - sexp_context_tracep(ctx) = sexp_context_tracep(context); - return ctx; +sexp sexp_make_child_context (sexp ctx, sexp lambda) { + sexp res = sexp_make_eval_context(ctx, + sexp_context_stack(ctx), + sexp_context_env(ctx)); + sexp_context_lambda(res) = lambda; + sexp_context_top(res) = sexp_context_top(ctx); + sexp_context_fv(res) = sexp_context_fv(ctx); + sexp_context_tracep(res) = sexp_context_tracep(ctx); + return res; } +/**************************** identifiers *****************************/ + static sexp sexp_identifierp (sexp ctx, sexp x) { return sexp_make_boolean(sexp_idp(x)); } @@ -353,7 +362,7 @@ static sexp sexp_strip_synclos (sexp ctx, sexp x) { return res; } -static sexp sexp_identifier_eq(sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) { +static sexp sexp_identifier_eq (sexp ctx, sexp e1, sexp id1, sexp e2, sexp id2) { sexp cell, lam1=SEXP_FALSE, lam2=SEXP_FALSE; if (sexp_synclop(id1)) { e1 = sexp_synclo_env(id1); @@ -742,12 +751,6 @@ static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) { *((sexp_sint_t*)data) = sexp_context_pos(ctx)-label; } -static sexp finalize_bytecode (sexp ctx) { - emit(ctx, OP_RET); - shrink_bcode(ctx, sexp_context_pos(ctx)); - return sexp_context_bc(ctx); -} - static void generate_lit (sexp ctx, sexp value) { emit_push(ctx, value); } @@ -980,7 +983,7 @@ static void generate_lambda (sexp ctx, sexp lambda) { prev_lambda = sexp_context_lambda(ctx); prev_fv = sexp_lambdap(prev_lambda) ? sexp_lambda_fv(prev_lambda) : SEXP_NULL; fv = sexp_lambda_fv(lambda); - ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx)); + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx)); sexp_context_lambda(ctx2) = lambda; /* allocate space for local vars */ for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) @@ -1120,7 +1123,7 @@ static sexp free_vars (sexp ctx, sexp x, sexp fv) { return fv1; } -static sexp make_param_list(sexp ctx, sexp_uint_t i) { +static sexp make_param_list (sexp ctx, sexp_uint_t i) { sexp_gc_var1(res); sexp_gc_preserve1(ctx, res); res = SEXP_NULL; @@ -1160,7 +1163,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { /*********************** the virtual machine **************************/ -static sexp sexp_save_stack(sexp ctx, sexp *stack, sexp_uint_t to) { +static sexp sexp_save_stack (sexp ctx, sexp *stack, sexp_uint_t to) { sexp res, *data; sexp_uint_t i; res = sexp_make_vector(ctx, sexp_make_fixnum(to), SEXP_VOID); @@ -1170,7 +1173,7 @@ static sexp sexp_save_stack(sexp ctx, sexp *stack, sexp_uint_t to) { return res; } -static sexp_uint_t sexp_restore_stack(sexp saved, sexp *current) { +static sexp_uint_t sexp_restore_stack (sexp saved, sexp *current) { sexp_uint_t len = sexp_vector_length(saved), i; sexp *from = sexp_vector_data(saved); for (i=0; i= INIT_STACK_SIZE) + if (top+16 >= SEXP_INIT_STACK_SIZE) errx(70, "out of stack space at %ld", top); #endif i = sexp_unbox_fixnum(_WORD0); @@ -1851,9 +1855,11 @@ sexp sexp_vm (sexp ctx, sexp proc) { if (sexp_flonump(_ARG1)) { if (sexp_flonum_value(_ARG1) != trunc(sexp_flonum_value(_ARG1))) { sexp_raise("inexact->exact: not an integer", sexp_list1(ctx, _ARG1)); +#if USE_BIGNUMS } else if ((sexp_flonum_value(_ARG1) > SEXP_MAX_FIXNUM) || sexp_flonum_value(_ARG1) < SEXP_MIN_FIXNUM) { _ARG1 = sexp_double_to_bignum(ctx, sexp_flonum_value(_ARG1)); +#endif } else { _ARG1 = sexp_make_fixnum((sexp_sint_t)sexp_flonum_value(_ARG1)); } @@ -2015,14 +2021,13 @@ sexp sexp_load (sexp ctx, sexp source, sexp env) { sexp_gc_preserve4(ctx, ctx2, x, in, res); res = SEXP_VOID; in = sexp_open_input_file(ctx, source); - out = sexp_env_global_ref(env, the_cur_err_symbol, SEXP_FALSE); - ctx2 = sexp_make_context(ctx, NULL, env); + out = sexp_current_error_port(ctx); + ctx2 = sexp_make_eval_context(ctx, NULL, env); sexp_context_parent(ctx2) = ctx; tmp = sexp_env_bindings(env); sexp_context_tailp(ctx2) = 0; if (sexp_exceptionp(in)) { - if (sexp_not(out)) - out = sexp_env_global_ref(sexp_context_env(ctx), the_cur_err_symbol, SEXP_FALSE); + if (sexp_not(out)) out = sexp_current_error_port(ctx); if (sexp_oportp(out)) sexp_print_exception(ctx, in, out); res = in; @@ -2124,8 +2129,10 @@ static sexp sexp_expt (sexp ctx, sexp x, sexp e) { if ((f > SEXP_MAX_FIXNUM) || sexp_flonump(x) || sexp_flonump(e)) { if (sexp_flonump(x) || sexp_flonump(e)) res = sexp_make_flonum(ctx, f); +#if USE_BIGNUMS else res = sexp_bignum_expt(ctx, sexp_fixnum_to_bignum(ctx, x), e); +#endif } else #endif res = sexp_make_fixnum((sexp_sint_t)round(f)); @@ -2331,19 +2338,19 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_env_define(ctx, e, sexp_intern(ctx, sexp_opcode_name(op)), op); } /* add io port and interaction env parameters */ - sexp_env_define(ctx, e, the_cur_in_symbol, + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_IN_SYMBOL), sexp_make_input_port(ctx, stdin, SEXP_FALSE)); - sexp_env_define(ctx, e, the_cur_out_symbol, + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_OUT_SYMBOL), sexp_make_output_port(ctx, stdout, SEXP_FALSE)); - sexp_env_define(ctx, e, the_cur_err_symbol, + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL), sexp_make_output_port(ctx, stderr, SEXP_FALSE)); - sexp_env_define(ctx, e, the_interaction_env_symbol, e); + sexp_env_define(ctx, e, sexp_global(ctx, SEXP_G_INTERACTION_ENV_SYMBOL), e); sexp_env_define(ctx, e, sexp_intern(ctx, "*module-directory*"), sexp_c_string(ctx, sexp_module_dir, -1)); /* add default exception handler */ - err_cell = sexp_env_cell(e, the_cur_err_symbol); + err_cell = sexp_env_cell(e, sexp_global(ctx, SEXP_G_CUR_ERR_SYMBOL)); perr_cell = sexp_env_cell(e, sexp_intern(ctx, "print-exception")); - ctx2 = sexp_make_context(ctx, sexp_context_stack(ctx), e); + ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), e); sexp_context_tailp(ctx2) = 0; if (err_cell && perr_cell && sexp_opcodep(sexp_cdr(perr_cell))) { emit(ctx2, OP_GLOBAL_KNOWN_REF); @@ -2361,7 +2368,7 @@ static sexp sexp_make_standard_env (sexp ctx, sexp version) { sexp_make_fixnum(0), finalize_bytecode(ctx2), tmp); - sexp_env_define(ctx2, e, the_err_handler_symbol, err_handler); + sexp_env_define(ctx2, e, sexp_global(ctx, SEXP_G_ERR_HANDLER_SYMBOL), err_handler); sexp_gc_release4(ctx); return e; } @@ -2404,7 +2411,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { stack[top] = sexp_make_fixnum(len); top++; stack[top++] = sexp_make_fixnum(0); - stack[top++] = final_resumer; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); stack[top++] = sexp_make_fixnum(0); sexp_context_top(ctx) = top; res = sexp_vm(ctx, proc); @@ -2434,13 +2441,10 @@ sexp sexp_eval (sexp ctx, sexp obj, sexp env) { sexp res, ctx2; sexp_gc_var1(thunk); sexp_gc_preserve1(ctx, thunk); - ctx2 = sexp_make_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); + ctx2 = sexp_make_eval_context(ctx, NULL, (env ? env : sexp_context_env(ctx))); thunk = sexp_compile(ctx2, obj); if (sexp_exceptionp(thunk)) { - sexp_print_exception(ctx2, thunk, - sexp_env_global_ref(sexp_context_env(ctx2), - the_cur_err_symbol, - SEXP_FALSE)); + sexp_print_exception(ctx2, thunk, sexp_current_error_port(ctx)); res = thunk; } else { res = sexp_apply(ctx2, thunk, SEXP_NULL); @@ -2460,34 +2464,8 @@ sexp sexp_eval_string (sexp ctx, char *str, sexp env) { } void sexp_scheme_init (void) { - sexp ctx; if (! scheme_initialized_p) { scheme_initialized_p = 1; sexp_init(); - ctx = sexp_make_context(NULL, NULL, NULL); - the_compile_error_symbol = sexp_intern(ctx, "compile"); - the_err_handler_symbol = sexp_intern(ctx, "*current-exception-handler*"); - the_cur_in_symbol = sexp_intern(ctx, "*current-input-port*"); - the_cur_out_symbol = sexp_intern(ctx, "*current-output-port*"); - the_cur_err_symbol = sexp_intern(ctx, "*current-error-port*"); - the_interaction_env_symbol = sexp_intern(ctx, "*interaction-environment*"); -#if USE_BOEHM - GC_add_roots((char*)&continuation_resumer, - ((char*)&continuation_resumer)+sizeof(continuation_resumer)+1); - GC_add_roots((char*)&final_resumer, - ((char*)&final_resumer)+sizeof(continuation_resumer)+1); - GC_add_roots((char*)&opcodes, ((char*)&opcodes)+sizeof(opcodes)+1); -#endif - emit(ctx, OP_RESUMECC); - continuation_resumer = finalize_bytecode(ctx); - ctx = sexp_make_child_context(ctx, NULL); - emit(ctx, OP_DONE); - final_resumer = sexp_make_procedure(ctx, - sexp_make_fixnum(0), - sexp_make_fixnum(0), - finalize_bytecode(ctx), - sexp_make_vector(ctx, 0, SEXP_VOID)); - sexp_bytecode_name(sexp_procedure_code(final_resumer)) - = sexp_intern(ctx, "final-resumer"); } } diff --git a/gc.c b/gc.c index c0ef988b..290e6e38 100644 --- a/gc.c +++ b/gc.c @@ -15,28 +15,14 @@ #define sexp_heap_align(n) sexp_align(n, 4) #endif -typedef struct sexp_free_list *sexp_free_list; -struct sexp_free_list { - sexp_uint_t size; - sexp_free_list next; -}; - -typedef struct sexp_heap *sexp_heap; -struct sexp_heap { - sexp_uint_t size; - sexp_free_list free_list; - sexp_heap next; - char *data; -}; - -static sexp_heap heap; +#if USE_GLOBAL_HEAP +static sexp_heap sexp_global_heap; +#endif #if USE_DEBUG_GC static sexp* stack_base; #endif -extern sexp continuation_resumer, final_resumer; - static sexp_heap sexp_heap_last (sexp_heap h) { while (h->next) h = h->next; return h; @@ -88,7 +74,7 @@ int stack_references_pointer_p (sexp ctx, sexp x) { sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { size_t freed, max_freed=0, sum_freed=0, size; - sexp_heap h = heap; + sexp_heap h = sexp_context_heap(ctx); sexp p; sexp_free_list q, r, s; char *end; @@ -150,11 +136,11 @@ sexp sexp_sweep (sexp ctx, size_t *sum_freed_ptr) { sexp sexp_gc (sexp ctx, size_t *sum_freed) { sexp res; +#if USE_GLOBAL_SYMBOLS int i; - sexp_mark(continuation_resumer); - sexp_mark(final_resumer); for (i=0; isize; new_size = sexp_heap_align(((cur_size > size) ? cur_size : size) * 2); h->next = sexp_make_heap(new_size); @@ -189,7 +175,7 @@ int sexp_grow_heap (sexp ctx, size_t size) { void* sexp_try_alloc (sexp ctx, size_t size) { sexp_free_list ls1, ls2, ls3; sexp_heap h; - for (h=heap; h; h=h->next) + for (h=sexp_context_heap(ctx); h; h=h->next) for (ls1=h->free_list, ls2=ls1->next; ls2; ls1=ls2, ls2=ls2->next) if (ls2->size >= size) { if (ls2->size >= (size + SEXP_MINIMUM_OBJECT_SIZE)) { @@ -214,7 +200,7 @@ void* sexp_alloc (sexp ctx, size_t size) { res = sexp_try_alloc(ctx, size); if (! res) { max_freed = sexp_unbox_fixnum(sexp_gc(ctx, &sum_freed)); - h = sexp_heap_last(heap); + h = sexp_heap_last(sexp_context_heap(ctx)); if (((max_freed < size) || ((h->size - sum_freed) < (h->size*(1 - SEXP_GROW_HEAP_RATIO)))) && ((! SEXP_MAXIMUM_HEAP_SIZE) || (size < SEXP_MAXIMUM_HEAP_SIZE))) @@ -227,8 +213,12 @@ void* sexp_alloc (sexp ctx, size_t size) { } void sexp_gc_init (void) { +#if USE_GLOBAL_HEAP || USE_DEBUG_GC sexp_uint_t size = sexp_heap_align(SEXP_INITIAL_HEAP_SIZE); - heap = sexp_make_heap(size); +#endif +#if USE_GLOBAL_HEAP + sexp_global_heap = sexp_make_heap(size); +#endif #if USE_DEBUG_GC /* the +32 is a hack, but this is just for debugging anyway */ stack_base = ((sexp*)&size) + 32; diff --git a/include/chibi/config.h b/include/chibi/config.h index e539ebf3..f033e622 100644 --- a/include/chibi/config.h +++ b/include/chibi/config.h @@ -3,53 +3,109 @@ /* BSD-style license: http://synthcode.com/license.txt */ /* uncomment this to disable the module system */ +/* Currently this just loads the config.scm from main and */ +/* sets up an (import (module name)) macro. */ /* #define USE_MODULES 0 */ /* uncomment this to disable dynamic loading */ +/* If enabled, you can LOAD .so files with a */ +/* sexp_init_library(ctx, env) function provided. */ /* #define USE_DL 0 */ /* uncomment this to disable dynamic type definitions */ +/* This enables register-simple-type and related */ +/* opcodes for defining types, needed by the default */ +/* implementation of (srfi 9). */ /* #define USE_TYPE_DEFS 0 */ /* uncomment this to use the Boehm conservative GC */ +/* Conservative GCs make it easier to write extensions, */ +/* since you don't have to keep track of intermediate */ +/* variables, but can leak memory. Boehm is also a */ +/* very large library to link in. You may want to */ +/* enable this when debugging your own extensions, or */ +/* if you suspect a bug in the native GC. */ /* #define USE_BOEHM 1 */ /* uncomment this to just malloc manually instead of any GC */ +/* Mostly for debugging purposes, this is the no GC option. */ +/* You can use the just with the read/write API and */ +/* explicitly free sexps though. */ /* #define USE_MALLOC 1 */ /* uncomment this to add conservative checks to the native GC */ +/* Please mail the author if enabling this makes a bug */ +/* go away and you're not working on your own C extension. */ /* #define USE_DEBUG_GC 1 */ -/* uncomment this if you only want fixnum support */ +/* uncomment this to make the heap common to all contexts */ +/* By default separate contexts can have separate heaps, */ +/* and are thus thread-safe and independant. */ +/* #define USE_GLOBAL_HEAP 1 */ + +/* uncomment this to make the symbol table common to all contexts */ +/* Will still be restricted to all contexts sharing the same */ +/* heap, of course. */ +/* #define USE_GLOBAL_SYMBOLS 1 */ + +/* uncomment this if you don't need flonum support */ +/* This is only for EVAL - you'll still be able to read */ +/* and write flonums directly through the sexp API. */ /* #define USE_FLONUMS 0 */ /* uncomment this if you want immediate flonums */ +/* This is experimental, enablde at your own risk. */ /* #define USE_IMMEDIATE_FLONUMS 1 */ /* uncomment this if you don't want bignum support */ +/* Bignums are implemented with a small, custom library */ +/* in opt/bignum.c. */ /* #define USE_BIGNUMS 0 */ /* uncomment this if you don't need extended math operations */ +/* This includes the trigonometric and expt functions. */ +/* Automatically disabled if you've disabled flonums. */ /* #define USE_MATH 0 */ /* uncomment this to disable warning about references to undefined variables */ +/* This is something of a hack, but can be quite useful. */ +/* It's very fast and doesn't involve any separate analysis */ +/* passes. */ /* #define USE_WARN_UNDEFS 0 */ /* uncomment this to disable huffman-coded immediate symbols */ +/* By default (this may change) small symbols are represented */ +/* as immediates using a simple huffman encoding. This keeps */ +/* the symbol table small, and minimizes hashing when doing a */ +/* lot of reading. */ /* #define USE_HUFF_SYMS 0 */ /* uncomment this to just use a single list for hash tables */ +/* You can trade off some space in exchange for longer read */ +/* times by disabling hashing and just putting all */ +/* non-immediate symbols in a single list. */ /* #define USE_HASH_SYMS 0 */ /* uncomment this to disable string ports */ +/* If disabled some basic functionality such as number->string */ +/* will not be available by default. */ /* #define USE_STRING_STREAMS 0 */ -/* uncomment this to enable stack overflow checks */ -/* #define USE_CHECK_STACK 1 */ +/* uncomment this to disable stack overflow checks */ +/* By default stacks are fairly small, so it's good to leave */ +/* this enabled. */ +/* #define USE_CHECK_STACK 0 */ /* uncomment this to disable debugging utilities */ +/* By default there's a `disasm' procedure you can use to */ +/* view the compiled VM instructions of a procedure. You can */ +/* disable this if you don't need it. */ /* #define USE_DEBUG 0 */ +/* #define USE_DEBUG_VM 0 */ +/* Experts only. */ +/* For *very* verbose output on every VM operation. */ + /************************************************************************/ /* DEFAULTS - DO NOT MODIFY ANYTHING BELOW THIS LINE */ /************************************************************************/ @@ -101,6 +157,22 @@ #define USE_DEBUG_GC 0 #endif +#ifndef USE_GLOBAL_HEAP +#if USE_BOEHM || USE_MALLOC +#define USE_GLOBAL_HEAP 1 +#else +#define USE_GLOBAL_HEAP 0 +#endif +#endif + +#ifndef USE_GLOBAL_SYMBOLS +#if USE_BOEHM || USE_MALLOC +#define USE_GLOBAL_SYMBOLS 1 +#else +#define USE_GLOBAL_SYMBOLS 0 +#endif +#endif + #ifndef USE_FLONUMS #define USE_FLONUMS 1 #endif @@ -114,7 +186,7 @@ #endif #ifndef USE_MATH -#define USE_MATH 1 +#define USE_MATH USE_FLONUMS #endif #ifndef USE_WARN_UNDEFS @@ -133,6 +205,10 @@ #define USE_DEBUG 1 #endif +#ifndef USE_DEBUG_VM +#define USE_DEBUG_VM 0 +#endif + #ifndef USE_STRING_STREAMS #define USE_STRING_STREAMS 1 #endif diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 5137b235..f7340132 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -9,13 +9,13 @@ /************************* additional types ***************************/ -#define INIT_BCODE_SIZE 128 -#define INIT_STACK_SIZE 8192 +#define SEXP_INIT_BCODE_SIZE 128 +#define SEXP_INIT_STACK_SIZE 8192 #define sexp_init_file "init.scm" #define sexp_config_file "config.scm" -enum core_form_names { +enum sexp_core_form_names { CORE_DEFINE = 1, CORE_SET, CORE_LAMBDA, @@ -27,7 +27,7 @@ enum core_form_names { CORE_LETREC_SYNTAX }; -enum opcode_classes { +enum sexp_opcode_classes { OPC_GENERIC = 1, OPC_TYPE_PREDICATE, OPC_PREDICATE, @@ -42,7 +42,7 @@ enum opcode_classes { OPC_NUM_OP_CLASSES }; -enum opcode_names { +enum sexp_opcode_names { OP_NOOP, OP_RAISE, OP_RESUMECC, @@ -120,6 +120,8 @@ enum opcode_names { /**************************** prototypes ******************************/ SEXP_API void sexp_scheme_init (void); +SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env); +SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); SEXP_API sexp sexp_eval (sexp context, sexp obj, sexp env); SEXP_API sexp sexp_eval_string (sexp context, char *str, sexp env); @@ -127,7 +129,6 @@ SEXP_API sexp sexp_load (sexp context, sexp expr, sexp env); SEXP_API sexp sexp_make_env (sexp context); SEXP_API sexp sexp_env_copy (sexp context, sexp to, sexp from, sexp ls); SEXP_API void sexp_env_define (sexp context, sexp env, sexp sym, sexp val); -SEXP_API sexp sexp_make_context (sexp context, sexp stack, sexp env); SEXP_API void sexp_warn_undefs (sexp ctx, sexp from, sexp to, sexp out); SEXP_API sexp sexp_make_opcode (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp_proc1); SEXP_API sexp sexp_make_foreign (sexp ctx, char *name, int num_args, int flags, sexp_proc1 f, sexp data); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 7152b806..6dc5a43f 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -127,6 +127,20 @@ typedef sexp (*sexp_proc5) (sexp, sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc6) (sexp, sexp, sexp, sexp, sexp, sexp); typedef sexp (*sexp_proc7) (sexp, sexp, sexp, sexp, sexp, sexp, sexp); +typedef struct sexp_free_list *sexp_free_list; +struct sexp_free_list { + sexp_uint_t size; + sexp_free_list next; +}; + +typedef struct sexp_heap *sexp_heap; +struct sexp_heap { + sexp_uint_t size; + sexp_free_list free_list; + sexp_heap next; + char *data; +}; + struct sexp_gc_var_t { sexp *var; /* char *name; */ @@ -239,9 +253,10 @@ struct sexp_struct { sexp data[]; } stack; struct { + sexp_heap heap; struct sexp_gc_var_t *saves; sexp_uint_t pos, depth, tailp, tracep; - sexp bc, lambda, stack, env, fv, parent; + sexp bc, lambda, stack, env, fv, parent, globals; } context; } value; }; @@ -561,8 +576,6 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_stack_top(x) ((x)->value.stack.top) #define sexp_stack_data(x) ((x)->value.stack.data) -#define sexp_context_heap(x) ((x)->value.context.heap) -#define sexp_context_symbols(x) ((x)->value.context.symbols) #define sexp_context_env(x) ((x)->value.context.env) #define sexp_context_stack(x) ((x)->value.context.stack) #define sexp_context_depth(x) ((x)->value.context.depth) @@ -574,6 +587,21 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); #define sexp_context_saves(x) ((x)->value.context.saves) #define sexp_context_tailp(x) ((x)->value.context.tailp) #define sexp_context_tracep(x) ((x)->value.context.tailp) +#define sexp_context_globals(x) ((x)->value.context.globals) + +#define sexp_global(ctx,x) (sexp_vector_data(sexp_context_globals(ctx))[x]) + +#if USE_GLOBAL_HEAP +#define sexp_context_heap(ctx) sexp_global_heap +#else +#define sexp_context_heap(ctx) ((ctx)->value.context.heap) +#endif + +#if USE_GLOBAL_SYMBOLS +#define sexp_context_symbols(ctx) sexp_symbol_table +#else +#define sexp_context_symbols(ctx) sexp_vector_data(sexp_global(ctx, SEXP_G_SYMBOLS)) +#endif #define sexp_context_top(x) (sexp_stack_top(sexp_context_stack(x))) @@ -613,6 +641,25 @@ SEXP_API sexp sexp_make_integer(sexp ctx, sexp_sint_t x); /****************************** utilities *****************************/ +enum sexp_context_globals { +#if ! USE_GLOBAL_SYMBOLS + SEXP_G_SYMBOLS, +#endif + SEXP_G_QUOTE_SYMBOL, + SEXP_G_QUASIQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SYMBOL, + SEXP_G_UNQUOTE_SPLICING_SYMBOL, + SEXP_G_EMPTY_VECTOR, + SEXP_G_CUR_IN_SYMBOL, + SEXP_G_CUR_OUT_SYMBOL, + SEXP_G_CUR_ERR_SYMBOL, + SEXP_G_ERR_HANDLER_SYMBOL, + SEXP_G_INTERACTION_ENV_SYMBOL, + SEXP_G_RESUMECC_BYTECODE, + SEXP_G_FINAL_RESUMER, + SEXP_G_NUM_GLOBALS +}; + #define sexp_list1(x,a) sexp_cons((x), (a), SEXP_NULL) #define sexp_push(ctx, ls, x) ((ls) = sexp_cons((ctx), (x), (ls))) @@ -668,6 +715,7 @@ SEXP_API sexp sexp_buffered_flush (sexp ctx, sexp p); #define sexp_newline(ctx, p) sexp_write_char(ctx, '\n', (p)) SEXP_API struct sexp_struct *sexp_type_specs; +SEXP_API sexp sexp_make_context(sexp ctx); SEXP_API sexp sexp_alloc_tagged(sexp ctx, size_t size, sexp_uint_t tag); SEXP_API sexp sexp_cons(sexp ctx, sexp head, sexp tail); SEXP_API sexp sexp_list2(sexp ctx, sexp a, sexp b); @@ -704,16 +752,25 @@ SEXP_API sexp sexp_make_input_string_port(sexp ctx, sexp str); SEXP_API sexp sexp_make_output_string_port(sexp ctx); SEXP_API sexp sexp_get_output_string(sexp ctx, sexp port); SEXP_API sexp sexp_make_exception(sexp ctx, sexp kind, sexp message, sexp irritants, sexp procedure, sexp source); -SEXP_API sexp sexp_user_exception (sexp ctx, sexp self, char *message, sexp obj); -SEXP_API sexp sexp_type_exception (sexp ctx, char *message, sexp obj); -SEXP_API sexp sexp_range_exception (sexp ctx, sexp obj, sexp start, sexp end); +SEXP_API sexp sexp_user_exception(sexp ctx, sexp self, char *message, sexp obj); +SEXP_API sexp sexp_type_exception(sexp ctx, char *message, sexp obj); +SEXP_API sexp sexp_range_exception(sexp ctx, sexp obj, sexp start, sexp end); SEXP_API sexp sexp_print_exception(sexp ctx, sexp exn, sexp out); SEXP_API void sexp_init(void); +#if USE_GLOBAL_HEAP +#define sexp_destroy_context(ctx) +#else +SEXP_API void sexp_destroy_context(sexp ctx); +#endif + #if USE_TYPE_DEFS SEXP_API sexp sexp_register_type (sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp, sexp); SEXP_API sexp sexp_register_simple_type (sexp ctx, sexp name, sexp slots); #endif +#define sexp_current_error_port(ctx) sexp_env_global_ref(sexp_context_env(ctx),sexp_global(ctx,SEXP_G_CUR_ERR_SYMBOL),SEXP_FALSE) +#define sexp_debug(ctx, msg, obj) (sexp_write_string(ctx, msg, sexp_current_error_port(ctx)), sexp_write(ctx, obj, sexp_current_error_port(ctx)), sexp_write_char(ctx, '\n', sexp_current_error_port(ctx))) + #endif /* ! SEXP_H */ diff --git a/main.c b/main.c index 961791c7..2a24db43 100644 --- a/main.c +++ b/main.c @@ -128,7 +128,7 @@ void run_main (int argc, char **argv) { sexp_uint_t i, quit=0, init_loaded=0; sexp_gc_var1(str); - ctx = sexp_make_context(NULL, NULL, NULL); + ctx = sexp_make_eval_context(NULL, NULL, NULL); sexp_gc_preserve1(ctx, str); env = sexp_context_env(ctx); out = sexp_eval_string(ctx, "(current-output-port)", env); diff --git a/opt/debug.c b/opt/debug.c index 051e4123..0df9ea17 100644 --- a/opt/debug.c +++ b/opt/debug.c @@ -65,9 +65,10 @@ static sexp sexp_disasm (sexp ctx, sexp bc, sexp out) { return SEXP_VOID; } -#ifdef DEBUG_VM +#if USE_DEBUG_VM static void sexp_print_stack (sexp ctx, sexp *stack, int top, int fp, sexp out) { int i; + if (! sexp_oport(out)) out = sexp_current_error_port(ctx); for (i=0; i