Working towards more efficient treatment of non-bytecoded ensemble subcommands.

4 files changed, 141 insertions, 6 deletions

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 309682d..c052531 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -529,6 +529,11 @@ InstructionDesc const tclInstructionTable[] = {
 	/* Forces the variable indexed by opnd to be an array. Does not touch
 	 * the stack. */
 
+    {"invokeReplace",	 5,	INT_MIN,  1,	{OPERAND_UINT4}},
+	/* Invoke command named objv[0], replacing the first two words with
+	 * the word at the top of the stack;
+	 * <objc,objv> = <op4,top op4 after popping 1> */
+
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 3302f9b..4d8ed65 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -711,8 +711,10 @@ typedef struct ByteCode {
 #define INST_ARRAY_MAKE_STK		161
 #define INST_ARRAY_MAKE_IMM		162
 
+#define INST_INVOKE_REPLACE		163
+
 /* The last opcode */
-#define LAST_INST_OPCODE		162
+#define LAST_INST_OPCODE		163
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index b76c603..8f0d4fe 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -35,6 +35,14 @@ static void		MakeCachedEnsembleCommand(Tcl_Obj *objPtr,
 static void		FreeEnsembleCmdRep(Tcl_Obj *objPtr);
 static void		DupEnsembleCmdRep(Tcl_Obj *objPtr, Tcl_Obj *copyPtr);
 static void		StringOfEnsembleCmdRep(Tcl_Obj *objPtr);
+static int		CompileToCompiledCommand(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Tcl_Token *tokenPtr,
+			    int len, Tcl_Obj **elems, Command *cmdPtr,
+			    CompileEnv *envPtr);
+static int		CompileToInvokedCommand(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Tcl_Token *tokenPtr,
+			    int len, Tcl_Obj **elems, Command *cmdPtr,
+			    CompileEnv *envPtr);
 
 /*
  * The lists of subcommands and options for the [namespace ensemble] command.
@@ -2734,7 +2742,6 @@ TclCompileEnsemble(
     Tcl_Token *tokenPtr;
     Tcl_Obj *mapObj, *subcmdObj, *targetCmdObj, *listObj, **elems;
     Tcl_Command ensemble = (Tcl_Command) cmdPtr;
-    Tcl_Parse synthetic;
     int len, result, flags = 0, i;
     unsigned numBytes;
     const char *word;
@@ -2920,7 +2927,7 @@ TclCompileEnsemble(
     if (Tcl_ListObjGetElements(NULL, targetCmdObj, &len, &elems) != TCL_OK) {
 	return TCL_ERROR;
     }
-    if (len > 1 && Tcl_IsSafe(interp)) {
+    if (len > 1 || Tcl_IsSafe(interp)) {
 	return TCL_ERROR;
     }
     targetCmdObj = elems[0];
@@ -2928,7 +2935,7 @@ TclCompileEnsemble(
     Tcl_IncrRefCount(targetCmdObj);
     cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
     TclDecrRefCount(targetCmdObj);
-    if (cmdPtr == NULL || cmdPtr->compileProc == NULL
+    if (cmdPtr == NULL
 	    || cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
 	    || cmdPtr->flags * CMD_HAS_EXEC_TRACES
 	    || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
@@ -2942,10 +2949,39 @@ TclCompileEnsemble(
 
     /*
      * Now we've done the mapping process, can now actually try to compile.
-     * We do this by handing off to the subcommand's actual compiler. But to
-     * do that, we have to perform some trickery to rewrite the arguments.
+     * If there is a subcommand compiler and that successfully produces code,
+     * we'll use that. Otherwise, we fall back to generating opcodes to do the
+     * invoke at runtime.
      */
 
+    if (cmdPtr->compileProc != NULL &&
+	    CompileToCompiledCommand(interp, parsePtr, tokenPtr,
+		    len, elems, cmdPtr, envPtr) == TCL_OK) {
+	return TCL_OK;
+    }
+    return CompileToInvokedCommand(interp, parsePtr, tokenPtr,
+	    len, elems, cmdPtr, envPtr);
+}
+
+/*
+ * How to compile a subcommand using its own command compiler. To do that, we
+ * have to perform some trickery to rewrite the arguments, as compilers *must*
+ * have parse tokens that refer to addresses in the original script.
+ */
+
+static int
+CompileToCompiledCommand(
+    Tcl_Interp *interp,
+    Tcl_Parse *parsePtr,
+    Tcl_Token *tokenPtr,
+    int len,
+    Tcl_Obj **elems,
+    Command *cmdPtr,
+    CompileEnv *envPtr)		/* Holds resulting instructions. */
+{
+    Tcl_Parse synthetic;
+    int result, i;
+
     TclParseInit(interp, NULL, 0, &synthetic);
     synthetic.numWords = parsePtr->numWords - 2 + len;
     TclGrowParseTokenArray(&synthetic, 2*len);
@@ -3001,6 +3037,41 @@ TclCompileEnsemble(
     Tcl_FreeParse(&synthetic);
     return result;
 }
+
+static int
+CompileToInvokedCommand(
+    Tcl_Interp *interp,
+    Tcl_Parse *parsePtr,
+    Tcl_Token *tokenPtr,
+    int len,
+    Tcl_Obj **elems,
+    Command *cmdPtr,
+    CompileEnv *envPtr)		/* Holds resulting instructions. */
+{
+    Tcl_Obj *objPtr = Tcl_NewObj();
+    char *bytes;
+    int length, i, literal;
+
+    if (len != 1) {
+	return TCL_ERROR;
+    }
+
+    // TODO: Generate magic (with new instruction) for setting up the ensemble
+    // rewriting...
+
+    for (i=0,tokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) {
+	TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, envPtr);
+	tokenPtr = TokenAfter(tokenPtr);
+    }
+    Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr);
+    bytes = Tcl_GetStringFromObj(objPtr, &length);
+    literal = TclRegisterNewCmdLiteral(envPtr, bytes, length);
+    TclDecrRefCount(objPtr);
+    TclEmitPush(literal, envPtr);
+    TclEmitInstInt4(INST_INVOKE_REPLACE, parsePtr->numWords, envPtr);
+    TclAdjustStackDepth(-1, envPtr);
+    return TCL_OK;
+}
 
 /*
  * Local Variables:
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 2b5f713..3fab3cc 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2972,6 +2972,63 @@ TEBCresume(
 	Tcl_Panic("TclNRExecuteByteCode: obsolete INST_CALL_FUNC1 found");
 #endif
 
+    case INST_INVOKE_REPLACE:
+	objc = TclGetUInt4AtPtr(pc+1);
+	objPtr = POP_OBJECT();
+	objv = &OBJ_AT_DEPTH(objc-1);
+	cleanup = objc;
+#ifdef TCL_COMPILE_DEBUG
+	if (tclTraceExec >= 2) {
+	    int i;
+
+	    if (traceInstructions) {
+		strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+		TRACE(("%u => call (implementation %s) ",
+			objc, O2S(objPtr)));
+	    } else {
+		fprintf(stdout,
+			"%d: (%u) invoking (using implementation %s) ",
+			iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+			O2S(objPtr));
+	    }
+	    for (i = 0;  i < objc;  i++) {
+		TclPrintObject(stdout, objv[i], 15);
+		fprintf(stdout, " ");
+	    }
+	    fprintf(stdout, "\n");
+	    fflush(stdout);
+	}
+#endif /*TCL_COMPILE_DEBUG*/
+	{
+	    Tcl_Obj *copyPtr = Tcl_NewListObj(objc - 1, NULL);
+	    register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1;
+	    Tcl_Obj **copyObjv = &listRepPtr->elements;
+	    int i;
+
+	    listRepPtr->elemCount = objc - 1;
+	    copyObjv[0] = objPtr;
+	    memcpy(copyObjv+1, objv+2, sizeof(Tcl_Obj *) * (objc - 2));
+	    for (i=1 ; i<objc-1 ; i++) {
+		Tcl_IncrRefCount(copyObjv[i]);
+	    }
+	    objPtr = copyPtr;
+	}
+	bcFramePtr->data.tebc.pc = (char *) pc;
+	iPtr->cmdFramePtr = bcFramePtr;
+	if (iPtr->flags & INTERP_DEBUG_FRAME) {
+	    TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
+		    codePtr, bcFramePtr, pc - codePtr->codeStart);
+	}
+	iPtr->ensembleRewrite.sourceObjs = objv;
+	iPtr->ensembleRewrite.numRemovedObjs = 2;
+	iPtr->ensembleRewrite.numInsertedObjs = 1;
+	DECACHE_STACK_INFO();
+	pc += 5;
+	TEBC_YIELD();
+	TclNRAddCallback(interp, TclClearRootEnsemble, NULL,NULL,NULL,NULL);
+	iPtr->evalFlags |= TCL_EVAL_REDIRECT;
+	return TclNREvalObjEx(interp, objPtr, TCL_EVAL_INVOKE, NULL, INT_MIN);
+
     /*
      * -----------------------------------------------------------------
      *	   Start of INST_LOAD instructions.