summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog13
-rw-r--r--generic/tclCompile.c11
-rw-r--r--generic/tclInt.h12
-rw-r--r--generic/tclNamesp.c12
-rw-r--r--generic/tclOO.c10
-rw-r--r--generic/tclOOMethod.c29
-rw-r--r--tests/oo.test31
7 files changed, 89 insertions, 29 deletions
diff --git a/ChangeLog b/ChangeLog
index af59a38..14372f2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+2008-08-20 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclOO.c (AllocObject): Suppress compilation of commands in
+ the namespace allocated for each object.
+ * generic/tclOOMethod.c (PushMethodCallFrame): Restore some of the
+ hackery that makes calling methods of classes fast. Fixes performance
+ problem introduced by the fix of [Bug 2037727].
+
+ * generic/tclCompile.c (TclCompileScript): Allow the suppression of
+ * generic/tclInt.h (NS_SUPPRESS_COMPILATION): compilation of commands
+ * generic/tclNamesp.c (Tcl_CreateNamespace): from a namespace or its
+ children.
+
2008-08-20 Daniel Steffen <das@users.sourceforge.net>
* generic/tclTest.c (TestconcatobjCmd): Fix use of internal-only
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 2d040b4..d79ba9d 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclCompile.c,v 1.154 2008/07/25 22:11:20 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.155 2008/08/20 15:41:21 dkf Exp $
*/
#include "tclInt.h"
@@ -1350,6 +1350,7 @@ TclCompileScript(
if ((cmdPtr != NULL)
&& (cmdPtr->compileProc != NULL)
+ && !(cmdPtr->nsPtr->flags&NS_SUPPRESS_COMPILATION)
&& !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
&& !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
int savedNumCmds = envPtr->numCommands;
@@ -1474,10 +1475,10 @@ TclCompileScript(
tokenPtr[1].start, tokenPtr[1].size);
if (eclPtr->type == TCL_LOCATION_SOURCE) {
- EnterCmdWordIndex (eclPtr,
- envPtr->literalArrayPtr[objIndex].objPtr,
- envPtr->codeNext - envPtr->codeStart,
- wordIdx);
+ EnterCmdWordIndex(eclPtr,
+ envPtr->literalArrayPtr[objIndex].objPtr,
+ envPtr->codeNext - envPtr->codeStart,
+ wordIdx);
}
}
TclEmitPush(objIndex, envPtr);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index c40220f..811278b 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.391 2008/08/17 19:37:12 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.392 2008/08/20 15:41:24 dkf Exp $
*/
#ifndef _TCLINT
@@ -361,13 +361,17 @@ struct NamespacePathEntry {
* unit that refers to the namespace has been freed (i.e., when
* the namespace's refCount is 0), the namespace's storage will
* be freed.
- * NS_KILLED 1 means that TclTeardownNamespace has already been called on
- * this namespace and it should not be called again [Bug 1355942]
+ * NS_KILLED - 1 means that TclTeardownNamespace has already been called on
+ * this namespace and it should not be called again [Bug 1355942]
+ * NS_SUPPRESS_COMPILATION -
+ * Marks the commands in this namespace for not being compiled,
+ * forcing them to be looked up every time.
*/
#define NS_DYING 0x01
#define NS_DEAD 0x02
-#define NS_KILLED 0x04
+#define NS_KILLED 0x04
+#define NS_SUPPRESS_COMPILATION 0x08
/*
* Flags passed to TclGetNamespaceForQualName:
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index c9f022d..535f8cc 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,7 +23,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclNamesp.c,v 1.174 2008/08/03 17:33:12 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.175 2008/08/20 15:41:25 dkf Exp $
*/
#include "tclInt.h"
@@ -893,6 +893,16 @@ Tcl_CreateNamespace(
Tcl_DStringFree(&buffer2);
/*
+ * If compilation of commands originating from the parent NS is
+ * suppressed, suppress it for commands originating in this one too.
+ */
+
+ if (nsPtr->parentPtr != NULL &&
+ nsPtr->parentPtr->flags & NS_SUPPRESS_COMPILATION) {
+ nsPtr->flags |= NS_SUPPRESS_COMPILATION;
+ }
+
+ /*
* Return a pointer to the new namespace.
*/
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 4db39c3..95926f2 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOO.c,v 1.14 2008/08/06 21:23:14 dgp Exp $
+ * RCS: @(#) $Id: tclOO.c,v 1.15 2008/08/20 15:41:26 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -455,6 +455,14 @@ AllocObject(
TclSetNsPath((Namespace *) oPtr->namespacePtr, 1, &fPtr->helpersNs);
/*
+ * Suppress use of compiled versions of the commands in this object's
+ * namespace and its children; causes wrong behaviour without expensive
+ * recompilation. [Bug 2037727]
+ */
+
+ ((Namespace *) oPtr->namespacePtr)->flags |= NS_SUPPRESS_COMPILATION;
+
+ /*
* Fill in the rest of the non-zero/NULL parts of the structure.
*/
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index c977a3b..0110283 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclOOMethod.c,v 1.13 2008/08/12 17:51:03 dgp Exp $
+ * RCS: @(#) $Id: tclOOMethod.c,v 1.14 2008/08/20 15:41:26 dkf Exp $
*/
#ifdef HAVE_CONFIG_H
@@ -16,6 +16,7 @@
#endif
#include "tclInt.h"
#include "tclOOInt.h"
+#include "tclCompile.h"
/*
* Structure used to help delay computing names of objects or classes for
@@ -787,17 +788,25 @@ PushMethodCallFrame(
fdPtr->cmd.clientData = &fdPtr->efi;
pmPtr->procPtr->cmdPtr = &fdPtr->cmd;
- /*
- * [Bug 2037727] Always call TclProcCompileProc so that we check not
- * only that we have bytecode, but also that it remains valid.
+ /*
+ * [Bug 2037727] Always call TclProcCompileProc so that we check not only
+ * that we have bytecode, but also that it remains valid. Note that we set
+ * the namespace of the code here directly; this is a hack, but the
+ * alternative is *so* slow...
*/
- result = TclProcCompileProc(interp, pmPtr->procPtr,
- pmPtr->procPtr->bodyPtr, (Namespace *) nsPtr,
- "body of method", namePtr);
- if (result != TCL_OK) {
- return result;
- }
+ if (pmPtr->procPtr->bodyPtr->typePtr == &tclByteCodeType) {
+ ByteCode *codePtr =
+ pmPtr->procPtr->bodyPtr->internalRep.otherValuePtr;
+
+ codePtr->nsPtr = nsPtr;
+ }
+ result = TclProcCompileProc(interp, pmPtr->procPtr,
+ pmPtr->procPtr->bodyPtr, (Namespace *) nsPtr, "body of method",
+ namePtr);
+ if (result != TCL_OK) {
+ return result;
+ }
/*
* Make the stack frame and fill it out with information about this call.
diff --git a/tests/oo.test b/tests/oo.test
index ea97bf2..3575511 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -7,7 +7,7 @@
# See the file "license.terms" for information on usage and redistribution of
# this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: oo.test,v 1.10 2008/08/06 21:23:15 dgp Exp $
+# RCS: @(#) $Id: oo.test,v 1.11 2008/08/20 15:41:26 dkf Exp $
package require TclOO 0.4 ;# Must match value in configure.in
if {[lsearch [namespace children] ::tcltest] == -1} {
@@ -1799,21 +1799,36 @@ test oo-26.1 {Bug 2037727} -setup {
example destroy
rename succeed {}
} -result succeed
-
test oo-26.2 {Bug 2037727} -setup {
oo::class create example {
- method namespace {} {self namespace}
- method foo {} {succeed}
+ method localProc {args body} {proc called $args $body}
+ method run {} { called }
+ }
+ example create i1
+ example create i2
+} -body {
+ i1 localProc args {}
+ i2 localProc args {return nonempty}
+ list [i1 run] [i2 run]
+} -cleanup {
+ example destroy
+} -result {{} nonempty}
+test oo-26.3 {Bug 2037727} -setup {
+ oo::class create example {
+ method subProc {args body} {
+ namespace eval subns [list proc called $args $body]
+ }
+ method run {} { subns::called }
}
example create i1
example create i2
- namespace eval [i1 namespace] {proc succeed args {}}
- namespace eval [i2 namespace] {proc succeed args {return succeed}}
} -body {
- list [i1 foo] [i2 foo]
+ i1 subProc args {}
+ i2 subProc args {return nonempty}
+ list [i1 run] [i2 run]
} -cleanup {
example destroy
-} -result {{} succeed}
+} -result {{} nonempty}
cleanupTests
return
generated by cgit v0.12 at 2024-08-20 10:22:55 (GMT)