Compile [namespace which -command]; big performance saving in some contexts.

7 files changed, 71 insertions, 4 deletions

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 132ee68..27720c7 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -461,6 +461,7 @@ static const TalInstDesc TalInstructionTable[] = {
 								0,	1},
     {"pushResult",	ASSEM_1BYTE,	INST_PUSH_RESULT,	0,	1},
     {"regexp",		ASSEM_REGEXP,	INST_REGEXP,		2,	1},
+    {"resolveCmd",	ASSEM_1BYTE,	INST_RESOLVE_COMMAND,	1,	1},
     {"reverse",		ASSEM_REVERSE,	INST_REVERSE,		INT_MIN,-1-0},
     {"rshift",		ASSEM_1BYTE,	INST_RSHIFT,		2,	1},
     {"store",		ASSEM_LVT,	(INST_STORE_SCALAR1<<8
@@ -507,7 +508,8 @@ static const unsigned char NonThrowingByteCodes[] = {
     INST_NOP,							/* 132 */
     INST_NS_CURRENT,						/* 141 */
     INST_COROUTINE_NAME,					/* 142 */
-    INST_INFO_LEVEL_NUM						/* 143 */
+    INST_INFO_LEVEL_NUM,					/* 143 */
+    INST_RESOLVE_COMMAND					/* 145 */
 };
 
 /*
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 66bc5f0..245779e 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -4151,6 +4151,52 @@ TclCompileNamespaceUpvarCmd(
     PushLiteral(envPtr, "", 0);
     return TCL_OK;
 }
+
+int
+TclCompileNamespaceWhichCmd(
+    Tcl_Interp *interp,		/* Used for error reporting. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
+				 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds resulting instructions. */
+{
+    DefineLineInformation;	/* TIP #280 */
+    Tcl_Token *tokenPtr, *opt;
+    int idx;
+
+    if (parsePtr->numWords < 2 || parsePtr->numWords > 3) {
+	return TCL_ERROR;
+    }
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
+    idx = 1;
+
+    /*
+     * If there's an option, check that it's "-command". We don't handle
+     * "-variable" (currently) and anything else is an error.
+     */
+
+    if (parsePtr->numWords == 3) {
+	if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+	    return TCL_ERROR;
+	}
+	opt = tokenPtr + 1;
+	if (opt->size < 2 || opt->size > 8
+		|| strncmp(opt->start, "-command", opt->size) != 0) {
+	    return TCL_ERROR;
+	}
+	tokenPtr = TokenAfter(tokenPtr);
+	idx++;
+    }
+
+    /*
+     * Issue the bytecode.
+     */
+
+    CompileWord(envPtr,		tokenPtr,		interp, idx);
+    TclEmitOpcode(		INST_RESOLVE_COMMAND,	envPtr);
+    return TCL_OK;
+}
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 3ee0fdf..b331551 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -448,6 +448,11 @@ InstructionDesc const tclInstructionTable[] = {
 	/* Push the argument words to a stack depth (i.e., [info level <n>])
 	 * of the interpreter as an object on the stack.
 	 * Stack:  ... depth => ... argList */
+    {"resolveCmd",	 1,	0,	  0,	{OPERAND_NONE}},
+	/* Resolves the command named on the top of the stack to its fully
+	 * qualified version, or produces the empty string if no such command
+	 * exists. Never generates errors.
+	 * Stack:  ... cmdName => ... fullCmdName */
     {"tclooSelf",	 1,	+1,	  0,	{OPERAND_NONE}},
 	/* Push the identity of the current TclOO object (i.e., the name of
 	 * its current public access command) on the stack. */
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 044bef9..86a0f77 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -686,10 +686,11 @@ typedef struct ByteCode {
 #define INST_COROUTINE_NAME		142
 #define INST_INFO_LEVEL_NUM		143
 #define INST_INFO_LEVEL_ARGS		144
-#define INST_TCLOO_SELF			145
+#define INST_RESOLVE_COMMAND		145
+#define INST_TCLOO_SELF			146
 
 /* The last opcode */
-#define LAST_INST_OPCODE		145
+#define LAST_INST_OPCODE		146
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 0ec16e9..a24c806 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4107,6 +4107,16 @@ TEBCresume(
 	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
 	NEXT_INST_F(1, 1, 1);
     }
+    case INST_RESOLVE_COMMAND: {
+	Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
+
+	TclNewObj(objResultPtr);
+	if (cmd != NULL) {
+	    Tcl_GetCommandFullName(interp, cmd, objResultPtr);
+	}
+	TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr);
+	NEXT_INST_F(1, 1, 1);
+    }
     case INST_TCLOO_SELF: {
 	CallFrame *framePtr = iPtr->varFramePtr;
 	CallContext *contextPtr;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1bf52d1..448a7cd 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3597,6 +3597,9 @@ MODULE_SCOPE int	TclCompileNamespaceCurrentCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileNamespaceWhichCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileNoOp(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 072eb72..60c40d0 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -178,7 +178,7 @@ static const EnsembleImplMap defaultNamespaceMap[] = {
     {"tail",		NamespaceTailCmd, NULL, NULL, NULL, 0},
     {"unknown",		NamespaceUnknownCmd, NULL, NULL, NULL, 0},
     {"upvar",		NamespaceUpvarCmd,	TclCompileNamespaceUpvarCmd, NULL, NULL, 0},
-    {"which",		NamespaceWhichCmd, NULL, NULL, NULL, 0},
+    {"which",		NamespaceWhichCmd,	TclCompileNamespaceWhichCmd, NULL, NULL, 0},
     {NULL, NULL, NULL, NULL, NULL, 0}
 };