diff options
| -rw-r--r-- | ChangeLog | 13 | ||||
| -rw-r--r-- | generic/tclCompile.c | 11 | ||||
| -rw-r--r-- | generic/tclInt.h | 12 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 12 | ||||
| -rw-r--r-- | generic/tclOO.c | 10 | ||||
| -rw-r--r-- | generic/tclOOMethod.c | 29 | ||||
| -rw-r--r-- | tests/oo.test | 31 |
7 files changed, 89 insertions, 29 deletions
@@ -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 |