diff --git a/eval.c b/eval.c index 8f2808d6..ede8e5bd 100644 --- a/eval.c +++ b/eval.c @@ -148,8 +148,10 @@ static sexp sexp_reverse_flatten_dot (sexp ctx, sexp ls) { sexp_gc_preserve1(ctx, res); for (res=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) sexp_push(ctx, res, sexp_car(ls)); + if (!sexp_nullp(ls)) + res = sexp_cons(ctx, ls, res); sexp_gc_release1(ctx); - return (sexp_nullp(ls) ? res : sexp_cons(ctx, ls, res)); + return res; } static sexp sexp_flatten_dot (sexp ctx, sexp ls) { @@ -392,15 +394,15 @@ sexp sexp_make_child_context (sexp ctx, sexp lambda) { /**************************** identifiers *****************************/ -static sexp sexp_identifierp_op (sexp ctx sexp_api_params(self, n), sexp x) { +sexp sexp_identifierp_op (sexp ctx sexp_api_params(self, n), sexp x) { return sexp_make_boolean(sexp_idp(x)); } -static sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), sexp x) { +sexp sexp_syntactic_closure_expr_op (sexp ctx sexp_api_params(self, n), sexp x) { return (sexp_synclop(x) ? sexp_synclo_expr(x) : x); } -static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) { +sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) { sexp res; sexp_gc_var2(kar, kdr); sexp_gc_preserve2(ctx, kar, kdr); @@ -420,7 +422,7 @@ static sexp sexp_strip_synclos (sexp ctx sexp_api_params(self, n), sexp x) { return res; } -static sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), sexp e1, sexp id1, sexp e2, sexp id2) { +sexp sexp_identifier_eq_op (sexp ctx sexp_api_params(self, n), 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); @@ -906,7 +908,7 @@ static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) return sexp_exception_kind(exn); } -static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) { +sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp path) { FILE *in; sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); in = fopen(sexp_string_data(path), "r"); @@ -915,7 +917,7 @@ static sexp sexp_open_input_file_op (sexp ctx sexp_api_params(self, n), sexp pat return sexp_make_input_port(ctx, in, path); } -static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) { +sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp path) { FILE *out; sexp_assert_type(ctx, sexp_stringp, SEXP_STRING, path); out = fopen(sexp_string_data(path), "w"); @@ -924,7 +926,7 @@ static sexp sexp_open_output_file_op (sexp ctx sexp_api_params(self, n), sexp pa return sexp_make_output_port(ctx, out, path); } -static sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { +sexp sexp_close_port_op (sexp ctx sexp_api_params(self, n), sexp port) { sexp_assert_type(ctx, sexp_portp, SEXP_OPORT, port); if (! sexp_port_openp(port)) return sexp_user_exception(ctx, self, "port already closed", port); @@ -1423,15 +1425,14 @@ sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data) { - sexp res = SEXP_VOID; - sexp_gc_var1(op); - sexp_gc_preserve1(ctx, op); + sexp_gc_var2(op, res); + sexp_gc_preserve2(ctx, op, res); op = sexp_make_foreign(ctx, name, num_args, flags, f, data); if (sexp_exceptionp(op)) res = op; else - sexp_env_define(ctx, env, sexp_intern(ctx, name, -1), op); - sexp_gc_release1(ctx); + sexp_env_define(ctx, env, res = sexp_intern(ctx, name, -1), op); + sexp_gc_release2(ctx); return res; } @@ -1477,11 +1478,14 @@ sexp sexp_make_env_op (sexp ctx sexp_api_params(self, n)) { sexp sexp_make_null_env_op (sexp ctx sexp_api_params(self, n), sexp version) { sexp_uint_t i; - sexp e = sexp_make_env(ctx), core; + sexp_gc_var2(e, core); + sexp_gc_preserve2(ctx, e, core); + e = sexp_make_env(ctx); for (i=0; i<(sizeof(core_forms)/sizeof(core_forms[0])); i++) { core = sexp_copy_core(ctx, &core_forms[i]); sexp_env_define(ctx, e, sexp_intern(ctx, sexp_core_name(core), -1), core); } + sexp_gc_release2(ctx); return e; } @@ -1652,7 +1656,7 @@ sexp sexp_load_standard_env (sexp ctx, sexp e, sexp version) { sexp_push(ctx, tmp, sym=sexp_intern(ctx, "threads", -1)); #endif sexp_push(ctx, tmp, sym=sexp_intern(ctx, "chibi", -1)); - sexp_env_define(ctx, e, sexp_intern(ctx, "*features*", -1), tmp); + sexp_env_define(ctx, e, sym=sexp_intern(ctx, "*features*", -1), tmp); sexp_global(ctx, SEXP_G_OPTIMIZATIONS) = SEXP_NULL; #if SEXP_USE_SIMPLIFY op = sexp_make_foreign(ctx, "simplify", 1, 0, @@ -1699,7 +1703,9 @@ sexp sexp_make_standard_env_op (sexp ctx sexp_api_params(self, n), sexp version) } sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp) { - sexp oldname, newname, value; + sexp oldname, newname; + sexp_gc_var1(value); + sexp_gc_preserve1(ctx, value); if (! sexp_envp(to)) to = sexp_context_env(ctx); if (! sexp_envp(from)) from = sexp_context_env(ctx); if (sexp_not(ls)) { @@ -1730,6 +1736,7 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se } } } + sexp_gc_release1(ctx); return SEXP_VOID; } diff --git a/gc.c b/gc.c index 305654cb..54643207 100644 --- a/gc.c +++ b/gc.c @@ -48,10 +48,6 @@ static int sexp_in_heap(sexp ctx, sexp_uint_t x) { } #endif -#if SEXP_USE_DEBUG_GC -#include "opt/gc_debug.c" -#endif - void sexp_mark (sexp ctx, sexp x) { sexp_sint_t i, len; sexp t, *p; diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 33f73624..bd989863 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -153,9 +153,15 @@ SEXP_API sexp sexp_load_standard_env (sexp context, sexp env, sexp version); SEXP_API sexp sexp_find_module_file (sexp ctx, const char *file); SEXP_API sexp sexp_load_module_file (sexp ctx, const char *file, sexp env); SEXP_API sexp sexp_add_module_directory_op (sexp ctx sexp_api_params(self, n), sexp dir, sexp appendp); -SEXP_API sexp sexp_extend_env (sexp context, sexp env, sexp vars, sexp value); -SEXP_API sexp sexp_env_copy_op (sexp context sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp); -SEXP_API sexp sexp_env_define (sexp context, sexp env, sexp sym, sexp val); +SEXP_API sexp sexp_extend_env (sexp ctx, sexp env, sexp vars, sexp value); +SEXP_API sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, sexp ls, sexp immutp); +SEXP_API sexp sexp_identifier_op(sexp ctx sexp_api_params(self, n), sexp x); +SEXP_API sexp sexp_syntactic_closure_expr(sexp ctx sexp_api_params(self, n), sexp x); +SEXP_API sexp sexp_identifier_eq_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b, sexp c, sexp d); +SEXP_API sexp sexp_open_input_file_op(sexp ctx sexp_api_params(self, n), sexp x); +SEXP_API sexp sexp_open_output_file_op(sexp ctx sexp_api_params(self, n), sexp x); +SEXP_API sexp sexp_close_port_op(sexp ctx sexp_api_params(self, n), sexp x); +SEXP_API sexp sexp_env_define (sexp ctx, sexp env, sexp sym, sexp val); SEXP_API sexp sexp_env_cell (sexp env, sexp sym); SEXP_API sexp sexp_env_ref (sexp env, sexp sym, sexp dflt); SEXP_API sexp sexp_env_global_ref (sexp env, sexp sym, sexp dflt); @@ -191,7 +197,7 @@ SEXP_API sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, #define sexp_eval(ctx, x, e) sexp_eval_op(ctx sexp_api_pass(NULL, 2), x, e) #define sexp_load(ctx, f, e) sexp_load_op(ctx sexp_api_pass(NULL, 2), f, e) #define sexp_env_copy(ctx, a, b, c, d) sexp_env_copy_op(ctx sexp_api_pass(NULL, 4), a, b, c, d) -#define sexp_identifierp(ctx, x) sexp_identifier_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_identifierp(ctx, x) sexp_identifierp_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_identifier_to_symbol(ctx, x) sexp_syntactic_closure_expr(ctx sexp_api_pass(NULL, 1), x) #define sexp_identifier_eq(ctx, a, b, c, d) sexp_identifier_eq_op(ctx sexp_api_pass(NULL, 4), a, b, c, d) #define sexp_open_input_file(ctx, x) sexp_open_input_file_op(ctx sexp_api_pass(NULL, 1), x) diff --git a/sexp.c b/sexp.c index e068a018..841be8a1 100644 --- a/sexp.c +++ b/sexp.c @@ -1091,7 +1091,7 @@ sexp sexp_buffered_write_string (sexp ctx, const char *str, sexp p) { sexp sexp_buffered_flush (sexp ctx, sexp p) { sexp_gc_var1(tmp); if (! sexp_oportp(p)) - return sexp_type_exception(ctx, NULL, SEXP_OPORT, p); + return sexp_type_exception(ctx, NULL, SEXP_OPORT, p); if (! sexp_port_openp(p)) return sexp_user_exception(ctx, SEXP_FALSE, "port is closed", p); else { diff --git a/tools/genstatic.scm b/tools/genstatic.scm index 3382698e..abe7f13f 100755 --- a/tools/genstatic.scm +++ b/tools/genstatic.scm @@ -121,7 +121,7 @@ (define (init-c-lib lib) (display " ") (display (cdr lib)) - (display "(ctx, env);\n")) + (display "(ctx sexp_api_pass(NULL, 1), env);\n")) (define (main args) (find-c-libs (if (pair? (cdr args)) (cadr args) "lib")) diff --git a/vm.c b/vm.c index b019acfb..d96f8d7c 100644 --- a/vm.c +++ b/vm.c @@ -149,10 +149,11 @@ static void generate_ref (sexp ctx, sexp ref, int unboxp) { if (! sexp_lambdap(sexp_ref_loc(ref))) { /* global ref */ if (unboxp) { - emit(ctx, - (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) - ? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF); + emit(ctx, (sexp_cdr(sexp_ref_cell(ref)) == SEXP_UNDEF) + ? SEXP_OP_GLOBAL_REF : SEXP_OP_GLOBAL_KNOWN_REF); emit_word(ctx, (sexp_uint_t)sexp_ref_cell(ref)); + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), + sexp_ref_cell(ref)); } else emit_push(ctx, sexp_ref_cell(ref)); } else { @@ -211,13 +212,13 @@ static void generate_opcode_app (sexp ctx, sexp app) { emit_word(ctx, (sexp_uint_t)sexp_opcode_data(op)); #else emit_push(ctx, sexp_opcode_data(op)); + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), + sexp_opcode_data(op)); #endif emit(ctx, SEXP_OP_CDR); } else { emit_push(ctx, sexp_opcode_data(op)); } - sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), - sexp_opcode_data(op)); sexp_context_depth(ctx)++; num_args++; } @@ -270,6 +271,7 @@ static void generate_opcode_app (sexp ctx, sexp app) { case SEXP_OPC_FOREIGN: emit(ctx, sexp_opcode_code(op)); emit_word(ctx, (sexp_uint_t)op); + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), op); break; case SEXP_OPC_TYPE_PREDICATE: case SEXP_OPC_GETTER: @@ -282,6 +284,7 @@ static void generate_opcode_app (sexp ctx, sexp app) { emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data(op))); if (sexp_opcode_data2(op)) emit_word(ctx, sexp_unbox_fixnum(sexp_opcode_data2(op))); + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), op); } break; case SEXP_OPC_PARAMETER: @@ -435,8 +438,8 @@ static sexp make_param_list (sexp ctx, sexp_uint_t i) { } static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { - sexp ls, bc, res, env; - sexp_gc_var5(params, ref, refs, lambda, ctx2); + sexp ls, res, env; + sexp_gc_var6(bc, params, ref, refs, lambda, ctx2); if (i == sexp_opcode_num_args(op)) { /* return before preserving */ if (sexp_opcode_proc(op)) return sexp_opcode_proc(op); } else if (i < sexp_opcode_num_args(op)) { @@ -444,7 +447,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { } else if (! sexp_opcode_variadic_p(op)) { /* i > num_args */ return sexp_compile_error(ctx, "too many args for opcode", op); } - sexp_gc_preserve5(ctx, params, ref, refs, lambda, ctx2); + sexp_gc_preserve6(ctx, bc, params, ref, refs, lambda, ctx2); params = make_param_list(ctx, i); lambda = sexp_make_lambda(ctx, params); ctx2 = sexp_make_child_context(ctx, lambda); @@ -462,7 +465,7 @@ static sexp make_opcode_procedure (sexp ctx, sexp op, sexp_uint_t i) { res=sexp_make_procedure(ctx2, SEXP_ZERO, sexp_make_fixnum(i), bc, SEXP_VOID); if (i == sexp_opcode_num_args(op)) sexp_opcode_proc(op) = res; - sexp_gc_release5(ctx); + sexp_gc_release6(ctx); return res; } @@ -987,14 +990,14 @@ sexp sexp_vm (sexp ctx, sexp proc) { case SEXP_OP_SLOT_REF: _ALIGN_IP(); if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0))) - sexp_raise("slot-ref: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + sexp_raise("slot-ref: bad type", sexp_list2(ctx, tmp1=sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); _ARG1 = sexp_slot_ref(_ARG1, _UWORD1); ip += sizeof(sexp)*2; break; case SEXP_OP_SLOT_SET: _ALIGN_IP(); if (! sexp_check_type(ctx, _ARG1, sexp_type_by_index(ctx, _UWORD0))) - sexp_raise("slot-set!: bad type", sexp_list2(ctx, sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); + sexp_raise("slot-set!: bad type", sexp_list2(ctx, tmp1=sexp_c_string(ctx, sexp_type_name_by_index(ctx, _UWORD0), -1), _ARG1)); else if (sexp_immutablep(_ARG1)) sexp_raise("slot-set!: immutable object", sexp_list1(ctx, _ARG1)); sexp_slot_set(_ARG1, _UWORD1, _ARG2); @@ -1401,7 +1404,9 @@ sexp sexp_vm (sexp ctx, sexp proc) { _ARG1 = sexp_make_character(i); break; case SEXP_OP_YIELD: +#if SEXP_USE_GREEN_THREADS fuel = 0; +#endif _PUSH(SEXP_VOID); break; case SEXP_OP_RET: @@ -1457,9 +1462,11 @@ sexp sexp_apply1 (sexp ctx, sexp f, sexp x) { sexp sexp_apply (sexp ctx, sexp proc, sexp args) { sexp res, ls, *stack = sexp_stack_data(sexp_context_stack(ctx)); sexp_sint_t top = sexp_context_top(ctx), len, offset; + sexp_gc_var1(tmp); + sexp_gc_preserve1(ctx, tmp); len = sexp_unbox_fixnum(sexp_length(ctx, args)); if (sexp_opcodep(proc)) - proc = make_opcode_procedure(ctx, proc, len); + proc = tmp = make_opcode_procedure(ctx, proc, len); if (! sexp_procedurep(proc)) { res = sexp_exceptionp(proc) ? proc : sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); @@ -1475,5 +1482,6 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { res = sexp_vm(ctx, proc); if (! res) res = SEXP_VOID; /* shouldn't happen */ } + sexp_gc_release1(ctx); return res; }