Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-07-08 13:37:35 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions 1

adding reserve opcode to avoid pushing dummy values.

Browse source 
also adding register-optimization! primitive.
This commit is contained in:
Alex Shinn 2011-06-13 20:52:42 +09:00
parent 97a12937f4
commit d7147bf67e
7 changed files with 42 additions and 13 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
eval.c
View file

@ -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

1
include/chibi/eval.h
View file

@ -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,

1
include/chibi/sexp.h
View file

@ -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))

1
lib/chibi/disasm.c
View file

@ -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;

1
opcodes.c
View file

@ -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),

2
opt/opcode_names.h
View file

@ -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",

41
vm.c
View file

@ -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;