tailcall: Fix to avoid tailcalls consuming C stack frames

The purpose of a tailcall is to avoid using additional stack frames,
however although were were not creating an extra Tcl callframe we were
using C stack frames through the call sequence:

	JimCallProcedure -> Jim_EvalObjList -> JimInvokeCommand -> JimCallProcedure

This meant that a large number of tailcalls would overflow the stack.
Instead we need to have JimCallProcedure return to JimInvokeCommand
where the tailcall can be handled by a subsequent call to JimCallProcedure.

Signed-off-by: Steve Bennett <steveb@workware.net.au>

3 files changed, 75 insertions, 53 deletions

diff --git a/jim.c b/jim.c
index 31ff2bf..668f43c 100644
--- a/jim.c
+++ b/jim.c
@@ -10080,6 +10080,7 @@ static int JimInvokeCommand(Jim_Interp *interp, int objc, Jim_Obj *const *objv)
     int retcode;
     Jim_Cmd *cmdPtr;
     void *prevPrivData;
+    Jim_Obj *tailcallObj = NULL;
 
 #if 0
     printf("invoke");
@@ -10090,18 +10091,11 @@ static int JimInvokeCommand(Jim_Interp *interp, int objc, Jim_Obj *const *objv)
     printf("\n");
 #endif
 
-    if (interp->framePtr->tailcallCmd) {
-        /* Special tailcall command was pre-resolved */
-        cmdPtr = interp->framePtr->tailcallCmd;
-        interp->framePtr->tailcallCmd = NULL;
-    }
-    else {
-        cmdPtr = Jim_GetCommand(interp, objv[0], JIM_ERRMSG);
-        if (cmdPtr == NULL) {
-            return JimUnknown(interp, objc, objv);
-        }
-        JimIncrCmdRefCount(cmdPtr);
+    cmdPtr = Jim_GetCommand(interp, objv[0], JIM_ERRMSG);
+    if (cmdPtr == NULL) {
+        return JimUnknown(interp, objc, objv);
     }
+    JimIncrCmdRefCount(cmdPtr);
 
     if (interp->evalDepth == interp->maxEvalDepth) {
         Jim_SetResultString(interp, "Infinite eval recursion", -1);
@@ -10111,21 +10105,72 @@ static int JimInvokeCommand(Jim_Interp *interp, int objc, Jim_Obj *const *objv)
     interp->evalDepth++;
     prevPrivData = interp->cmdPrivData;
 
+tailcall:
+
     /* Call it -- Make sure result is an empty object. */
     Jim_SetEmptyResult(interp);
     if (cmdPtr->isproc) {
         retcode = JimCallProcedure(interp, cmdPtr, objc, objv);
+
+        /* Handle the JIM_RETURN return code */
+        if (retcode == JIM_RETURN) {
+            if (--interp->returnLevel <= 0) {
+                retcode = interp->returnCode;
+                interp->returnCode = JIM_OK;
+                interp->returnLevel = 0;
+            }
+        }
+        else if (retcode == JIM_ERR) {
+            interp->addStackTrace++;
+            Jim_DecrRefCount(interp, interp->errorProc);
+            interp->errorProc = objv[0];
+            Jim_IncrRefCount(interp->errorProc);
+        }
     }
     else {
         interp->cmdPrivData = cmdPtr->u.native.privData;
         retcode = cmdPtr->u.native.cmdProc(interp, objc, objv);
     }
+
+    if (tailcallObj) {
+        /* clean up previous tailcall if we were invoking one */
+        Jim_DecrRefCount(interp, tailcallObj);
+        tailcallObj = NULL;
+    }
+
+    /* If a tailcall is returned for this frame, loop to invoke the new command */
+    if (retcode == JIM_EVAL && interp->framePtr->tailcallObj) {
+        JimDecrCmdRefCount(interp, cmdPtr);
+
+        /* Replace the current command with the new tailcall command */
+        cmdPtr = interp->framePtr->tailcallCmd;
+        interp->framePtr->tailcallCmd = NULL;
+        tailcallObj = interp->framePtr->tailcallObj;
+        interp->framePtr->tailcallObj = NULL;
+        /* We can access the internal rep here because the object can only
+         * be constructed by the tailcall command
+         */
+        objc = tailcallObj->internalRep.listValue.len;
+        objv = tailcallObj->internalRep.listValue.ele;
+        goto tailcall;
+    }
+
     interp->cmdPrivData = prevPrivData;
     interp->evalDepth--;
 
 out:
     JimDecrCmdRefCount(interp, cmdPtr);
 
+    if (interp->framePtr->tailcallObj) {
+        /* We might have skipped invoking a tailcall, perhaps because of an error
+         * in defer handling so cleanup now
+         */
+        JimDecrCmdRefCount(interp, interp->framePtr->tailcallCmd);
+        Jim_DecrRefCount(interp, interp->framePtr->tailcallObj);
+        interp->framePtr->tailcallCmd = NULL;
+        interp->framePtr->tailcallObj = NULL;
+    }
+
     return retcode;
 }
 
@@ -10829,47 +10874,6 @@ badargset:
     interp->framePtr = interp->framePtr->parent;
     JimFreeCallFrame(interp, callFramePtr, JIM_FCF_REUSE);
 
-    /* Now chain any tailcalls in the parent frame */
-    if (interp->framePtr->tailcallObj) {
-        do {
-            Jim_Obj *tailcallObj = interp->framePtr->tailcallObj;
-
-            interp->framePtr->tailcallObj = NULL;
-
-            if (retcode == JIM_EVAL) {
-                retcode = Jim_EvalObjList(interp, tailcallObj);
-                if (retcode == JIM_RETURN) {
-                    /* If the result of the tailcall is 'return', push
-                     * it up to the caller
-                     */
-                    interp->returnLevel++;
-                }
-            }
-            Jim_DecrRefCount(interp, tailcallObj);
-        } while (interp->framePtr->tailcallObj);
-
-        /* If the tailcall chain finished early, may need to manually discard the command */
-        if (interp->framePtr->tailcallCmd) {
-            JimDecrCmdRefCount(interp, interp->framePtr->tailcallCmd);
-            interp->framePtr->tailcallCmd = NULL;
-        }
-    }
-
-    /* Handle the JIM_RETURN return code */
-    if (retcode == JIM_RETURN) {
-        if (--interp->returnLevel <= 0) {
-            retcode = interp->returnCode;
-            interp->returnCode = JIM_OK;
-            interp->returnLevel = 0;
-        }
-    }
-    else if (retcode == JIM_ERR) {
-        interp->addStackTrace++;
-        Jim_DecrRefCount(interp, interp->errorProc);
-        interp->errorProc = argv[0];
-        Jim_IncrRefCount(interp->errorProc);
-    }
-
     return retcode;
 }
 
diff --git a/tests/apply.test b/tests/apply.test
index abf6438..504b4ae 100644
--- a/tests/apply.test
+++ b/tests/apply.test
@@ -127,6 +127,24 @@ test apply-8.10 {default values} {
     apply [list {x {y 2} args} $applyBody] 1 3
 } {{args {}} {x 1} {y 3}}
 
+test apply-9.1 {tailcall within apply} {
+    proc p {y frame} {
+        list [expr {$y * 2}] [expr {$frame - [info frame]}]
+    }
+    apply {{x} {
+        tailcall p $x [info frame]
+        notreached
+    }} {4}
+} {8 0}
+test apply-9.2 {return from apply} {
+    apply {{x} {
+        return [expr {$x + 1}]
+    }} {4}
+} {5}
+
+
+rename p {}
+
 ::tcltest::cleanupTests
 return
 
diff --git a/tests/tailcall.test b/tests/tailcall.test
index eaa48cc..b2dc70a 100644
--- a/tests/tailcall.test
+++ b/tests/tailcall.test
@@ -87,7 +87,7 @@ test tailcall-1.9 {tailcall with large number of invocations} {
 		incr n -1
 		tailcall a $n
 	}
-	a 1000
+	a 100000
 } 1
 
 test tailcall-1.10 {tailcall through uplevel} {