adding reserve opcode to avoid pushing dummy values.

also adding register-optimization! primitive.

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

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,

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

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;

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

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

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,6 +230,7 @@ static void generate_opcode_app (sexp ctx, sexp app) {
     }
 
     /* push the arguments onto the stack in reverse order */
+    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)));
@@ -241,6 +242,7 @@ static void generate_opcode_app (sexp ctx, sexp app) {
           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))
+  k = sexp_unbox_fixnum(sexp_length(ctx, sexp_lambda_locals(lambda)));
-    emit_push(ctx2, SEXP_VOID);
+  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;