From f8a32963725d11177ad3c8769c610c4ad1ed7d39 Mon Sep 17 00:00:00 2001 From: Alex Shinn Date: Sat, 15 May 2010 13:05:50 +0900 Subject: [PATCH] moving apply to vm.c copying lambda param lists on creation --- eval.c | 461 +++------------------------------------ include/chibi/eval.h | 4 +- include/chibi/features.h | 18 ++ include/chibi/sexp.h | 20 +- sexp.c | 12 + vm.c | 429 ++++++++++++++++++++++++++++++++++++ 6 files changed, 501 insertions(+), 443 deletions(-) diff --git a/eval.c b/eval.c index d5babf23..b35b8891 100644 --- a/eval.c +++ b/eval.c @@ -169,7 +169,7 @@ static void shrink_bcode (sexp ctx, sexp_uint_t i) { sexp tmp; if (sexp_bytecode_length(sexp_context_bc(ctx)) != i) { tmp = sexp_alloc_bytecode(ctx, i); - sexp_bytecode_name(tmp) = SEXP_FALSE; + sexp_bytecode_name(tmp) = sexp_bytecode_name(sexp_context_bc(ctx)); sexp_bytecode_length(tmp) = i; sexp_bytecode_literals(tmp) = sexp_bytecode_literals(sexp_context_bc(ctx)); @@ -197,30 +197,13 @@ static void expand_bcode (sexp ctx, sexp_uint_t size) { } } -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) { - unsigned char *data; - 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); -} - -static void emit_push (sexp ctx, sexp obj) { - emit(ctx, SEXP_OP_PUSH); - emit_word(ctx, (sexp_uint_t)obj); - if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) - sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); -} +static void emit_enter (sexp ctx); +static void emit_return (sexp ctx); +static void bless_bytecode (sexp ctx, sexp bc); static sexp finalize_bytecode (sexp ctx) { sexp bc; - emit(ctx, SEXP_OP_RET); + emit_return(ctx); shrink_bcode(ctx, sexp_context_pos(ctx)); bc = sexp_context_bc(ctx); if (sexp_pairp(sexp_bytecode_literals(bc))) { /* compress literals */ @@ -231,11 +214,17 @@ static sexp finalize_bytecode (sexp ctx) { else sexp_bytecode_literals(bc) = sexp_list_to_vector(ctx, sexp_bytecode_literals(bc)); } + bless_bytecode(ctx, bc); return bc; } -sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, - sexp bc, sexp vars) { +static void emit (sexp ctx, unsigned char c) { + expand_bcode(ctx, 1); + sexp_bytecode_data(sexp_context_bc(ctx))[sexp_context_pos(ctx)++] = c; +} + +sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), 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; @@ -303,6 +292,14 @@ static sexp sexp_make_lit (sexp ctx, sexp value) { return res; } +/************************* backend ***************************/ + +#if SEXP_USE_NATIVE_X86 +#include "opt/x86.c" +#else +#include "vm.c" +#endif + /****************************** contexts ******************************/ #define SEXP_STACK_SIZE (sexp_sizeof(stack)+sizeof(sexp)*SEXP_INIT_STACK_SIZE) @@ -325,9 +322,10 @@ void sexp_init_eval_context_globals (sexp ctx) { sexp_gc_var2(tmp, vec); ctx = sexp_make_child_context(ctx, NULL); sexp_gc_preserve2(ctx, tmp, vec); - tmp = sexp_intern(ctx, "*current-exception-handler*", -1); + vec = sexp_intern(ctx, "*current-exception-handler*", -1); sexp_global(ctx, SEXP_G_ERR_HANDLER) - = sexp_env_cell_create(ctx, sexp_context_env(ctx), tmp, SEXP_FALSE, NULL); + = sexp_env_cell_create(ctx, sexp_context_env(ctx), vec, SEXP_FALSE, NULL); +#if ! SEXP_USE_NATIVE_X86 emit(ctx, SEXP_OP_RESUMECC); sexp_global(ctx, SEXP_G_RESUMECC_BYTECODE) = finalize_bytecode(ctx); ctx = sexp_make_child_context(ctx, NULL); @@ -338,6 +336,7 @@ void sexp_init_eval_context_globals (sexp ctx) { = sexp_make_procedure(ctx, SEXP_ZERO, SEXP_ZERO, tmp, vec); sexp_bytecode_name(sexp_procedure_code(sexp_global(ctx, SEXP_G_FINAL_RESUMER))) = sexp_intern(ctx, "final-resumer", -1); +#endif sexp_global(ctx, SEXP_G_MODULE_PATH) = SEXP_NULL; sexp_add_path(ctx, sexp_default_module_dir); sexp_add_path(ctx, getenv(SEXP_MODULE_PATH_VAR)); @@ -530,7 +529,7 @@ static sexp analyze_lambda (sexp ctx, sexp x) { else if (sexp_truep(sexp_memq(ctx, sexp_car(ls), sexp_cdr(ls)))) sexp_return(res, sexp_compile_error(ctx, "duplicate parameter", x)); /* build lambda and analyze body */ - res = sexp_make_lambda(ctx, sexp_cadr(x)); + res = sexp_make_lambda(ctx, sexp_copy_list(ctx, sexp_cadr(x))); ctx2 = sexp_make_child_context(ctx, res); tmp = sexp_flatten_dot(ctx2, sexp_lambda_params(res)); sexp_context_env(ctx2) = sexp_extend_env(ctx2, sexp_context_env(ctx2), tmp, res); @@ -799,328 +798,7 @@ static sexp analyze (sexp ctx, sexp object) { sexp sexp_analyze (sexp ctx, sexp x) {return analyze(ctx, x);} -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); - 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; -} - -static void generate_lit (sexp ctx, sexp value) { - emit_push(ctx, value); -} - -static void generate_seq (sexp ctx, sexp app) { - sexp head=app, tail=sexp_cdr(app); - sexp_uint_t tailp = sexp_context_tailp(ctx); - sexp_context_tailp(ctx) = 0; - for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) - if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) { - generate(ctx, sexp_car(head)); - emit(ctx, SEXP_OP_DROP); - sexp_context_depth(ctx)--; - } - sexp_context_tailp(ctx) = tailp; - generate(ctx, sexp_car(head)); -} - -static void generate_cnd (sexp ctx, sexp cnd) { - sexp_sint_t label1, label2, tailp=sexp_context_tailp(ctx); - sexp_context_tailp(ctx) = 0; - generate(ctx, sexp_cnd_test(cnd)); - sexp_context_tailp(ctx) = tailp; - emit(ctx, SEXP_OP_JUMP_UNLESS); - sexp_context_depth(ctx)--; - label1 = sexp_context_make_label(ctx); - generate(ctx, sexp_cnd_pass(cnd)); - sexp_context_tailp(ctx) = tailp; - emit(ctx, SEXP_OP_JUMP); - sexp_context_depth(ctx)--; - label2 = sexp_context_make_label(ctx); - sexp_context_patch_label(ctx, label1); - generate(ctx, sexp_cnd_fail(cnd)); - sexp_context_patch_label(ctx, label2); -} - -static void generate_non_global_ref (sexp ctx, sexp name, sexp cell, - sexp lambda, sexp fv, int unboxp) { - sexp_uint_t i; - sexp loc = sexp_cdr(cell); - if (loc == lambda && sexp_lambdap(lambda)) { - /* local ref */ - emit(ctx, SEXP_OP_LOCAL_REF); - emit_word(ctx, sexp_param_index(lambda, name)); - } else { - /* closure ref */ - for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) - if ((name == sexp_ref_name(sexp_car(fv))) - && (loc == sexp_ref_loc(sexp_car(fv)))) - break; - emit(ctx, SEXP_OP_CLOSURE_REF); - emit_word(ctx, i); - } - if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) - emit(ctx, SEXP_OP_CDR); - sexp_context_depth(ctx)++; -} - -static void generate_ref (sexp ctx, sexp ref, int unboxp) { - sexp lam; - 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_word(ctx, (sexp_uint_t)sexp_ref_cell(ref)); - } else - emit_push(ctx, sexp_ref_cell(ref)); - } else { - lam = sexp_context_lambda(ctx); - generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), - lam, sexp_lambda_fv(lam), unboxp); - } -} - -static void generate_set (sexp ctx, sexp set) { - sexp ref = sexp_set_var(set), lambda; - /* compile the value */ - sexp_context_tailp(ctx) = 0; - if (sexp_lambdap(sexp_set_value(set))) - sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref); - generate(ctx, sexp_set_value(set)); - if (! sexp_lambdap(sexp_ref_loc(ref))) { - /* global vars are set directly */ - emit_push(ctx, sexp_ref_cell(ref)); - emit(ctx, SEXP_OP_SET_CDR); - } else { - lambda = sexp_ref_loc(ref); - if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { - /* stack or closure mutable vars are boxed */ - generate_ref(ctx, ref, 0); - emit(ctx, SEXP_OP_SET_CDR); - } else { - /* internally defined variable */ - emit(ctx, SEXP_OP_LOCAL_SET); - emit_word(ctx, sexp_param_index(lambda, sexp_ref_name(ref))); - } - } - sexp_context_depth(ctx)--; -} - -static void generate_opcode_app (sexp ctx, sexp app) { - sexp op = sexp_car(app); - sexp_sint_t i, num_args, inv_default=0; - sexp_gc_var1(ls); - sexp_gc_preserve1(ctx, ls); - - num_args = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))); - sexp_context_tailp(ctx) = 0; - - /* maybe push the default for an optional argument */ - if ((num_args == sexp_opcode_num_args(op)) - && sexp_opcode_variadic_p(op) - && sexp_opcode_data(op) - && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { - if (sexp_opcode_inverse(op)) { - inv_default = 1; - } else { - emit_push(ctx, sexp_opcode_data(op)); - if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); - sexp_context_depth(ctx)++; - num_args++; - } - } - - /* push the arguments onto the stack in reverse order */ - ls = ((sexp_opcode_inverse(op) - && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC)) - ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); - for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) - generate(ctx, sexp_car(ls)); - - /* push the default for inverse opcodes */ - if (inv_default) { - emit_push(ctx, sexp_opcode_data(op)); - if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); - sexp_context_depth(ctx)++; - num_args++; - } - - /* emit the actual operator call */ - switch (sexp_opcode_class(op)) { - case SEXP_OPC_ARITHMETIC: - /* fold variadic arithmetic operators */ - for (i=num_args-1; i>0; i--) - emit(ctx, sexp_opcode_code(op)); - break; - case SEXP_OPC_ARITHMETIC_CMP: - if (num_args > 2) { - emit(ctx, SEXP_OP_STACK_REF); - emit_word(ctx, 2); - emit(ctx, SEXP_OP_STACK_REF); - emit_word(ctx, 2); - emit(ctx, sexp_opcode_code(op)); - emit(ctx, SEXP_OP_AND); - for (i=num_args-2; i>0; i--) { - emit(ctx, SEXP_OP_STACK_REF); - emit_word(ctx, 3); - emit(ctx, SEXP_OP_STACK_REF); - emit_word(ctx, 3); - emit(ctx, sexp_opcode_code(op)); - emit(ctx, SEXP_OP_AND); - emit(ctx, SEXP_OP_AND); - } - } else - emit(ctx, sexp_opcode_code(op)); - break; - case SEXP_OPC_FOREIGN: - emit(ctx, sexp_opcode_code(op)); - emit_word(ctx, (sexp_uint_t)op); - break; - case SEXP_OPC_TYPE_PREDICATE: - case SEXP_OPC_GETTER: - case SEXP_OPC_SETTER: - case SEXP_OPC_CONSTRUCTOR: - emit(ctx, sexp_opcode_code(op)); - if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) - || sexp_opcode_code(op) == SEXP_OP_MAKE) { - if (sexp_opcode_data(op)) - 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))); - } - break; - case SEXP_OPC_PARAMETER: - emit_push(ctx, sexp_opcode_data(op)); - emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); - break; - default: - emit(ctx, sexp_opcode_code(op)); - } - - sexp_context_depth(ctx) -= (num_args-1); - sexp_gc_release1(ctx); -} - -static void generate_general_app (sexp ctx, sexp app) { - sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), - tailp = sexp_context_tailp(ctx); - sexp_gc_var1(ls); - sexp_gc_preserve1(ctx, ls); - - /* push the arguments onto the stack */ - sexp_context_tailp(ctx) = 0; - for (ls=sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls=sexp_cdr(ls)) - generate(ctx, sexp_car(ls)); - - /* push the operator onto the stack */ - generate(ctx, sexp_car(app)); - - /* maybe overwrite the current frame */ - emit(ctx, (tailp ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); - emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); - - sexp_context_tailp(ctx) = tailp; - sexp_context_depth(ctx) -= len; - sexp_gc_release1(ctx); -} - -static void generate_app (sexp ctx, sexp app) { - if (sexp_opcodep(sexp_car(app))) - generate_opcode_app(ctx, app); - else - generate_general_app(ctx, app); -} - -static void generate_lambda (sexp ctx, sexp lambda) { - sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv; - sexp_uint_t k; - sexp_gc_var2(tmp, bc); - sexp_gc_preserve2(ctx, tmp, bc); - 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); - sexp_context_lambda(ctx2) = lambda; - /* allocate space for local vars */ - for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) - emit_push(ctx2, SEXP_VOID); - /* box mutable vars */ - for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { - k = sexp_param_index(lambda, sexp_car(ls)); - if (k >= 0) { - emit(ctx2, SEXP_OP_LOCAL_REF); - emit_word(ctx2, k); - emit_push(ctx2, sexp_car(ls)); - emit(ctx2, SEXP_OP_CONS); - emit(ctx2, SEXP_OP_LOCAL_SET); - emit_word(ctx2, k); - emit(ctx2, SEXP_OP_DROP); - } - } - sexp_context_tailp(ctx2) = 1; - generate(ctx2, sexp_lambda_body(lambda)); - flags = sexp_make_fixnum((sexp_listp(ctx2, sexp_lambda_params(lambda)) - == SEXP_FALSE) ? 1uL : 0uL); - len = sexp_length(ctx2, sexp_lambda_params(lambda)); - bc = finalize_bytecode(ctx2); - sexp_bytecode_name(bc) = sexp_lambda_name(lambda); - if (sexp_nullp(fv)) { - /* shortcut, no free vars */ - tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID); - tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp); - sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), tmp); - generate_lit(ctx, tmp); - } else { - /* push the closed vars */ - emit_push(ctx, SEXP_VOID); - emit_push(ctx, sexp_length(ctx, fv)); - emit(ctx, SEXP_OP_MAKE_VECTOR); - sexp_context_depth(ctx)--; - 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), - prev_lambda, prev_fv, 0); - emit_push(ctx, sexp_make_fixnum(k)); - emit(ctx, SEXP_OP_STACK_REF); - emit_word(ctx, 3); - emit(ctx, SEXP_OP_VECTOR_SET); - emit(ctx, SEXP_OP_DROP); - sexp_context_depth(ctx)--; - } - /* push the additional procedure info and make the closure */ - emit_push(ctx, bc); - emit_push(ctx, len); - emit_push(ctx, flags); - emit(ctx, SEXP_OP_MAKE_PROCEDURE); - } - sexp_gc_release2(ctx); -} - -static void generate (sexp ctx, sexp x) { - if (sexp_pointerp(x)) { - switch (sexp_pointer_tag(x)) { - case SEXP_PAIR: generate_app(ctx, x); break; - case SEXP_LAMBDA: generate_lambda(ctx, x); break; - case SEXP_CND: generate_cnd(ctx, x); break; - case SEXP_REF: generate_ref(ctx, x, 1); break; - case SEXP_SET: generate_set(ctx, x); break; - case SEXP_SEQ: generate_seq(ctx, sexp_seq_ls(x)); break; - case SEXP_LIT: generate_lit(ctx, sexp_lit_value(x)); break; - default: generate_lit(ctx, x); - } - } else { - generate_lit(ctx, x); - } -} +/********************** free varable analysis *************************/ static sexp insert_free_var (sexp ctx, sexp x, sexp fv) { sexp name=sexp_ref_name(x), loc=sexp_ref_loc(x), ls; @@ -1188,50 +866,6 @@ sexp sexp_free_vars (sexp ctx, sexp x, sexp fv) { return fv1; } -static sexp make_param_list (sexp ctx, sexp_uint_t i) { - sexp_gc_var1(res); - sexp_gc_preserve1(ctx, res); - res = SEXP_NULL; - for ( ; i>0; i--) - res = sexp_cons(ctx, sexp_make_fixnum(i), res); - sexp_gc_release1(ctx); - return res; -} - -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); - 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)) { - return sexp_compile_error(ctx, "not enough args for opcode", op); - } 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); - params = make_param_list(ctx, i); - lambda = sexp_make_lambda(ctx, params); - ctx2 = sexp_make_child_context(ctx, lambda); - env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda); - sexp_context_env(ctx2) = env; - for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) { - ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(env, sexp_car(ls))); - sexp_push(ctx2, refs, ref); - } - refs = sexp_reverse(ctx2, refs); - refs = sexp_cons(ctx2, op, refs); - generate_opcode_app(ctx2, refs); - bc = finalize_bytecode(ctx2); - sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1); - 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); - return res; -} - -#include "vm.c" - /************************ library procedures **************************/ static sexp sexp_exception_type_op (sexp ctx sexp_api_params(self, n), sexp exn) { @@ -1487,19 +1121,6 @@ static sexp sexp_string_cmp_op (sexp ctx sexp_api_params(self, n), sexp str1, se /************************** optimizations *****************************/ -sexp sexp_apply_optimization (sexp ctx, sexp proc, sexp ast) { - sexp res; - sexp_gc_var1(args); - if (sexp_opcodep(proc)) { - res = ((sexp_proc2)sexp_opcode_func(proc))(ctx sexp_api_pass(proc, 1), ast); - } else { - sexp_gc_preserve1(ctx, args); - res = sexp_apply(ctx, proc, args=sexp_list1(ctx, ast)); - sexp_gc_release1(ctx); - } - return res; -} - #if SEXP_USE_SIMPLIFY #include "opt/simplify.c" #endif @@ -1889,31 +1510,6 @@ sexp sexp_env_copy_op (sexp ctx sexp_api_params(self, n), sexp to, sexp from, se /************************** eval interface ****************************/ -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; - len = sexp_unbox_fixnum(sexp_length(ctx, args)); - if (sexp_opcodep(proc)) - proc = make_opcode_procedure(ctx, proc, len); - if (! sexp_procedurep(proc)) { - res = sexp_exceptionp(proc) ? proc : - sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); - } else { - 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_ZERO; - stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); - stack[top++] = SEXP_ZERO; - sexp_context_top(ctx) = top; - res = sexp_vm(ctx, proc); - if (! res) res = SEXP_VOID; /* shouldn't happen */ - } - return res; -} - sexp sexp_compile (sexp ctx, sexp x) { sexp_gc_var3(ast, vec, res); sexp_gc_preserve3(ctx, ast, vec, res); @@ -1923,8 +1519,9 @@ sexp sexp_compile (sexp ctx, sexp x) { } else { res = sexp_global(ctx, SEXP_G_OPTIMIZATIONS); for ( ; sexp_pairp(res); res=sexp_cdr(res)) - ast = sexp_apply_optimization(ctx, sexp_cdar(res), ast); + ast = sexp_apply1(ctx, sexp_cdar(res), ast); sexp_free_vars(ctx, ast, SEXP_NULL); /* should return SEXP_NULL */ + emit_enter(ctx); generate(ctx, ast); res = finalize_bytecode(ctx); vec = sexp_make_vector(ctx, 0, SEXP_VOID); diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 1994bc74..6c16c277 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -129,7 +129,6 @@ SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda); SEXP_API sexp sexp_compile_error (sexp ctx, const char *message, sexp obj); SEXP_API sexp sexp_analyze (sexp context, sexp x); SEXP_API sexp sexp_apply (sexp context, sexp proc, sexp args); -SEXP_API sexp sexp_apply_optimization (sexp context, sexp proc, sexp ast); SEXP_API sexp sexp_free_vars (sexp context, sexp x, sexp fv); SEXP_API int sexp_param_index (sexp lambda, sexp name); SEXP_API sexp sexp_eval_op (sexp context sexp_api_params(self, n), sexp obj, sexp env); @@ -152,7 +151,7 @@ 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); 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, sexp_proc1); -SEXP_API sexp sexp_make_procedure (sexp ctx, sexp flags, sexp num_args, sexp bc, sexp vars); +SEXP_API sexp sexp_make_procedure_op (sexp ctx sexp_api_params(self, n), sexp flags, sexp num_args, sexp bc, sexp vars); SEXP_API sexp sexp_make_foreign (sexp ctx, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); SEXP_API sexp sexp_define_foreign_aux (sexp ctx, sexp env, const char *name, int num_args, int flags, sexp_proc1 f, sexp data); @@ -170,6 +169,7 @@ SEXP_API sexp sexp_make_setter_op (sexp ctx sexp_api_params(self, n), sexp name, /* simplify primitive API interface */ #define sexp_make_synclo(ctx, a, b, c) sexp_make_synclo_op(ctx sexp_api_pass(NULL, 3) a, b, c) +#define sexp_make_procedure(ctx, f, n, b, v) sexp_make_procedure_op(ctx sexp_api_pass(NULL, 4), f, n, b, v) #define sexp_make_env(ctx) sexp_make_env_op(ctx sexp_api_pass(NULL, 0)) #define sexp_make_null_env(ctx, v) sexp_make_null_env_op(ctx sexp_api_pass(NULL, 0), v) #define sexp_make_standard_env(ctx) sexp_make_standard_env_op(ctx sexp_api_pass(NULL, 0)) diff --git a/include/chibi/features.h b/include/chibi/features.h index fdb6fe98..a3a7d7b2 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 enable the experimental native x86 backend */ +/* #define SEXP_USE_NATIVE_X86 1 */ + /* uncomment this to disable the module system */ /* Currently this just loads the config.scm from main and */ /* sets up an (import (module name)) macro. */ @@ -206,6 +209,10 @@ #define SEXP_USE_NO_FEATURES 0 #endif +#ifndef SEXP_USE_NATIVE_X86 +#define SEXP_USE_NATIVE_X86 0 +#endif + #ifndef SEXP_USE_MODULES #define SEXP_USE_MODULES ! SEXP_USE_NO_FEATURES #endif @@ -338,6 +345,17 @@ #define SEXP_USE_CHECK_STACK ! SEXP_USE_NO_FEATURES #endif +#if SEXP_USE_NATIVE_X86 +#undef SEXP_USE_BOEHM +#define SEXP_USE_BOEHM 1 +#undef SEXP_USE_FLONUMS +#define SEXP_USE_FLONUMS 0 +#undef SEXP_USE_BIGNUMS +#define SEXP_USE_BIGNUMS 0 +#undef SEXP_USE_SIMPLIFY +#define SEXP_USE_SIMPLIFY 0 +#endif + #ifndef SEXP_USE_ALIGNED_BYTECODE #if defined(__arm__) #define SEXP_USE_ALIGNED_BYTECODE 1 diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index 05cdb7b5..9cd0807f 100644 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -41,21 +41,21 @@ typedef unsigned long size_t; #include /* tagging system - * bits end in 00: pointer - * 01: fixnum - * 011: immediate flonum (optional) - * 111: immediate symbol (optional) - * 0110: char - * 1110: other immediate object (NULL, TRUE, FALSE) + * bits end in 00: pointer + * 01: fixnum + * 011: immediate flonum (optional) + * 111: immediate symbol (optional) + * 000110: char + * 001110: unique immediate (NULL, TRUE, FALSE) */ #define SEXP_FIXNUM_BITS 2 #define SEXP_IMMEDIATE_BITS 3 -#define SEXP_EXTENDED_BITS 4 +#define SEXP_EXTENDED_BITS 6 #define SEXP_FIXNUM_MASK 3 #define SEXP_IMMEDIATE_MASK 7 -#define SEXP_EXTENDED_MASK 15 +#define SEXP_EXTENDED_MASK 63 #define SEXP_POINTER_TAG 0 #define SEXP_FIXNUM_TAG 1 @@ -208,7 +208,7 @@ struct sexp_struct { sexp kind, message, irritants, procedure, source; } exception; struct { - char sign; + signed char sign; sexp_uint_t length; sexp_uint_t data[]; } bignum; @@ -837,6 +837,7 @@ SEXP_API sexp sexp_equalp_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) SEXP_API sexp sexp_listp_op(sexp ctx sexp_api_params(self, n), sexp obj); SEXP_API sexp sexp_reverse_op(sexp ctx sexp_api_params(self, n), sexp ls); SEXP_API sexp sexp_nreverse_op(sexp ctx sexp_api_params(self, n), sexp ls); +SEXP_API sexp sexp_copy_list_op(sexp ctx sexp_api_params(self, n), sexp ls); SEXP_API sexp sexp_append2_op(sexp ctx sexp_api_params(self, n), sexp a, sexp b); SEXP_API sexp sexp_memq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); SEXP_API sexp sexp_assq_op(sexp ctx sexp_api_params(self, n), sexp x, sexp ls); @@ -913,6 +914,7 @@ SEXP_API sexp sexp_finalize_c_type (sexp ctx sexp_api_params(self, n), sexp obj) #define sexp_length(ctx, x) sexp_length_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_reverse(ctx, x) sexp_reverse_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_nreverse(ctx, x) sexp_nreverse_op(ctx sexp_api_pass(NULL, 1), x) +#define sexp_copy_list(ctx, x) sexp_copy_list_op(ctx sexp_api_pass(NULL, 1), x) #define sexp_cons(ctx, a, b) sexp_cons_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_append2(ctx, a, b) sexp_append2_op(ctx sexp_api_pass(NULL, 2), a, b) #define sexp_make_vector(ctx, a, b) sexp_make_vector_op(ctx sexp_api_pass(NULL, 2), a, b); diff --git a/sexp.c b/sexp.c index aea6d4f0..35861be0 100644 --- a/sexp.c +++ b/sexp.c @@ -547,6 +547,18 @@ sexp sexp_nreverse_op (sexp ctx sexp_api_params(self, n), sexp ls) { return b; } +sexp sexp_copy_list_op (sexp ctx sexp_api_params(self, n), sexp ls) { + sexp tmp; + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + if (! sexp_pairp(ls)) return ls; + tmp = res = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + for (ls=sexp_cdr(ls); sexp_pairp(ls); ls=sexp_cdr(ls), tmp=sexp_cdr(tmp)) + sexp_cdr(tmp) = sexp_cons(ctx, sexp_car(ls), sexp_cdr(ls)); + sexp_gc_release1(ctx); + return res; +} + sexp sexp_append2_op (sexp ctx sexp_api_params(self, n), sexp a, sexp b) { sexp_gc_var2(a1, b1); sexp_gc_preserve2(ctx, a1, b1); diff --git a/vm.c b/vm.c index e0edd053..6a53e941 100644 --- a/vm.c +++ b/vm.c @@ -2,6 +2,396 @@ /* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ +/************************* code generation ****************************/ + +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)); + sexp_context_align_pos(ctx); + *((sexp_uint_t*)(&(data[sexp_context_pos(ctx)]))) = val; + sexp_context_pos(ctx) += sizeof(sexp); +} + +static void emit_push (sexp ctx, sexp obj) { + emit(ctx, SEXP_OP_PUSH); + emit_word(ctx, (sexp_uint_t)obj); + if (sexp_pointerp(obj) && ! sexp_symbolp(obj)) + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), obj); +} + +static void emit_enter (sexp ctx) {return;} +static void bless_bytecode (sexp ctx, sexp bc) {return;} + +static void emit_return (sexp ctx) { + emit(ctx, SEXP_OP_RET); +} + +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); + 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; +} + +static void generate_lit (sexp ctx, sexp value) { + emit_push(ctx, value); +} + +static void generate_seq (sexp ctx, sexp app) { + sexp head=app, tail=sexp_cdr(app); + sexp_uint_t tailp = sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; + for ( ; sexp_pairp(tail); head=tail, tail=sexp_cdr(tail)) + if (sexp_pointerp(sexp_car(head)) && (! sexp_litp(sexp_car(head)))) { + generate(ctx, sexp_car(head)); + emit(ctx, SEXP_OP_DROP); + sexp_context_depth(ctx)--; + } + sexp_context_tailp(ctx) = tailp; + generate(ctx, sexp_car(head)); +} + +static void generate_cnd (sexp ctx, sexp cnd) { + sexp_sint_t label1, label2, tailp=sexp_context_tailp(ctx); + sexp_context_tailp(ctx) = 0; + generate(ctx, sexp_cnd_test(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_OP_JUMP_UNLESS); + sexp_context_depth(ctx)--; + label1 = sexp_context_make_label(ctx); + generate(ctx, sexp_cnd_pass(cnd)); + sexp_context_tailp(ctx) = tailp; + emit(ctx, SEXP_OP_JUMP); + sexp_context_depth(ctx)--; + label2 = sexp_context_make_label(ctx); + sexp_context_patch_label(ctx, label1); + generate(ctx, sexp_cnd_fail(cnd)); + sexp_context_patch_label(ctx, label2); +} + +static void generate_non_global_ref (sexp ctx, sexp name, sexp cell, + sexp lambda, sexp fv, int unboxp) { + sexp_uint_t i; + sexp loc = sexp_cdr(cell); + if (loc == lambda && sexp_lambdap(lambda)) { + /* local ref */ + emit(ctx, SEXP_OP_LOCAL_REF); + emit_word(ctx, sexp_param_index(lambda, name)); + } else { + /* closure ref */ + for (i=0; sexp_pairp(fv); fv=sexp_cdr(fv), i++) + if ((name == sexp_ref_name(sexp_car(fv))) + && (loc == sexp_ref_loc(sexp_car(fv)))) + break; + emit(ctx, SEXP_OP_CLOSURE_REF); + emit_word(ctx, i); + } + if (unboxp && (sexp_memq(ctx, name, sexp_lambda_sv(loc)) != SEXP_FALSE)) + emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; +} + +static void generate_ref (sexp ctx, sexp ref, int unboxp) { + sexp lam; + 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_word(ctx, (sexp_uint_t)sexp_ref_cell(ref)); + } else + emit_push(ctx, sexp_ref_cell(ref)); + } else { + lam = sexp_context_lambda(ctx); + generate_non_global_ref(ctx, sexp_ref_name(ref), sexp_ref_cell(ref), + lam, sexp_lambda_fv(lam), unboxp); + } +} + +static void generate_set (sexp ctx, sexp set) { + sexp ref = sexp_set_var(set), lambda; + /* compile the value */ + sexp_context_tailp(ctx) = 0; + if (sexp_lambdap(sexp_set_value(set))) + sexp_lambda_name(sexp_set_value(set)) = sexp_ref_name(ref); + generate(ctx, sexp_set_value(set)); + if (! sexp_lambdap(sexp_ref_loc(ref))) { + /* global vars are set directly */ + emit_push(ctx, sexp_ref_cell(ref)); + emit(ctx, SEXP_OP_SET_CDR); + } else { + lambda = sexp_ref_loc(ref); + if (sexp_truep(sexp_memq(ctx, sexp_ref_name(ref), sexp_lambda_sv(lambda)))) { + /* stack or closure mutable vars are boxed */ + generate_ref(ctx, ref, 0); + emit(ctx, SEXP_OP_SET_CDR); + } else { + /* internally defined variable */ + emit(ctx, SEXP_OP_LOCAL_SET); + emit_word(ctx, sexp_param_index(lambda, sexp_ref_name(ref))); + } + } + sexp_context_depth(ctx)--; +} + +static void generate_opcode_app (sexp ctx, sexp app) { + sexp op = sexp_car(app); + sexp_sint_t i, num_args, inv_default=0; + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); + + num_args = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))); + sexp_context_tailp(ctx) = 0; + + /* maybe push the default for an optional argument */ + if ((num_args == sexp_opcode_num_args(op)) + && sexp_opcode_variadic_p(op) + && sexp_opcode_data(op) + && (sexp_opcode_class(op) != SEXP_OPC_PARAMETER)) { + if (sexp_opcode_inverse(op)) { + inv_default = 1; + } else { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + } + + /* push the arguments onto the stack in reverse order */ + ls = ((sexp_opcode_inverse(op) + && (sexp_opcode_class(op) != SEXP_OPC_ARITHMETIC)) + ? sexp_cdr(app) : sexp_reverse(ctx, sexp_cdr(app))); + for ( ; sexp_pairp(ls); ls = sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the default for inverse opcodes */ + if (inv_default) { + emit_push(ctx, sexp_opcode_data(op)); + if (sexp_opcode_opt_param_p(op)) emit(ctx, SEXP_OP_CDR); + sexp_context_depth(ctx)++; + num_args++; + } + + /* emit the actual operator call */ + switch (sexp_opcode_class(op)) { + case SEXP_OPC_ARITHMETIC: + /* fold variadic arithmetic operators */ + for (i=num_args-1; i>0; i--) + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_ARITHMETIC_CMP: + if (num_args > 2) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 2); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + for (i=num_args-2; i>0; i--) { + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, sexp_opcode_code(op)); + emit(ctx, SEXP_OP_AND); + emit(ctx, SEXP_OP_AND); + } + } else + emit(ctx, sexp_opcode_code(op)); + break; + case SEXP_OPC_FOREIGN: + emit(ctx, sexp_opcode_code(op)); + emit_word(ctx, (sexp_uint_t)op); + break; + case SEXP_OPC_TYPE_PREDICATE: + case SEXP_OPC_GETTER: + case SEXP_OPC_SETTER: + case SEXP_OPC_CONSTRUCTOR: + emit(ctx, sexp_opcode_code(op)); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE) { + if (sexp_opcode_data(op)) + 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))); + } + break; + case SEXP_OPC_PARAMETER: + emit_push(ctx, sexp_opcode_data(op)); + emit(ctx, ((num_args == 0) ? SEXP_OP_CDR : SEXP_OP_SET_CDR)); + break; + default: + emit(ctx, sexp_opcode_code(op)); + } + + sexp_context_depth(ctx) -= (num_args-1); + sexp_gc_release1(ctx); +} + +static void generate_general_app (sexp ctx, sexp app) { + sexp_uint_t len = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app))), + tailp = sexp_context_tailp(ctx); + sexp_gc_var1(ls); + sexp_gc_preserve1(ctx, ls); + + /* push the arguments onto the stack */ + sexp_context_tailp(ctx) = 0; + for (ls=sexp_reverse(ctx, sexp_cdr(app)); sexp_pairp(ls); ls=sexp_cdr(ls)) + generate(ctx, sexp_car(ls)); + + /* push the operator onto the stack */ + generate(ctx, sexp_car(app)); + + /* maybe overwrite the current frame */ + emit(ctx, (tailp ? SEXP_OP_TAIL_CALL : SEXP_OP_CALL)); + emit_word(ctx, (sexp_uint_t)sexp_make_fixnum(len)); + + sexp_context_tailp(ctx) = tailp; + sexp_context_depth(ctx) -= len; + sexp_gc_release1(ctx); +} + +static void generate_app (sexp ctx, sexp app) { + if (sexp_opcodep(sexp_car(app))) + generate_opcode_app(ctx, app); + else + generate_general_app(ctx, app); +} + +static void generate_lambda (sexp ctx, sexp lambda) { + sexp ctx2, fv, ls, flags, len, ref, prev_lambda, prev_fv; + sexp_uint_t k; + sexp_gc_var2(tmp, bc); + sexp_gc_preserve2(ctx, tmp, bc); + 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_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0); + sexp_context_lambda(ctx2) = lambda; + /* allocate space for local vars */ + for (ls=sexp_lambda_locals(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) + emit_push(ctx2, SEXP_VOID); + /* box mutable vars */ + for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { + k = sexp_param_index(lambda, sexp_car(ls)); + if (k >= 0) { + emit(ctx2, SEXP_OP_LOCAL_REF); + emit_word(ctx2, k); + emit_push(ctx2, sexp_car(ls)); + emit(ctx2, SEXP_OP_CONS); + emit(ctx2, SEXP_OP_LOCAL_SET); + emit_word(ctx2, k); + emit(ctx2, SEXP_OP_DROP); + } + } + sexp_context_tailp(ctx2) = 1; + generate(ctx2, sexp_lambda_body(lambda)); + flags = sexp_make_fixnum((sexp_listp(ctx2, sexp_lambda_params(lambda)) + == SEXP_FALSE) ? 1uL : 0uL); + len = sexp_length(ctx2, sexp_lambda_params(lambda)); + bc = finalize_bytecode(ctx2); + sexp_bytecode_name(bc) = sexp_lambda_name(lambda); + if (sexp_nullp(fv)) { + /* shortcut, no free vars */ + tmp = sexp_make_vector(ctx2, SEXP_ZERO, SEXP_VOID); + tmp = sexp_make_procedure(ctx2, flags, len, bc, tmp); + sexp_push(ctx, sexp_bytecode_literals(sexp_context_bc(ctx)), tmp); + generate_lit(ctx, tmp); + } else { + /* push the closed vars */ + emit_push(ctx, SEXP_VOID); + emit_push(ctx, sexp_length(ctx, fv)); + emit(ctx, SEXP_OP_MAKE_VECTOR); + sexp_context_depth(ctx)--; + 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), + prev_lambda, prev_fv, 0); + emit_push(ctx, sexp_make_fixnum(k)); + emit(ctx, SEXP_OP_STACK_REF); + emit_word(ctx, 3); + emit(ctx, SEXP_OP_VECTOR_SET); + emit(ctx, SEXP_OP_DROP); + sexp_context_depth(ctx)--; + } + /* push the additional procedure info and make the closure */ + emit_push(ctx, bc); + emit_push(ctx, len); + emit_push(ctx, flags); + emit(ctx, SEXP_OP_MAKE_PROCEDURE); + } + sexp_gc_release2(ctx); +} + +static void generate (sexp ctx, sexp x) { + if (sexp_pointerp(x)) { + switch (sexp_pointer_tag(x)) { + case SEXP_PAIR: generate_app(ctx, x); break; + case SEXP_LAMBDA: generate_lambda(ctx, x); break; + case SEXP_CND: generate_cnd(ctx, x); break; + case SEXP_REF: generate_ref(ctx, x, 1); break; + case SEXP_SET: generate_set(ctx, x); break; + case SEXP_SEQ: generate_seq(ctx, sexp_seq_ls(x)); break; + case SEXP_LIT: generate_lit(ctx, sexp_lit_value(x)); break; + default: generate_lit(ctx, x); + } + } else { + generate_lit(ctx, x); + } +} + +static sexp make_param_list (sexp ctx, sexp_uint_t i) { + sexp_gc_var1(res); + sexp_gc_preserve1(ctx, res); + res = SEXP_NULL; + for ( ; i>0; i--) + res = sexp_cons(ctx, sexp_make_fixnum(i), res); + sexp_gc_release1(ctx); + return res; +} + +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); + 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)) { + return sexp_compile_error(ctx, "not enough args for opcode", op); + } 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); + params = make_param_list(ctx, i); + lambda = sexp_make_lambda(ctx, params); + ctx2 = sexp_make_child_context(ctx, lambda); + env = sexp_extend_env(ctx2, sexp_context_env(ctx), params, lambda); + sexp_context_env(ctx2) = env; + for (ls=params, refs=SEXP_NULL; sexp_pairp(ls); ls=sexp_cdr(ls)) { + ref = sexp_make_ref(ctx2, sexp_car(ls), sexp_env_cell(env, sexp_car(ls))); + sexp_push(ctx2, refs, ref); + } + refs = sexp_reverse(ctx2, refs); + refs = sexp_cons(ctx2, op, refs); + generate_opcode_app(ctx2, refs); + bc = finalize_bytecode(ctx2); + sexp_bytecode_name(bc) = sexp_c_string(ctx2, sexp_opcode_name(op), -1); + 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); + return res; +} + /*********************** the virtual machine **************************/ static sexp sexp_save_stack (sexp ctx, sexp *stack, sexp_uint_t to) { @@ -795,3 +1185,42 @@ sexp sexp_vm (sexp ctx, sexp proc) { return _ARG1; } +/******************************* apply ********************************/ + +static sexp sexp_apply1 (sexp ctx, sexp f, sexp x) { + sexp res; + sexp_gc_var1(args); + if (sexp_opcodep(f)) { + res = ((sexp_proc2)sexp_opcode_func(f))(ctx sexp_api_pass(f, 1), x); + } else { + sexp_gc_preserve1(ctx, args); + res = sexp_apply(ctx, f, args=sexp_list1(ctx, x)); + sexp_gc_release1(ctx); + } + return res; +} + +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; + len = sexp_unbox_fixnum(sexp_length(ctx, args)); + if (sexp_opcodep(proc)) + proc = make_opcode_procedure(ctx, proc, len); + if (! sexp_procedurep(proc)) { + res = sexp_exceptionp(proc) ? proc : + sexp_type_exception(ctx, NULL, SEXP_PROCEDURE, proc); + } else { + 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_ZERO; + stack[top++] = sexp_global(ctx, SEXP_G_FINAL_RESUMER); + stack[top++] = SEXP_ZERO; + sexp_context_top(ctx) = top; + res = sexp_vm(ctx, proc); + if (! res) res = SEXP_VOID; /* shouldn't happen */ + } + return res; +}