apply opcode is now tail-recursive - calling it in a non-tail position is an error

eval.c

@@ -33,7 +33,7 @@ sexp sexp_compile_error (sexp ctx, const char *message, sexp o) {
   return exn;
 }
 
-static void sexp_warn (sexp ctx, char *msg, sexp x) {
+void sexp_warn (sexp ctx, char *msg, sexp x) {
   sexp out = sexp_current_error_port(ctx);
   if (sexp_oportp(out)) {
     sexp_write_string(ctx, "WARNING: ", out);

include/chibi/eval.h

@@ -54,6 +54,7 @@ SEXP_API const char** sexp_opcode_names;
 
 /**************************** prototypes ******************************/
 
+SEXP_API void sexp_warn (sexp ctx, char *msg, sexp x);
 SEXP_API void sexp_scheme_init (void);
 SEXP_API sexp sexp_make_eval_context (sexp context, sexp stack, sexp env, sexp_uint_t size, sexp_uint_t max_size);
 SEXP_API sexp sexp_make_child_context (sexp context, sexp lambda);

include/chibi/sexp.h

@@ -972,6 +972,7 @@ SEXP_API sexp sexp_make_unsigned_integer(sexp ctx, sexp_luint_t x);
 #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_opcode_tail_call_p(x) (sexp_opcode_flags(x) & 16)
 
 #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/init-7.scm

@@ -57,7 +57,7 @@
     (if (every pair? lol)
         (mapn proc
               (map1 cdr lol '())
-              (cons (apply1 proc (map1 car lol '())) res))
+              (cons (apply proc (map1 car lol '())) res))
         (reverse res)))
   (if (null? lol)
       (map1 proc ls '())

opcodes.c

@@ -128,7 +128,7 @@ _OP(SEXP_OPC_TYPE_PREDICATE, SEXP_OP_TYPEP,  1, 0, _I(SEXP_BOOLEAN), _I(SEXP_OBJ
 _FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "output-port?", 0, sexp_port_outputp_op),
 _FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "binary-port?", 0, sexp_port_binaryp_op),
 _FN1(_I(SEXP_BOOLEAN), _I(SEXP_IPORT), "port-open?", 0, sexp_port_openp_op),
-_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL),
+_OP(SEXP_OPC_GENERIC, SEXP_OP_APPLY1, 2, 16, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_NULL, SEXP_FALSE, 0, "apply1", 0, NULL),
 _OP(SEXP_OPC_GENERIC, SEXP_OP_CALLCC, 1, 0, _I(SEXP_OBJECT), _I(SEXP_PROCEDURE), SEXP_FALSE, SEXP_FALSE, 0, "%call/cc", 0, NULL),
 _OP(SEXP_OPC_GENERIC, SEXP_OP_RAISE, 1, 0, _I(SEXP_OBJECT), _I(SEXP_OBJECT), SEXP_FALSE, SEXP_FALSE, 0, "raise", 0, NULL),
 #if SEXP_USE_NATIVE_X86

vm.c

@@ -290,6 +290,12 @@ static void generate_opcode_app (sexp ctx, sexp app) {
   sexp_gc_var1(ls);
   sexp_gc_preserve1(ctx, ls);
 
+  if (sexp_opcode_tail_call_p(op) && !sexp_context_tailp(ctx)) {
+    sexp_warn(ctx, "tail-call only opcode in non-tail position: ", app);
+    generate_lit(ctx, SEXP_VOID);
+    return;
+  }
+
   num_args = sexp_unbox_fixnum(sexp_length(ctx, sexp_cdr(app)));
   sexp_context_tailp(ctx) = 0;
 
@@ -951,9 +957,14 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
   self = sexp_global(ctx, SEXP_G_FINAL_RESUMER);
   bc = sexp_procedure_code(self);
   cp = sexp_procedure_vars(self);
-  ip = sexp_bytecode_data(bc);
+  ip = sexp_bytecode_data(bc) - sizeof(sexp);
   tmp1 = proc, tmp2 = args;
-  goto apply1;
+  i = sexp_unbox_fixnum(sexp_length(ctx, tmp2));
+  sexp_ensure_stack(i + 64 + sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0);
+  for (top += i; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
+    _ARG1 = sexp_car(tmp2);
+  top += i+1;
+  goto make_call;
 
  loop:
 #if SEXP_USE_GREEN_THREADS
@@ -1066,23 +1077,27 @@ sexp sexp_apply (sexp ctx, sexp proc, sexp args) {
   case SEXP_OP_APPLY1:
     tmp1 = _ARG1;
     tmp2 = _ARG2;
-    top -= 2;
   apply1:
-    i = sexp_unbox_fixnum(sexp_length(ctx, tmp2));
+    i = sexp_unbox_fixnum(sexp_length(ctx, tmp2)); /* number of params */
     sexp_ensure_stack(i + 64 + sexp_procedurep(tmp1) ? sexp_bytecode_max_depth(sexp_procedure_code(tmp1)) : 0);
-    top += i;
+    k = sexp_unbox_fixnum(stack[fp+3]);            /* previous fp */
-    for ( ; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
+    j = sexp_unbox_fixnum(stack[fp]);              /* previous num params */
-      _ARG1 = sexp_car(tmp2);
+    self = stack[fp+2];
-    top += i+1;
+    bc = sexp_procedure_code(self);
-    ip -= sizeof(sexp);
+    cp = sexp_procedure_vars(self);
+    ip = (sexp_bytecode_data(bc)+sexp_unbox_fixnum(stack[fp+1])) - sizeof(sexp);
+    for (top=fp-j+i-1; sexp_pairp(tmp2); tmp2=sexp_cdr(tmp2), top--)
+      stack[top] = sexp_car(tmp2);
+    top = fp+i-j+1;
+    fp = k;
     goto make_call;
   case SEXP_OP_TAIL_CALL:
     _ALIGN_IP();
     i = sexp_unbox_fixnum(_WORD0);             /* number of params */
     tmp1 = _ARG1;                              /* procedure to call */
     /* save frame info */
-    tmp2 = stack[fp+3];
+    tmp2 = stack[fp+3];                        /* previous fp */
-    j = sexp_unbox_fixnum(stack[fp]);
+    j = sexp_unbox_fixnum(stack[fp]);          /* previous num params */
     self = stack[fp+2];
     bc = sexp_procedure_code(self);
     cp = sexp_procedure_vars(self);