From ec57daaf5fdd3aec86354f0d66eb379bc44919a1 Mon Sep 17 00:00:00 2001
From: Alex Shinn <ashinn@users.noreply.github.com>
Date: Tue, 10 Mar 2009 23:07:14 +0900
Subject: [PATCH] initial tail-call optimization support

---
 debug.c |  9 ++++++++-
 eval.c  | 53 ++++++++++++++++++++++++++++++++++++++++++-----------
 eval.h  |  1 +
 sexp.c  |  4 ++--
 4 files changed, 53 insertions(+), 14 deletions(-)

diff --git a/debug.c b/debug.c
index 831a9834..882c64ed 100644
--- a/debug.c
+++ b/debug.c
@@ -3,7 +3,8 @@
 /*  BSD-style license: http://synthcode.com/license.txt  */
 
 static const char* reverse_opcode_names[] =
-  {"NOOP", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR", "FCALL0", "FCALL1",
+  {"NOOP", "TAIL-CALL", "CALL", "APPLY1", "CALLCC", "RESUMECC", "ERROR",
+   "FCALL0", "FCALL1",
    "FCALL2", "FCALL3", "FCALL4", "FCALL5", "FCALL6", "FCALL7", "FCALLN",
    "JUMP-UNLESS", "JUMP", "RET", "DONE", "PARAMETER",
    "STACK-REF", "STACK-SET", "GLOBAL-REF", "GLOBAL-SET", "CLOSURE-REF",
@@ -35,10 +36,16 @@ void disasm (bytecode bc) {
     break;
   case OP_GLOBAL_REF:
   case OP_GLOBAL_SET:
+  case OP_TAIL_CALL:
   case OP_CALL:
   case OP_PUSH:
     sexp_write(((sexp*)ip)[0], cur_error_port);
     ip += sizeof(sexp);
+    if (opcode==OP_TAIL_CALL) {
+      fprintf(stderr, " ");
+      sexp_write(((sexp*)ip)[0], cur_error_port);
+      ip += sizeof(sexp);
+    }
     break;
   case OP_JUMP:
   case OP_JUMP_UNLESS:
diff --git a/eval.c b/eval.c
index 695b8641..6f46353c 100644
--- a/eval.c
+++ b/eval.c
@@ -344,12 +344,19 @@ void analyze_app (sexp obj, bytecode *bc, unsigned int *i, env e,
   analyze(SEXP_CAR(obj), bc, i, e, params, fv, sv, d, 0);
 
   /* maybe overwrite the current frame */
-/*   if (tailp) { */
-/*   } */
-
-  /* make the call */
-  emit(bc, i, OP_CALL);
-  emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len));
+  if (tailp) {
+    /* args ... */
+    /* i  */
+    /* ip */
+    /* cp */
+    emit(bc, i, OP_TAIL_CALL);
+    emit_word(bc, i, (sexp_uint_t) sexp_make_integer(sexp_length(params)+(*d)));
+    emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len));
+  } else {
+    /* normal call */
+    emit(bc, i, OP_CALL);
+    emit_word(bc, i, (sexp_uint_t) sexp_make_integer(len));
+  }
 }
 
 sexp free_vars (env e, sexp formals, sexp obj, sexp fv) {
@@ -465,10 +472,10 @@ bytecode compile(sexp params, sexp obj, env e, sexp fv, sexp sv, int done_p) {
     if (SEXP_PAIRP(SEXP_CDR(obj))) {
       analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 0);
       emit(&bc, &i, OP_DROP);
-    } else
-      analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, 1);
+    } else {
+      analyze(SEXP_CAR(obj), &bc, &i, e, params, fv, sv, &d, ! done_p);
+    }
   }
-  /* return */
   emit(&bc, &i, done_p ? OP_DONE : OP_RET);
   shrink_bcode(&bc, i);
   print_bytecode(bc);
@@ -670,11 +677,35 @@ sexp vm(bytecode bc, env e, sexp* stack, unsigned int top) {
     stack[top-2]=((stack[top-1] == stack[top-2]) ? SEXP_TRUE : SEXP_FALSE);
     top--;
     break;
+  case OP_TAIL_CALL:
+    j = sexp_unbox_integer(((sexp*)ip)[0]);    /* current depth */
+    ip += sizeof(sexp);
+    i = sexp_unbox_integer(((sexp*)ip)[0]);    /* number of params */
+    tmp1 = stack[top-1];                       /* procedure to call */
+/*     fprintf(stderr, "tail call: depth=%d, i=%d, top=%d\n", j, i, top); */
+/*     print_stack(stack, top); */
+    /* save frame info */
+    stack[top] = stack[top-i-j];
+    stack[top+1] = stack[top-i-j+1];
+    /* copy new args into place */
+    for (k=top-i-1; k<top-1; k++)
+      stack[k-j-i] = stack[k];
+    /* restore frame info */
+    stack[top-j-i] = stack[top];
+    stack[top-j-i+1] = stack[top+1];
+    top -= (j-i);
+/*     print_stack(stack, top); */
+/*     exit(0); */
+    bc = sexp_procedure_code(tmp1);
+    ip = bc->data;
+    cp = sexp_procedure_vars(tmp1);
+    break;
   case OP_CALL:
+    if (top >= INIT_STACK_SIZE)
+      errx(1, "out of stack space: %d", top);
     /* fprintf(stderr, "CALL\n"); */
     /* print_stack(stack, top); */
-    i = (sexp_uint_t) ((sexp*)ip)[0];
-    i = sexp_unbox_integer(i);
+    i = sexp_unbox_integer(((sexp*)ip)[0]);
     tmp1 = stack[top-1];
     if (! SEXP_PROCEDUREP(tmp1)) {
       fprintf(stderr, "error: non-procedure app\n");
diff --git a/eval.h b/eval.h
index 8ba456ce..a349ff44 100644
--- a/eval.h
+++ b/eval.h
@@ -91,6 +91,7 @@ enum opcode_classes {
 
 enum opcode_names {
   OP_NOOP,
+  OP_TAIL_CALL,
   OP_CALL,
   OP_APPLY1,
   OP_CALLCC,
diff --git a/sexp.c b/sexp.c
index 0a33c04e..ebf3d620 100644
--- a/sexp.c
+++ b/sexp.c
@@ -419,7 +419,7 @@ void sexp_write (sexp obj, sexp out) {
       sexp_write_char('"', out);
       i = sexp_string_length(obj);
       str = sexp_string_data(obj);
-      /* FALLTHROUGH */
+      /* ... FALLTHROUGH ... */
     case SEXP_SYMBOL:
       if (obj->tag != SEXP_STRING) {
         i = sexp_symbol_length(obj);
@@ -584,7 +584,7 @@ sexp sexp_read_raw (sexp in) {
     while ((c1 = sexp_read_char(in)) != EOF)
       if (c1 == '\n')
         break;
-    /* fallthrough */
+    /* ... FALLTHROUGH ... */
   case ' ':
   case '\t':
   case '\n':