Attachment "cmdResVsCmdLiterals.patch" to
ticket [3418547fff]
added by
foxcruiser
2011-10-04 23:15:23.
Index: generic/tclBasic.c
===================================================================
--- generic/tclBasic.c
+++ generic/tclBasic.c
@@ -1920,10 +1920,20 @@
Tcl_SetErrorCode(interp, "TCL", "EXPOSE", "COMMAND_EXISTS", NULL);
return TCL_ERROR;
}
/*
+ * Command resolvers (per-interp, per-namespace) might have resolved to a
+ * command for the given namespace scope with this command not being
+ * registered with the namespace's command table. During BC compilation,
+ * the so-resolved command turns into a CmdName literal. Without
+ * invalidating a possible CmdName literal here explicitly, such literals
+ * keep being reused while pointing to overhauled commands.
+ */
+ TclInvalidateCmdLiteral(interp, cmdName, nsPtr);
+
+ /*
* The list of command exported from the namespace might have changed.
* However, we do not need to recompute this just yet; next time we need
* the info will be soon enough.
*/
@@ -2066,10 +2076,21 @@
*/
ckfree(Tcl_GetHashValue(hPtr));
}
} else {
+
+ /*
+ * Command resolvers (per-interp, per-namespace) might have resolved to a
+ * command for the given namespace scope with this command not being
+ * registered with the namespace's command table. During BC compilation,
+ * the so-resolved command turns into a CmdName literal. Without
+ * invalidating a possible CmdName literal here explicitly, such literals
+ * keep being reused while pointing to overhauled commands.
+ */
+ TclInvalidateCmdLiteral(interp, tail, nsPtr);
+
/*
* The list of command exported from the namespace might have changed.
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
@@ -2239,10 +2260,20 @@
*/
ckfree(Tcl_GetHashValue(hPtr));
}
} else {
+ /*
+ * Command resolvers (per-interp, per-namespace) might have resolved to a
+ * command for the given namespace scope with this command not being
+ * registered with the namespace's command table. During BC compilation,
+ * the so-resolved command turns into a CmdName literal. Without
+ * invalidating a possible CmdName literal here explicitly, such literals
+ * keep being reused while pointing to overhauled commands.
+ */
+ TclInvalidateCmdLiteral(interp, tail, nsPtr);
+
/*
* The list of command exported from the namespace might have changed.
* However, we do not need to recompute this just yet; next time we
* need the info will be soon enough.
*/
@@ -2547,10 +2578,21 @@
* but that's no big deal.
*/
TclInvalidateNsCmdLookup(cmdNsPtr);
TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
+
+
+ /*
+ * Command resolvers (per-interp, per-namespace) might have resolved to a
+ * command for the given namespace scope with this command not being
+ * registered with the namespace's command table. During BC compilation,
+ * the so-resolved command turns into a CmdName literal. Without
+ * invalidating a possible CmdName literal here explicitly, such literals
+ * keep being reused while pointing to overhauled commands.
+ */
+ TclInvalidateCmdLiteral(interp, newTail, cmdPtr->nsPtr);
/*
* Script for rename traces can delete the command "oldName". Therefore
* increment the reference count for cmdPtr so that it's Command structure
* is freed only towards the end of this function by calling
Index: generic/tclCompile.h
===================================================================
--- generic/tclCompile.h
+++ generic/tclCompile.h
@@ -953,10 +953,12 @@
const char *string, int maxChars);
MODULE_SCOPE void TclRegisterAuxDataType(const AuxDataType *typePtr);
MODULE_SCOPE int TclRegisterLiteral(CompileEnv *envPtr,
char *bytes, int length, int flags);
MODULE_SCOPE void TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
+MODULE_SCOPE void TclInvalidateCmdLiteral(Tcl_Interp *interp,
+ CONST char *name, Namespace *nsPtr);
MODULE_SCOPE int TclSingleOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
MODULE_SCOPE int TclSortingOpCmd(ClientData clientData,
Tcl_Interp *interp, int objc,
Index: generic/tclLiteral.c
===================================================================
--- generic/tclLiteral.c
+++ generic/tclLiteral.c
@@ -934,10 +934,52 @@
if (oldBuckets != tablePtr->staticBuckets) {
ckfree(oldBuckets);
}
}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInvalidateCmdLiteral --
+ *
+ * Invalidate a command literal entry, if present in the literal hash
+ * tables, by resetting its internal representation. This invalidation
+ * leaves it in the literal tables and in existing literal arrays. As a
+ * result, existing references continue to work but we force a fresh
+ * command look-up upon the next use (see, in particular,
+ * TclSetCmdNameObj()).
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Resets the internal representation of the CmdName Tcl_Obj
+ * using TclFreeIntRep().
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInvalidateCmdLiteral(
+ Tcl_Interp *interp, /* Interpreter for which to invalidate a
+ command literal */
+ CONST char *name, /* Points to the start of the cmd literal name */
+ Namespace *nsPtr) /* The namespace for which to lookup and
+ invalidate a cmd literal */
+{
+ Interp *iPtr = (Interp *)interp;
+ Tcl_Obj *literalObjPtr;
+
+ literalObjPtr = TclCreateLiteral(iPtr, (char *)name, strlen(name), -1, NULL,
+ nsPtr, 0, NULL);
+ if (literalObjPtr && literalObjPtr->typePtr == &tclCmdNameType) {
+ TclFreeIntRep(literalObjPtr);
+ }
+}
+
+
#ifdef TCL_COMPILE_STATS
/*
*----------------------------------------------------------------------
*
* TclLiteralStats --
Index: generic/tclTest.c
===================================================================
--- generic/tclTest.c
+++ generic/tclTest.c
@@ -409,10 +409,14 @@
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
static int TestNRELevels(ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *const objv[]);
+static int TestInterpResolversCmd(ClientData clientData,
+ Tcl_Interp *interp, int objc,
+ Tcl_Obj *const objv[]);
+
static const Tcl_Filesystem testReportingFilesystem = {
"reporting",
sizeof(Tcl_Filesystem),
TCL_FILESYSTEM_VERSION_1,
@@ -673,10 +677,14 @@
Tcl_CreateMathFunc(interp, "T3", 2, t3ArgTypes, TestMathFunc2,
NULL);
Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
NULL, NULL);
+
+ Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolversCmd,
+ NULL, NULL);
+
if (TclObjTest_Init(interp) != TCL_OK) {
return TCL_ERROR;
}
if (Procbodytest_Init(interp) != TCL_OK) {
@@ -7124,10 +7132,196 @@
result[2] = Tcl_NewListObj(count, remObjv);
Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
ckfree(remObjv);
return TCL_OK;
}
+
+
+static int
+InterpCmdResolver(Tcl_Interp *interp,
+ CONST84 char *name,
+ Tcl_Namespace *context,
+ int flags,
+ Tcl_Command *rPtr)
+{
+ Tcl_Command sourceCmdPtr;
+ Interp *iPtr = (Interp *)interp;
+ CallFrame *varFramePtr = iPtr->varFramePtr;
+ Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
+ varFramePtr->procPtr : NULL;
+ Namespace *ns2NsPtr;
+
+ ns2NsPtr = Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+
+ if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
+ CONST char *callingCmdName = Tcl_GetCommandName(interp, (Tcl_Command)procPtr->cmdPtr);
+
+ if (*callingCmdName == 'x' && *(callingCmdName + 1) == '\0' &&
+ *name == 'z' && *(name + 1) == '\0') {
+ sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL, TCL_GLOBAL_ONLY);
+ if (sourceCmdPtr != NULL) {
+
+ /*fprintf(stdout, "InterpCmdResolver resolves cmd %s as '::y' in proc 'x'\n", name);*/
+
+ *rPtr = sourceCmdPtr;
+ return TCL_OK;
+ }
+ }
+ }
+ return TCL_CONTINUE;
+}
+
+static int
+InterpVarResolver(Tcl_Interp *interp,
+ CONST84 char *name,
+ Tcl_Namespace *context,
+ int flags,
+ Tcl_Var *rPtr)
+{
+ return TCL_CONTINUE;
+}
+
+typedef struct MyResolvedVarInfo {
+ Tcl_ResolvedVarInfo vInfo; /* This must be the first element. */
+ Tcl_Var var;
+ Tcl_Obj *nameObj;
+} MyResolvedVarInfo;
+
+
+static void
+HashVarFree(Tcl_Var var) {
+ if (VarHashRefCount(var) < 2) {
+ ckfree((char *) var);
+ } else {
+ VarHashRefCount(var)--;
+ }
+}
+
+
+static void
+MyCompiledVarFree(Tcl_ResolvedVarInfo *vInfoPtr) {
+ MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)vInfoPtr;
+
+ /*fprintf(stderr, "MyCompiledVarFree %p for variable '%s'\n",
+ resVarInfo, Tcl_GetString(resVarInfo->nameObj));*/
+
+ Tcl_DecrRefCount(resVarInfo->nameObj);
+ if (resVarInfo->var) {
+ HashVarFree(resVarInfo->var);
+ }
+ ckfree((char *)vInfoPtr);
+}
+
+#define TclVarHashGetValue(hPtr) ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+
+static Tcl_Var
+MyCompiledVarFetch(Tcl_Interp *interp, Tcl_ResolvedVarInfo *vinfoPtr) {
+ MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *)vinfoPtr;
+ Tcl_Var var = resVarInfo->var;
+ Namespace *nsPtr;
+ int isNewVar;
+ Interp *iPtr = (Interp *) interp;
+ Tcl_HashEntry *hPtr;
+
+ /*
+ int flags = var ? ((Var *)var)->flags : 0;
+ fprintf(stderr,"MyCompiledVarFetch var '%s' var %p flags = %.4x dead? %.4x\n",
+ Tcl_GetString(resVarInfo->nameObj), var, flags, flags & VAR_DEAD_HASH);*/
+
+ if (var && (((((Var *)var)->flags) & VAR_DEAD_HASH) == 0)) {
+ /*
+ * The cached variable is valid, return it.
+ */
+ /*fprintf(stderr, ".... use cached var '%s' var %p flags = %.4x\n",
+ Tcl_GetString(resVarInfo->nameObj), var, ((Var *)var)->flags);*/
+ return var;
+ }
+
+ if (var) {
+ /*
+ * The variable is not valid anymore. Clean it up.
+ */
+ HashVarFree(var);
+ }
+
+ nsPtr = iPtr->globalNsPtr;
+
+ hPtr = Tcl_CreateHashEntry((Tcl_HashTable *)&(nsPtr->varTable),
+ (char *) resVarInfo->nameObj, &isNewVar);
+ if (hPtr) {
+ var = (Tcl_Var)TclVarHashGetValue(hPtr);
+ } else {
+ var = NULL;
+ }
+
+ resVarInfo->var = var;
+ /*
+ * Increment the reference counter to avoid ckfree() of the variable
+ * in Tcl's FreeVarEntry(); for cleanup, we provide our own
+ * HashVarFree();
+ */
+ VarHashRefCount(var);
+
+ return var;
+}
+
+
+static int
+InterpCompiledVarResolver(Tcl_Interp *interp,
+ CONST84 char *name,
+ int length,
+ Tcl_Namespace *context,
+ Tcl_ResolvedVarInfo **rPtr)
+{
+ /*fprintf(stderr, "InterpCompiledVarResolver for '%s'\n", name);*/
+ /* special handling of variables starting with a capital T */
+ if (*name == 'T') {
+ MyResolvedVarInfo *resVarInfo = ckalloc(sizeof(MyResolvedVarInfo));
+ /*fprintf(stderr, "alloc MyResolvedVarInfo %p\n", resVarInfo);*/
+ resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
+ resVarInfo->vInfo.deleteProc = MyCompiledVarFree; /* if NULL, Tcl does a ckfree on proc clean up */
+ resVarInfo->var = NULL;
+ resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
+ Tcl_IncrRefCount(resVarInfo->nameObj);
+ *rPtr = (Tcl_ResolvedVarInfo *)resVarInfo;
+ return TCL_OK;
+ }
+ return TCL_CONTINUE;
+}
+
+static int
+TestInterpResolversCmd(ClientData clientData,
+ Tcl_Interp *interp,
+ int objc,
+ Tcl_Obj *const objv[])
+{
+ CONST char *option;
+ if (objc != 2) {
+ Tcl_AppendResult(interp, "wrong # arguments: should be \"", TclGetString(objv[0]),
+ " up|down\"", NULL);
+ return TCL_ERROR;
+ }
+ option = TclGetString(objv[1]);
+ if (*option == 'u' && strcmp(option, "up") == 0) {
+ Tcl_AddInterpResolvers(interp,"interpResolver",
+ InterpCmdResolver,
+ InterpVarResolver,
+ InterpCompiledVarResolver);
+ } else if (*option == 'd' && strcmp(option, "down") == 0) {
+ if(Tcl_RemoveInterpResolvers(interp, "interpResolver") == 0) {
+ Tcl_AppendResult(interp, "could not remove the resolver scheme", NULL);
+ return TCL_ERROR;
+ }
+ } else {
+ Tcl_AppendResult(interp, "bad option \"", option,
+ "\": must be 'up' or 'down'", NULL);
+ return TCL_ERROR;
+ }
+ return TCL_OK;
+}
+
+
/*
* Local Variables:
* mode: c
* c-basic-offset: 4
ADDED tests/resolvers.test
Index: tests/resolvers.test
===================================================================
--- tests/resolvers.test
+++ tests/resolvers.test
@@ -0,0 +1,220 @@
+#
+# This test collection covers some unwanted interactions between
+# command literal sharing and the use of command resolvers
+# (per-interp) which cause command literals to be re-used with their
+# command references being invalid in the reusing context.
+#
+# [email protected]
+# [email protected]
+#
+
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest
+ namespace import -force ::tcltest::*
+}
+
+test lit-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
+ testinterpresolver up
+
+ namespace eval ::ns1 {
+ proc z {} { return Z }
+ namespace export z
+ }
+ proc ::y {} { return Y }
+
+ proc ::x {} {
+ z
+ }
+
+} -body {
+ # 1) Have the proc body compiled: During compilation or,
+ # alternatively, the first evaluation of the compiled body, the
+ # InterpCmdResolver (see tclTest.c) maps the cmd token "z" to "::y";
+ # this mapping is saved in the resulting CmdName Tcl_Obj with the
+ # print string "z". The CmdName Tcl_Obj is turned into a command
+ # literal shared for a given (here: the global) namespace.
+ set r0 [x]; # --> The result of [x] is "Y"
+ # 2) After having requested cmd resolution above, we can now use
+ # the globally shared CmdName Tcl_Obj "z", now bound to cmd
+ # ::y. This is certainly questionable, but defensible
+ set r1 [z]; # # --> The result of [z] is "Y"
+ # 3) We import from the namespace ns1 another z. [namespace import]
+ # takes care "shadowed" cmd references, however, till now cmd
+ # literals have not been touched. This is, however, necessary since
+ # the BC compiler (used in the [namespace eval]) seems to be eager
+ # to reuse CmdName Tcl_Objs as cmd literals for a given NS scope. We
+ # expect, that r2 is "Z", the result of the namespace imported cmd.
+ namespace eval :: {
+ namespace import ::ns1::z
+ set r2 [z]
+ }
+ list $r0 $r1 $r2
+} -cleanup {
+ testinterpresolver down
+ rename ::x ""
+ rename ::y ""
+ namespace delete ::ns1
+} -constraints {
+} -result {Y Y Z}
+
+
+test lit-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup {
+ testinterpresolver up
+
+ proc ::y {} { return Y }
+
+ proc ::x {} {
+ z
+ }
+
+} -body {
+ set r0 [x]
+ set r1 [z]
+ proc ::foo {} {
+ proc ::z {} { return Z }
+ return [z]
+ }
+ list $r0 $r1 [::foo]
+} -cleanup {
+ testinterpresolver down
+ rename ::x ""
+ rename ::y ""
+ rename ::foo ""
+ rename ::z ""
+} -result {Y Y Z}
+
+test lit-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup {
+ testinterpresolver up
+ proc ::Z {} { return Z }
+
+ proc ::y {} { return Y }
+
+ proc ::x {} {
+ z
+ }
+
+} -body {
+ set r0 [x]
+ set r1 [z]
+ namespace eval :: {
+ rename ::Z ::z
+ set r2 [z]
+ }
+ list $r0 $r1 $r2
+} -cleanup {
+ testinterpresolver down
+ rename ::x ""
+ rename ::y ""
+ rename ::z ""
+} -result {Y Y Z}
+
+test lit-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup {
+ testinterpresolver up
+ proc ::Z {} { return Z }
+ interp hide {} Z
+
+ proc ::y {} { return Y }
+
+ proc ::x {} {
+ z
+ }
+
+} -body {
+ set r0 [x]
+ set r1 [z]
+ interp expose {} Z z
+ namespace eval :: {
+ set r2 [z]
+ }
+ list $r0 $r1 $r2
+} -cleanup {
+ testinterpresolver down
+ rename ::x ""
+ rename ::y ""
+ rename ::z ""
+} -result {Y Y Z}
+
+test lit-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -setup {
+ testinterpresolver up
+
+ namespace eval ::ns1 {
+ proc z {} { return Z }
+ namespace export z
+ }
+
+ proc ::y {} { return Y }
+
+ namespace eval ::ns2 {
+ proc x {} {
+ z
+ }
+ }
+
+} -body {
+
+ set r0 [namespace eval ::ns2 {x}]
+ set r1 [namespace eval ::ns2 {z}]
+ namespace eval ::ns2 {
+ namespace import ::ns1::z
+ set r2 [z]
+ }
+ list $r0 $r1 $r2
+} -cleanup {
+ testinterpresolver down
+ namespace delete ::ns2
+ namespace delete ::ns1
+} -result {Y Y Z}
+
+test lit-1.6 {cmdNameObj sharing vs. cmd resolver: interp alias} -setup {
+ testinterpresolver up
+ proc ::Z {} { return Z }
+
+ proc ::y {} { return Y }
+
+ proc ::x {} {
+ z
+ }
+
+} -body {
+ set r0 [x]
+ set r1 [z]
+ namespace eval :: {
+ interp alias {} ::z {} ::Z
+ set r2 [z]
+ }
+ list $r0 $r1 $r2
+} -cleanup {
+ testinterpresolver down
+ rename ::x ""
+ rename ::y ""
+ rename ::Z ""
+} -result {Y Y Z}
+
+
+
+test interpRes-1.1 {compiled var resolver: Bug #3383616} -setup {
+ testinterpresolver up
+
+ # The compiled var resolver fetches just variables starting with a
+ # capital "T" and stores some test information in the
+ # resolver-specific resolver var info.
+
+ proc ::x {} {
+ set T1 100
+ return $T1
+ }
+
+} -body {
+ # Call "x" the first time, causing a byte code compilation of the
+ # body. During the compilation the compiled var resolver, the
+ # resolve-specific var info is allocated, during the execution of
+ # the body, the variable is fetched and cached.
+ x;
+ # During later calls, the cached variable is reused.
+ x
+ # When the proc is freed, the resolver-specific resolver var info is
+ # freed. This did not happen before fix #3383616.
+ rename ::x ""
+} -cleanup {
+ testinterpresolver down
+} -result {}
