diff --git a/eval.c b/eval.c index b2f7d3aa..ba514e4c 100644 --- a/eval.c +++ b/eval.c @@ -1123,6 +1123,14 @@ sexp sexp_load_op (sexp ctx sexp_api_params(self, n), sexp source, sexp env) { return res; } +sexp sexp_register_optimization (sexp ctx sexp_api_params(self, n), sexp f, sexp priority) { + sexp_assert_type(ctx, sexp_applicablep, SEXP_PROCEDURE, f); + sexp_assert_type(ctx, sexp_fixnump, SEXP_FIXNUM, priority); + sexp_push(ctx, sexp_global(ctx, SEXP_G_OPTIMIZATIONS), SEXP_VOID); + sexp_car(sexp_global(ctx, SEXP_G_OPTIMIZATIONS)) = sexp_cons(ctx, priority, f); + return SEXP_VOID; +} + #if SEXP_USE_MATH #if SEXP_USE_BIGNUMS diff --git a/include/chibi/eval.h b/include/chibi/eval.h index 105798ae..c426a203 100644 --- a/include/chibi/eval.h +++ b/include/chibi/eval.h @@ -61,6 +61,7 @@ enum sexp_opcode_names { SEXP_OP_JUMP_UNLESS, SEXP_OP_JUMP, SEXP_OP_PUSH, + SEXP_OP_RESERVE, SEXP_OP_DROP, SEXP_OP_GLOBAL_REF, SEXP_OP_GLOBAL_KNOWN_REF, diff --git a/include/chibi/sexp.h b/include/chibi/sexp.h index a8a4e87e..65add36e 100755 --- a/include/chibi/sexp.h +++ b/include/chibi/sexp.h @@ -779,6 +779,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x); #define sexp_opcode_variadic_p(x) (sexp_opcode_flags(x) & 1) #define sexp_opcode_opt_param_p(x) (sexp_opcode_flags(x) & 2) #define sexp_opcode_ref_trans_p(x) (sexp_opcode_flags(x) & 4) +#define sexp_opcode_static_param_p(x) (sexp_opcode_flags(x) & 8) #define sexp_lambda_name(x) (sexp_field(x, lambda, SEXP_LAMBDA, name)) #define sexp_lambda_params(x) (sexp_field(x, lambda, SEXP_LAMBDA, params)) diff --git a/lib/chibi/disasm.c b/lib/chibi/disasm.c index f947790d..a9facc5d 100644 --- a/lib/chibi/disasm.c +++ b/lib/chibi/disasm.c @@ -76,6 +76,7 @@ static sexp disasm (sexp ctx, sexp self, sexp bc, sexp out, int depth) { case SEXP_OP_JUMP: case SEXP_OP_JUMP_UNLESS: case SEXP_OP_TYPEP: + case SEXP_OP_RESERVE: sexp_write_integer(ctx, ((sexp_sint_t*)ip)[0], out); ip += sizeof(sexp); break; diff --git a/opcodes.c b/opcodes.c index 5dfcd77b..80598f17 100644 --- a/opcodes.c +++ b/opcodes.c @@ -134,6 +134,7 @@ _FN1(_I(SEXP_OBJECT), _I(SEXP_OBJECT), "strip-syntactic-closures", 0, sexp_strip _FN0(_I(SEXP_OPORT), "open-output-string", 0, sexp_make_output_string_port_op), _FN1(_I(SEXP_IPORT), _I(SEXP_STRING), "open-input-string", 0, sexp_make_input_string_port_op), _FN1(_I(SEXP_STRING), _I(SEXP_OPORT), "get-output-string", 0, sexp_get_output_string_op), +_FN2OPT(_I(SEXP_OBJECT), _I(SEXP_PROCEDURE), _I(SEXP_FIXNUM), "register-optimization!", _I(600), sexp_register_optimization), #if SEXP_USE_MATH _FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "exp", 0, sexp_exp), _FN1(_I(SEXP_NUMBER), _I(SEXP_NUMBER), "log", 0, sexp_log), diff --git a/opt/opcode_names.h b/opt/opcode_names.h index b9a966cd..29bcbe04 100644 --- a/opt/opcode_names.h +++ b/opt/opcode_names.h @@ -2,7 +2,7 @@ static const char* reverse_opcode_names[] = {"NOOP", "RAISE", "RESUMECC", "CALLCC", "APPLY1", "TAIL-CALL", "CALL", "FCALL0", "FCALL1", "FCALL2", "FCALL3", "FCALL4", "FCALLN", - "JUMP-UNLESS", "JUMP", "PUSH", "DROP", + "JUMP-UNLESS", "JUMP", "PUSH", "RESERVE", "DROP", "GLOBAL-REF", "GLOBAL-KNOWN-REF", "PARAMETER-REF", "STACK-REF", "LOCAL-REF", "LOCAL-SET", "CLOSURE-REF", "VECTOR-REF", "VECTOR-SET", "VECTOR-LENGTH", diff --git a/vm.c b/vm.c index bf3dd2f1..7e52fe39 100644 --- a/vm.c +++ b/vm.c @@ -1,5 +1,5 @@ /* vm.c -- stack-based virtual machine backend */ -/* Copyright (c) 2009-2010 Alex Shinn. All rights reserved. */ +/* Copyright (c) 2009-2011 Alex Shinn. All rights reserved. */ /* BSD-style license: http://synthcode.com/license.txt */ #if SEXP_USE_DEBUG_VM > 1 @@ -230,16 +230,18 @@ static void generate_opcode_app (sexp ctx, sexp app) { } /* 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)); + if (!sexp_opcode_static_param_p(op)) { + 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)); #if SEXP_USE_AUTO_FORCE - if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) - || sexp_opcode_code(op) == SEXP_OP_MAKE_VECTOR) - emit(ctx, SEXP_OP_FORCE); + if ((sexp_opcode_class(op) != SEXP_OPC_CONSTRUCTOR) + || sexp_opcode_code(op) == SEXP_OP_MAKE_VECTOR) + emit(ctx, SEXP_OP_FORCE); #endif + } } } @@ -322,6 +324,12 @@ static void generate_opcode_app (sexp ctx, sexp app) { emit(ctx, sexp_opcode_code(op)); } + if (sexp_opcode_static_param_p(op)) + for (ls=sexp_cdr(app); sexp_pairp(ls); ls=sexp_cdr(ls)) + emit_word(ctx, sexp_unbox_fixnum(sexp_litp(sexp_car(ls)) ? + sexp_lit_value(sexp_car(ls)) : + sexp_car(ls))); + sexp_context_depth(ctx) -= (num_args-1); sexp_gc_release1(ctx); } @@ -367,8 +375,11 @@ static void generate_lambda (sexp ctx, sexp lambda) { ctx2 = sexp_make_eval_context(ctx, sexp_context_stack(ctx), sexp_context_env(ctx), 0, 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); + k = sexp_unbox_fixnum(sexp_length(ctx, sexp_lambda_locals(lambda))); + if (k > 0) { + emit(ctx2, SEXP_OP_RESERVE); + emit_word(ctx2, k); + } /* box mutable vars */ for (ls=sexp_lambda_sv(lambda); sexp_pairp(ls); ls=sexp_cdr(ls)) { k = sexp_param_index(lambda, sexp_car(ls)); @@ -804,7 +815,8 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { } else { sexp_raise("too many args", sexp_list2(ctx, tmp1, sexp_make_fixnum(i))); } - } else if (sexp_procedure_variadic_p(tmp1)) { + } else if (sexp_procedure_variadic_p(tmp1) && + !sexp_procedure_unused_rest_p(tmp1)) { /* shift stack, set extra arg to null */ for (k=top; k>=top-i; k--) stack[k] = stack[k-1]; @@ -879,6 +891,11 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) { _PUSH(_WORD0); ip += sizeof(sexp); break; + case SEXP_OP_RESERVE: + _ALIGN_IP(); + top += _SWORD0; + ip += sizeof(sexp); + break; case SEXP_OP_DROP: top--; break;