diff --git a/eval.c b/eval.c index 4cd416a9..2df19d11 100644 --- a/eval.c +++ b/eval.c @@ -260,7 +260,7 @@ void sexp_shrink_bcode (sexp ctx, sexp_uint_t i) { void sexp_expand_bcode (sexp ctx, sexp_uint_t size) { sexp tmp; if (sexp_bytecode_length(sexp_context_bc(ctx)) - < (sexp_context_pos(ctx))+size) { + < (sexp_unbox_fixnum(sexp_context_pos(ctx)))+size) { tmp=sexp_alloc_bytecode(ctx, sexp_bytecode_length(sexp_context_bc(ctx))*2); sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); sexp_bytecode_length(tmp) @@ -278,13 +278,14 @@ void sexp_expand_bcode (sexp ctx, sexp_uint_t size) { void sexp_emit (sexp ctx, unsigned char c) { sexp_expand_bcode(ctx, 1); - sexp_bytecode_data(sexp_context_bc(ctx))[sexp_context_pos(ctx)++] = c; + sexp_bytecode_data(sexp_context_bc(ctx))[sexp_unbox_fixnum(sexp_context_pos(ctx))] = c; + sexp_context_pos(ctx) = sexp_fx_add(sexp_context_pos(ctx), SEXP_ONE); } sexp sexp_complete_bytecode (sexp ctx) { sexp bc; sexp_emit_return(ctx); - sexp_shrink_bcode(ctx, sexp_context_pos(ctx)); + sexp_shrink_bcode(ctx, sexp_unbox_fixnum(sexp_context_pos(ctx))); bc = sexp_context_bc(ctx); if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */ if (sexp_nullp(sexp_cdr(sexp_bytecode_literals(bc)))) @@ -294,6 +295,7 @@ sexp sexp_complete_bytecode (sexp ctx) { else sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); } + sexp_bytecode_max_depth(bc) = sexp_unbox_fixnum(sexp_context_max_depth(ctx)); #if SEXP_USE_FULL_SOURCE_INFO if (sexp_bytecode_source(bc) && sexp_pairp(sexp_bytecode_source(bc))) { sexp_bytecode_source(bc) = sexp_nreverse(ctx, sexp_bytecode_source(bc)); @@ -444,6 +446,9 @@ sexp sexp_make_eval_context (sexp ctx, sexp stack, sexp env, sexp_uint_t size, s return res; if (ctx) sexp_gc_preserve1(ctx, res); sexp_context_env(res) = (env ? env : sexp_make_primitive_env(res, SEXP_SEVEN)); + sexp_context_specific(res) = sexp_make_vector(res, SEXP_SEVEN, SEXP_ZERO); + sexp_context_lambda(res) = SEXP_FALSE; + sexp_context_fv(res) = SEXP_NULL; sexp_context_bc(res) = sexp_alloc_bytecode(res, SEXP_INIT_BCODE_SIZE); if (sexp_exceptionp(sexp_context_bc(res))) { res = sexp_context_bc(res); @@ -2126,6 +2131,7 @@ sexp sexp_compile_op (sexp ctx, sexp self, sexp_sint_t n, sexp obj, sexp env) { sexp_emit_enter(ctx2); sexp_generate(ctx2, 0, 0, 0, ast); res = sexp_complete_bytecode(ctx2); + sexp_context_specific(ctx2) = SEXP_FALSE; vec = sexp_make_vector(ctx2, 0, SEXP_VOID); if (sexp_exceptionp(vec)) res = vec; else res = sexp_make_procedure(ctx2, SEXP_ZERO, SEXP_ZERO, res, vec); diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 2c2444bc..db388ce6 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -367,7 +367,7 @@ struct sexp_struct { #endif } env; struct { - sexp_uint_t length; + sexp_uint_t length, max_depth; sexp name, literals, source; unsigned char data[]; } bytecode; @@ -421,8 +421,8 @@ struct sexp_struct { struct timeval tval; #endif char tailp, tracep, timeoutp, waitp; - sexp_uint_t pos, depth, last_fp; - sexp bc, lambda, stack, env, fv, parent, child, + sexp_uint_t last_fp; + sexp stack, env, parent, child, globals, dk, params, proc, name, specific, event; #if SEXP_USE_DL sexp dl; @@ -922,6 +922,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_cpointer_maybe_null_value(x) (sexp_not(x) ? NULL : sexp_cpointer_value(x)) #define sexp_bytecode_length(x) (sexp_field(x, bytecode, SEXP_BYTECODE, length)) +#define sexp_bytecode_max_depth(x) (sexp_field(x, bytecode, SEXP_BYTECODE, max_depth)) #define sexp_bytecode_name(x) (sexp_field(x, bytecode, SEXP_BYTECODE, name)) #define sexp_bytecode_literals(x) (sexp_field(x, bytecode, SEXP_BYTECODE, literals)) #define sexp_bytecode_source(x) (sexp_field(x, bytecode, SEXP_BYTECODE, source)) @@ -1014,11 +1015,6 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_context_env(x) (sexp_field(x, context, SEXP_CONTEXT, env)) #define sexp_context_stack(x) (sexp_field(x, context, SEXP_CONTEXT, stack)) -#define sexp_context_depth(x) (sexp_field(x, context, SEXP_CONTEXT, depth)) -#define sexp_context_bc(x) (sexp_field(x, context, SEXP_CONTEXT, bc)) -#define sexp_context_fv(x) (sexp_field(x, context, SEXP_CONTEXT, fv)) -#define sexp_context_pos(x) (sexp_field(x, context, SEXP_CONTEXT, pos)) -#define sexp_context_lambda(x) (sexp_field(x, context, SEXP_CONTEXT, lambda)) #define sexp_context_parent(x) (sexp_field(x, context, SEXP_CONTEXT, parent)) #define sexp_context_child(x) (sexp_field(x, context, SEXP_CONTEXT, child)) #define sexp_context_saves(x) (sexp_field(x, context, SEXP_CONTEXT, saves)) @@ -1039,6 +1035,17 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_context_waitp(x) (sexp_field(x, context, SEXP_CONTEXT, waitp)) #define sexp_context_dl(x) (sexp_field(x, context, SEXP_CONTEXT, dl)) +/* during compilation, sexp_context_specific is set to a vector */ +/* containing the following elements: */ + +#define sexp_context_bc(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_ZERO)) +#define sexp_context_fv(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_ONE)) +#define sexp_context_lambda(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_TWO)) +#define sexp_context_pos(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_THREE)) +#define sexp_context_depth(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_FOUR)) +#define sexp_context_max_depth(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_FIVE)) +#define sexp_context_exception(x) (sexp_vector_ref(sexp_context_specific(x), SEXP_SIX)) + #if SEXP_USE_ALIGNED_BYTECODE #define sexp_context_align_pos(ctx) sexp_context_pos(ctx) = sexp_word_align(sexp_context_pos(ctx)) #else diff --git a/sexp.c b/sexp.c index 99045a80..1fb20114 100644 --- a/sexp.c +++ b/sexp.c @@ -212,7 +212,7 @@ static struct sexp_type_struct _sexp_type_specs[] = { {SEXP_SEQ, sexp_offsetof(seq, ls), 2, 2, 0, 0, sexp_sizeof(seq), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Sequence", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL}, {SEXP_LIT, sexp_offsetof(lit, value), 2, 2, 0, 0, sexp_sizeof(lit), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Literal", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, (sexp)sexp_write_simple_object, NULL}, {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), 0, 0, 0, 0, 0, 0, (sexp)"Stack", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL}, - {SEXP_CONTEXT, sexp_offsetof(context, bc), 14+SEXP_USE_DL, 14+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL}, + {SEXP_CONTEXT, sexp_offsetof(context, stack), 11+SEXP_USE_DL, 11+SEXP_USE_DL, 0, 0, sexp_sizeof(context), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Context", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL}, {SEXP_CPOINTER, sexp_offsetof(cpointer, parent), 1, 0, 0, 0, sexp_sizeof(cpointer), sexp_offsetof(cpointer, length), 1, 0, 0, 0, 0, 0, 0, (sexp)"Cpointer", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL}, #if SEXP_USE_AUTO_FORCE {SEXP_PROMISE, sexp_offsetof(promise, thunk), 2, 2, 0, 0, sexp_sizeof(promise), 0, 0, 0, 0, 0, 0, 0, 0, (sexp)"Promise", SEXP_FALSE, SEXP_FALSE, NULL, SEXP_FALSE, NULL, NULL}, @@ -445,12 +445,10 @@ sexp sexp_make_context (sexp ctx, size_t size, size_t max_size) { } if (!res || sexp_exceptionp(res)) return res; 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) = NULL; sexp_context_params(res) = SEXP_NULL; - sexp_context_depth(res)=sexp_context_tracep(res)=sexp_context_pos(res)=0; + sexp_context_tracep(res) = 0; sexp_context_tailp(res) = 1; #if SEXP_USE_GREEN_THREADS sexp_context_event(res) = SEXP_FALSE; diff --git a/vm.c b/vm.c index cfd6cd0a..d7c5c57b 100644 --- a/vm.c +++ b/vm.c @@ -82,6 +82,17 @@ sexp sexp_stack_trace_op (sexp ctx, sexp self, sexp_sint_t n, sexp out) { /************************* code generation ****************************/ +static void sexp_inc_context_pos(sexp ctx, sexp_sint_t off) { + sexp_context_pos(ctx) = sexp_fx_add(sexp_context_pos(ctx), sexp_make_fixnum(off)); +} + +static void sexp_inc_context_depth(sexp ctx, sexp_sint_t off) { + sexp_context_depth(ctx) = sexp_fx_add(sexp_context_depth(ctx), sexp_make_fixnum(off)); + if (sexp_unbox_fixnum(sexp_context_depth(ctx)) + > sexp_unbox_fixnum(sexp_context_max_depth(ctx))) + sexp_context_max_depth(ctx) = sexp_context_depth(ctx); +} + static void bytecode_preserve (sexp ctx, sexp obj) { sexp ls = sexp_bytecode_literals(sexp_context_bc(ctx)); if (sexp_pointerp(obj) && !sexp_symbolp(obj) @@ -94,13 +105,14 @@ static void sexp_emit_word (sexp ctx, sexp_uint_t val) { sexp_expand_bcode(ctx, sizeof(sexp)); data = sexp_bytecode_data(sexp_context_bc(ctx)); sexp_context_align_pos(ctx); - *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; - sexp_context_pos(ctx) += sizeof(sexp); + *((sexp_uint_t*)(&(data[sexp_unbox_fixnum(sexp_context_pos(ctx))]))) = val; + sexp_inc_context_pos(ctx, sizeof(sexp)); } static void sexp_emit_push (sexp ctx, sexp obj) { sexp_emit(ctx, SEXP_OP_PUSH); sexp_emit_word(ctx, (sexp_uint_t)obj); + sexp_inc_context_depth(ctx, 1); bytecode_preserve(ctx, obj); } @@ -116,9 +128,9 @@ static void sexp_push_source (sexp ctx, sexp source) { src = sexp_bytecode_source(bc); if (!src) src = sexp_bytecode_source(bc) = SEXP_NULL; if (!sexp_pairp(src) - || sexp_context_pos(ctx) > sexp_unbox_fixnum(sexp_caar(src))) { + || sexp_unbox_fixnum(sexp_context_pos(ctx)) > sexp_unbox_fixnum(sexp_caar(src))) { sexp_gc_preserve1(ctx, tmp); - tmp = sexp_cons(ctx, sexp_make_fixnum(sexp_context_pos(ctx)), source); + tmp = sexp_cons(ctx, sexp_context_pos(ctx), source); if (sexp_pairp(tmp)) { tmp = sexp_cons(ctx, tmp, src); if (sexp_pairp(tmp)) sexp_bytecode_source(bc) = tmp; @@ -132,15 +144,15 @@ static void sexp_push_source (sexp ctx, sexp source) { static sexp_sint_t sexp_context_make_label (sexp ctx) { sexp_sint_t label; sexp_context_align_pos(ctx); - label = sexp_context_pos(ctx); - sexp_context_pos(ctx) += sizeof(sexp_uint_t); + label = sexp_unbox_fixnum(sexp_context_pos(ctx)); + sexp_inc_context_pos(ctx, sizeof(sexp_uint_t)); return label; } static void sexp_context_patch_label (sexp ctx, sexp_sint_t label) { sexp bc = sexp_context_bc(ctx); unsigned char *data = sexp_bytecode_data(bc)+label; - *((sexp_sint_t*)data) = sexp_context_pos(ctx)-label; + *((sexp_sint_t*)data) = sexp_unbox_fixnum(sexp_context_pos(ctx))-label; } static void generate_lit (sexp ctx, sexp value) { @@ -153,7 +165,7 @@ static void generate_drop_prev (sexp ctx, sexp prev) { && sexp_opcode_class(sexp_car(prev)) != SEXP_OPC_FOREIGN) || (sexp_opcode_code(sexp_car(prev)) == SEXP_OP_PUSH))) || sexp_setp(prev) || sexp_litp(prev) || prev == SEXP_VOID) - sexp_context_pos(ctx) -= 1 + sizeof(sexp); + sexp_inc_context_pos(ctx, -(1 + sizeof(sexp))); else sexp_emit(ctx, SEXP_OP_DROP); } @@ -167,7 +179,7 @@ static void generate_seq (sexp ctx, sexp name, sexp loc, sexp lam, sexp app) { if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) { sexp_generate(ctx, name, loc, lam, sexp_car(head)); generate_drop_prev(ctx, sexp_car(head)); - sexp_context_depth(ctx)--; + sexp_inc_context_depth(ctx, -1); } sexp_context_tailp(ctx) = tailp; sexp_generate(ctx, name, loc, lam, sexp_car(head)); @@ -180,12 +192,12 @@ static void generate_cnd (sexp ctx, sexp name, sexp loc, sexp lam, sexp cnd) { sexp_generate(ctx, name, loc, lam, sexp_cnd_test(cnd)); sexp_context_tailp(ctx) = tailp; sexp_emit(ctx, SEXP_OP_JUMP_UNLESS); - sexp_context_depth(ctx)--; + sexp_inc_context_depth(ctx, -1); label1 = sexp_context_make_label(ctx); sexp_generate(ctx, name, loc, lam, sexp_cnd_pass(cnd)); sexp_context_tailp(ctx) = tailp; sexp_emit(ctx, SEXP_OP_JUMP); - sexp_context_depth(ctx)--; + sexp_inc_context_depth(ctx, -1); label2 = sexp_context_make_label(ctx); sexp_context_patch_label(ctx, label1); sexp_generate(ctx, name, loc, lam, sexp_cnd_fail(cnd)); @@ -211,7 +223,7 @@ static void generate_non_global_ref (sexp ctx, sexp name, sexp cell, } if (unboxp && (sexp_truep(sexp_memq(ctx, name, sexp_lambda_sv(loc))))) sexp_emit(ctx, SEXP_OP_CDR); - sexp_context_depth(ctx)++; + sexp_inc_context_depth(ctx, +1); } static void generate_ref (sexp ctx, sexp ref, int unboxp) { @@ -266,7 +278,7 @@ static void generate_set (sexp ctx, sexp set) { } } sexp_emit_push(ctx, SEXP_VOID); - sexp_context_depth(ctx)--; + sexp_inc_context_depth(ctx, +1); } static void generate_opcode_app (sexp ctx, sexp app) { @@ -298,7 +310,7 @@ static void generate_opcode_app (sexp ctx, sexp app) { } else { sexp_emit_push(ctx, sexp_opcode_data(op)); } - sexp_context_depth(ctx)++; + sexp_inc_context_depth(ctx, +1); num_args++; } } @@ -324,7 +336,7 @@ static void generate_opcode_app (sexp ctx, sexp app) { if (inv_default) { sexp_emit_push(ctx, sexp_opcode_data(op)); if (sexp_opcode_opt_param_p(op)) sexp_emit(ctx, SEXP_OP_CDR); - sexp_context_depth(ctx)++; + sexp_inc_context_depth(ctx, +1); num_args++; } @@ -409,7 +421,7 @@ static void generate_opcode_app (sexp ctx, sexp app) { && sexp_opcode_class(op) != SEXP_OPC_FOREIGN) sexp_emit_push(ctx, SEXP_VOID); - sexp_context_depth(ctx) -= (num_args-1); + sexp_inc_context_depth(ctx, -(num_args-1)); sexp_gc_release1(ctx); } @@ -432,7 +444,7 @@ static void generate_general_app (sexp ctx, sexp app) { sexp_emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); sexp_context_tailp(ctx) = tailp; - sexp_context_depth(ctx) -= len; + sexp_inc_context_depth(ctx, -len); sexp_gc_release1(ctx); } @@ -460,7 +472,7 @@ static void generate_tail_jump (sexp ctx, sexp name, sexp loc, sexp lam, sexp ap /* drop the current result and jump */ sexp_emit(ctx, SEXP_OP_JUMP); - sexp_emit_word(ctx, (sexp_uint_t) (-sexp_context_pos(ctx) + + sexp_emit_word(ctx, (sexp_uint_t) (-sexp_unbox_fixnum(sexp_context_pos(ctx)) + (sexp_pairp(sexp_lambda_locals(lam)) ? 1 + sizeof(sexp) : 0))); @@ -508,7 +520,7 @@ static int generate_lambda_locals (sexp ctx, sexp name, sexp loc, sexp lam, sexp return 1; } else if (sexp_setp(x) && sexp_internal_definep(ctx, sexp_set_var(x))) { sexp_generate(ctx, name, loc, lam, x); - sexp_context_pos(ctx) -= 1 + sizeof(sexp); + sexp_inc_context_pos(ctx, -(1 + sizeof(sexp))); return 1; } return 0; @@ -559,7 +571,7 @@ static int generate_lambda_body (sexp ctx, sexp name, sexp loc, sexp lam, sexp x sexp_emit(ctx, SEXP_OP_STACK_REF); sexp_emit_word(ctx, 3); sexp_emit(ctx, SEXP_OP_VECTOR_SET); - sexp_context_depth(ctx)--; + sexp_inc_context_depth(ctx, -1); } } } @@ -633,7 +645,7 @@ static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambd sexp_emit_push(ctx, SEXP_VOID); sexp_emit_push(ctx, sexp_length(ctx, fv)); sexp_emit(ctx, SEXP_OP_MAKE_VECTOR); - sexp_context_depth(ctx)--; + sexp_inc_context_depth(ctx, -1); for (k=0; sexp_pairp(fv); fv=sexp_cdr(fv), k++) { ref = sexp_car(fv); generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), @@ -642,7 +654,7 @@ static void generate_lambda (sexp ctx, sexp name, sexp loc, sexp lam, sexp lambd sexp_emit(ctx, SEXP_OP_STACK_REF); sexp_emit_word(ctx, 3); sexp_emit(ctx, SEXP_OP_VECTOR_SET); - sexp_context_depth(ctx)--; + sexp_inc_context_depth(ctx, -1); } /* push the additional procedure info and make the closure */ sexp_emit(ctx, SEXP_OP_MAKE_PROCEDURE); @@ -879,15 +891,15 @@ sexp sexp_print_vm_profile (sexp ctx, sexp self, sexp_sint_t n) { #endif #if SEXP_USE_CHECK_STACK -#define sexp_ensure_stack(n) \ - if (top+n >= sexp_stack_length(sexp_context_stack(ctx))) { \ - sexp_context_top(ctx) = top; \ - if (sexp_grow_stack(ctx, n)) { \ - stack = sexp_stack_data(sexp_context_stack(ctx)); \ - } else { \ - _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); \ - goto end_loop; \ - } \ +#define sexp_ensure_stack(n) \ + if (top+(n) >= sexp_stack_length(sexp_context_stack(ctx))) { \ + sexp_context_top(ctx) = top; \ + if (sexp_grow_stack(ctx, (n))) { \ + stack = sexp_stack_data(sexp_context_stack(ctx)); \ + } else { \ + _ARG1 = sexp_global(ctx, SEXP_G_OOS_ERROR); \ + goto end_loop; \ + } \ } #else #define sexp_ensure_stack(n) @@ -1029,7 +1041,7 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { top -= 2; apply1: i = sexp_unbox_fixnum(sexp_length(ctx, tmp2)); - sexp_ensure_stack(i + 64); + sexp_ensure_stack(i + 64 + sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0); top += i; for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--) _ARG1 = sexp_car(tmp2); @@ -1054,7 +1066,6 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { fp = sexp_unbox_fixnum(tmp2); goto make_call; case SEXP_OP_CALL: - sexp_ensure_stack(64); /* TODO: pre-compute stack needed for each proc */ _ALIGN_IP(); i = sexp_unbox_fixnum(_WORD0); tmp1 = _ARG1; @@ -1074,6 +1085,8 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { if (j < 0) sexp_raise("not enough args", sexp_list2(ctx, tmp1, sexp_make_fixnum(i))); + /* ensure there's sufficient stack space before pushing args */ + sexp_ensure_stack(sexp_bytecode_max_depth(sexp_procedure_code(tmp1))+64); if (j > 0) { if (sexp_procedure_variadic_p(tmp1)) { if (!sexp_procedure_unused_rest_p(tmp1)) {