commit a112728e08b7ec114dc60107db994bd3e27cc4c6 (HEAD, refs/heads/tco-2)
Author: Chris Gray <chrismgray@gmail.com>
Date:   Mon Dec 10 18:37:08 2012 -0800

    Change bytecode interpreter to allow for tail-call elimination in some cases

	Modified src/bytecode.c
diff --git a/src/bytecode.c b/src/bytecode.c
index 4c5ac15..9544090 100644
--- a/src/bytecode.c
+++ b/src/bytecode.c
@@ -45,6 +45,8 @@ by Hallvard:
 #include "xterm.h"
 #endif
 
+Lisp_Object Ffetch_bytecode (Lisp_Object);
+
 /*
  * define BYTE_CODE_SAFE to enable some minor sanity checking (useful for
  * debugging the byte compiler...)
@@ -481,8 +483,8 @@ If the third argument is incorrect, Emacs may crash.  */)
    executing BYTESTR.  */
 
 Lisp_Object
-exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
-		Lisp_Object args_template, ptrdiff_t nargs, Lisp_Object *args)
+exec_byte_code (volatile Lisp_Object bytestr, volatile Lisp_Object vector, volatile Lisp_Object maxdepth,
+		volatile Lisp_Object args_template, volatile ptrdiff_t nargs, Lisp_Object *args)
 {
   ptrdiff_t count = SPECPDL_INDEX ();
 #ifdef BYTE_CODE_METER
@@ -498,8 +500,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
   ptrdiff_t bytestr_length;
 #endif
   struct byte_stack stack;
-  Lisp_Object *top;
+  Lisp_Object *top = NULL;
+  Lisp_Object *bottom = NULL;
   Lisp_Object result;
+  jmp_buf env;
+  volatile Lisp_Object *funargs;
 
 #if 0 /* CHECK_FRAME_FONT */
  {
@@ -511,9 +516,23 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
  }
 #endif
 
+ funargs = xmalloc (nargs * sizeof(Lisp_Object));
+ funargs = *(volatile Lisp_Object *) &funargs;
+  {
+    int i;
+    for (i = 0; i < nargs; i++)
+      {
+        funargs[i] = args[i];
+      }
+  }
+  stack.next = byte_stack_list;
+  byte_stack_list = &stack;
+
+  setjmp(env);
   CHECK_STRING (bytestr);
   CHECK_VECTOR (vector);
   CHECK_NATNUM (maxdepth);
+  args = funargs;
 
 #ifdef BYTE_CODE_SAFE
   const_length = ASIZE (vector);
@@ -538,12 +557,11 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
   if (MAX_ALLOCA / word_size <= XFASTINT (maxdepth))
     memory_full (SIZE_MAX);
   top = alloca ((XFASTINT (maxdepth) + 1) * sizeof *top);
+
 #if BYTE_MAINTAIN_TOP
   stack.bottom = top + 1;
   stack.top = NULL;
 #endif
-  stack.next = byte_stack_list;
-  byte_stack_list = &stack;
 
 #ifdef BYTE_CODE_SAFE
   stacke = stack.bottom - 1 + XFASTINT (maxdepth);
@@ -595,6 +613,8 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
       error ("Unknown args template!");
     }
 
+  xfree (funargs);
+
   while (1)
     {
 #ifdef BYTE_CODE_SAFE
@@ -894,6 +914,42 @@ exec_byte_code (Lisp_Object bytestr, Lisp_Object vector, Lisp_Object maxdepth,
 		  }
 	      }
 #endif
+            /* If the next op is return, maybe we can eliminate the tail call */
+            if (*stack.pc == Breturn)
+              {
+                Lisp_Object fun, original_fun, syms_left;
+                fun = original_fun = TOP;
+                
+                if (SYMBOLP (fun) && !EQ (fun, Qunbound)
+                    && (fun = XSYMBOL (fun)->function, SYMBOLP (fun)))
+                  fun = indirect_function (fun);
+                if (COMPILEDP(fun))
+                  {
+                    syms_left = AREF (fun, COMPILED_ARGLIST);
+                    if (INTEGERP (syms_left))
+                      {
+                        int i;
+                        volatile Lisp_Object *funargs2;
+                        if (CONSP (AREF (fun, COMPILED_BYTECODE)))
+                          Ffetch_bytecode (fun);
+                        bytestr = AREF (fun, COMPILED_BYTECODE);
+                        vector = AREF (fun, COMPILED_CONSTANTS);
+                        maxdepth = AREF (fun, COMPILED_STACK_DEPTH);
+                        args_template = syms_left;
+                        nargs = op;
+                        funargs2 = xmalloc (nargs * sizeof(Lisp_Object));
+                        funargs = *(volatile Lisp_Object *) &funargs2;
+                        for (i = 0; i < nargs; i++) {
+                          funargs[i] = top[i + 1];
+                        }
+                        /* uses setjmp/longjmp rather than goto so that the emacs-lisp stack
+                           can be allocated on the CPU stack.  This is what the garbage collector
+                           assumes, so it is preferable to changing the garbage collector.
+                        */
+                        longjmp(env, 1);
+                      }
+                  }
+              }
 	    TOP = Ffuncall (op + 1, &TOP);
 	    AFTER_POTENTIAL_GC ();
 	    NEXT;
	Modified src/lisp.h
diff --git a/src/lisp.h b/src/lisp.h
index 5acb37f..2bb8e39 100644
--- a/src/lisp.h
+++ b/src/lisp.h
@@ -3401,8 +3401,8 @@ extern struct byte_stack *byte_stack_list;
 extern void mark_byte_stack (void);
 #endif
 extern void unmark_byte_stack (void);
-extern Lisp_Object exec_byte_code (Lisp_Object, Lisp_Object, Lisp_Object,
-				   Lisp_Object, ptrdiff_t, Lisp_Object *);
+extern Lisp_Object exec_byte_code (volatile Lisp_Object, volatile Lisp_Object, volatile Lisp_Object,
+				   volatile Lisp_Object, volatile ptrdiff_t, Lisp_Object *);
 
 /* Defined in macros.c.  */
 extern Lisp_Object Qexecute_kbd_macro;

