diff options
| -rw-r--r-- | ChangeLog | 11 | ||||
| -rw-r--r-- | generic/tclBasic.c | 5 | ||||
| -rw-r--r-- | generic/tclCompile.h | 3 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 26 | ||||
| -rw-r--r-- | tests/coroutine.test | 27 | ||||
| -rw-r--r-- | tests/namespace.test | 25 |
6 files changed, 90 insertions, 7 deletions
@@ -1,3 +1,14 @@ +2010-01-03 Miguel Sofer <msofer@users.sf.net> + + * generic/tclBasic.c: Fix lerak of coroutines on namespace + * generic/tclCompile.h: deletion, [Bug 2724403]. Added a test + * generic/tclNamesp.c: for this leak, and also a test for + * tests/coroutine.test: leaks on namespace deletion. + * tests/namespace.test: + + * library/init.tcl (unknown): [Bug 2824981]: Fix infinite recursion of + ::unknown when [set] is undefined. + 2009-12-30 Donal K. Fellows <dkf@users.sf.net> * library/safe.tcl (AliasSource): [Bug 2923613]: Make the safer diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 43f484b..254760d 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.437 2009/12/24 06:55:25 dkf Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.438 2010/01/03 20:29:11 msofer Exp $ */ #include "tclInt.h" @@ -137,7 +137,6 @@ static Tcl_Obj * GetCommandSource(Interp *iPtr, int objc, Tcl_Obj *const objv[], int lookup); static void MathFuncWrongNumArgs(Tcl_Interp *interp, int expected, int actual, Tcl_Obj *const *objv); -static Tcl_ObjCmdProc NRInterpCoroutine; static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static Tcl_NRPostProc NRRunObjProc; @@ -8674,7 +8673,7 @@ NRCoroutineExitCallback( return result; } -static int +int NRInterpCoroutine( ClientData clientData, Tcl_Interp *interp, /* Current interpreter. */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 25dec86..a41e094 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -9,7 +9,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.h,v 1.119 2009/09/04 17:33:11 dgp Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.120 2010/01/03 20:29:11 msofer Exp $ */ #ifndef _TCLCOMPILATION @@ -858,6 +858,7 @@ typedef struct { MODULE_SCOPE Tcl_NRPostProc NRCallTEBC; MODULE_SCOPE Tcl_NRPostProc NRCommand; +MODULE_SCOPE Tcl_ObjCmdProc NRInterpCoroutine; #define TCL_NR_BC_TYPE 0 #define TCL_NR_ATEXIT_TYPE 1 diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index 507007d..f8ee460 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.198 2009/12/13 17:11:47 msofer Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.199 2010/01/03 20:29:11 msofer Exp $ */ #include "tclInt.h" @@ -956,7 +956,31 @@ Tcl_DeleteNamespace( Namespace *globalNsPtr = (Namespace *) TclGetGlobalNamespace((Tcl_Interp *) iPtr); Tcl_HashEntry *entryPtr; + Tcl_HashSearch search; + Command *cmdPtr; + + /* + * Delete all coroutine commands now: break the circular ref cycle between + * the namespace and the coroutine command [Bug 2724403]. This code is + * essentially duplicated in TclTeardownNamespace() for all other + * commands. Don't optimize to Tcl_NextHashEntry() because of traces. + * + * NOTE: we could avoid traversing the ns's command list by keeping a + * separate list of coros. + */ + for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + entryPtr != NULL;) { + cmdPtr = (Command *) Tcl_GetHashValue(entryPtr); + if (cmdPtr->nreProc == NRInterpCoroutine) { + Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr, (Tcl_Command)cmdPtr); + entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search); + } else { + entryPtr = entryPtr->nextPtr; + } + } + + /* * If the namespace has associated ensemble commands, delete them first. * This leaves the actual contents of the namespace alone (unless they are diff --git a/tests/coroutine.test b/tests/coroutine.test index b4019d4..caa1d0a 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -9,7 +9,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: coroutine.test,v 1.10 2009/12/19 14:22:00 msofer Exp $ +# RCS: @(#) $Id: coroutine.test,v 1.11 2010/01/03 20:29:12 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -17,6 +17,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} { } testConstraint testnrelevels [llength [info commands testnrelevels]] +testConstraint memory [llength [info commands memory]] set lambda [list {{start 0} {stop 10}} { # init @@ -378,6 +379,7 @@ test coroutine-4.2 {bug #2093188} -setup { rename bar {} unset ::res } -result {{} 3 {{v {} read} {v {} unset}}} + test coroutine-4.3 {bug #2093947} -setup { proc foo {} { set v 1 @@ -412,6 +414,29 @@ test coroutine-4.4 {bug #2917627: cmd resolution} -setup { namespace delete b } -result local +test coroutine-4.5 {bug #2724403} -constraints {memory} \ +-setup { + proc getbytes {} { + set lines [split [memory info] "\n"] + lindex $lines 3 3 + } +} -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set ns ::y$i + namespace eval $ns {} + proc ${ns}::start {} {yield; puts hello} + coroutine ${ns}::run ${ns}::start + namespace delete $ns + set start $end + set end [getbytes] + } + set leakedBytes [expr {$end - $start}] +} -cleanup { + rename getbytes {} + unset i ns start end +} -result 0 + test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} \ -setup { proc nestedYield {{val {}}} { diff --git a/tests/namespace.test b/tests/namespace.test index 5feaf91..889f945 100644 --- a/tests/namespace.test +++ b/tests/namespace.test @@ -11,13 +11,15 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: namespace.test,v 1.76 2009/01/09 15:00:27 dkf Exp $ +# RCS: @(#) $Id: namespace.test,v 1.77 2010/01/03 20:29:12 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } +testConstraint memory [llength [info commands memory]] + # # REMARK: the tests for 'namespace upvar' are not done here. They are to be # found in the file 'upvar.test'. @@ -2853,6 +2855,27 @@ test namespace-53.10 {ensembles: nested rewrite} -setup { 1 {wrong # args: should be "ns v x z2 a2"}\ 0 {2 v v2}} +test namespace-54.1 {leak on namespace deletion} -constraints {memory} \ +-setup { + proc getbytes {} { + set lines [split [memory info] "\n"] + lindex $lines 3 3 + } +} -body { + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set ns ::y$i + namespace eval $ns {} + namespace delete $ns + set start $end + set end [getbytes] + } + set leakedBytes [expr {$end - $start}] +} -cleanup { + rename getbytes {} + unset i ns start end +} -result 0 + # cleanup catch {rename cmd1 {}} catch {unset l} |