From f7429e323099dee3d15b340936276850974dbbe7 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 11 Jul 2023 11:35:01 +0000 Subject: Prevent foreach memory bloat iterating within a proc --- generic/tclExecute.c | 16 ++++++++++++---- 1 file changed, 12 insertions(+), 4 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 120dac6..b74c74a 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6424,7 +6424,7 @@ TEBCresume( { ForeachInfo *infoPtr; - Tcl_Obj *listPtr, **elements; + Tcl_Obj *listPtr; ForeachVarList *varListPtr; Tcl_Size numLists, listLen, numVars, listTmpDepth; Tcl_Size iterNum, iterMax, iterTmp; @@ -6540,8 +6540,7 @@ TEBCresume( listPtr = OBJ_AT_DEPTH(listTmpDepth); DECACHE_STACK_INFO(); - status = TclListObjGetElementsM( - interp, listPtr, &listLen, &elements); + status = Tcl_ListObjLength(interp, listPtr, &listLen); if (status != TCL_OK) { CACHE_STACK_INFO(); goto gotError; @@ -6554,7 +6553,16 @@ TEBCresume( if (valIndex >= listLen) { TclNewObj(valuePtr); } else { - valuePtr = elements[valIndex]; + status = Tcl_ListObjIndex( + interp, listPtr, valIndex, &valuePtr); + if (status != TCL_OK) { + /* Could happen for abstract lists */ + goto gotError; + } + if (valuePtr == NULL) { + /* Permitted for Tcl_LOI to return NULL */ + TclNewObj(valuePtr); + } } varIndex = varListPtr->varIndexes[j]; -- cgit v0.12 From d852753be2883cd493304baf8fe53eaf7920df1f Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 11 Jul 2023 12:59:13 +0000 Subject: Wrap DECACHE_STACK_INFO around Tcl_ListObjIndex call from bytecode engine. --- generic/tclExecute.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index b74c74a..84331a3 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6553,12 +6553,15 @@ TEBCresume( if (valIndex >= listLen) { TclNewObj(valuePtr); } else { + DECACHE_STACK_INFO(); status = Tcl_ListObjIndex( interp, listPtr, valIndex, &valuePtr); if (status != TCL_OK) { /* Could happen for abstract lists */ + CACHE_STACK_INFO(); goto gotError; } + CACHE_STACK_INFO(); if (valuePtr == NULL) { /* Permitted for Tcl_LOI to return NULL */ TclNewObj(valuePtr); -- cgit v0.12 From 04328bc72033c31bd77ac75f27def3e39bd4d117 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Tue, 11 Jul 2023 16:43:13 +0000 Subject: Tweak last for performance in case of traditional lists. --- generic/tclExecute.c | 36 ++++++++++++++++++++++++------------ 1 file changed, 24 insertions(+), 12 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 84331a3..973ba8e 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -6424,7 +6424,7 @@ TEBCresume( { ForeachInfo *infoPtr; - Tcl_Obj *listPtr; + Tcl_Obj *listPtr, **elements; ForeachVarList *varListPtr; Tcl_Size numLists, listLen, numVars, listTmpDepth; Tcl_Size iterNum, iterMax, iterTmp; @@ -6537,10 +6537,18 @@ TEBCresume( for (i = 0; i < numLists; i++) { varListPtr = infoPtr->varLists[i]; numVars = varListPtr->numVars; + int hasAbstractList; listPtr = OBJ_AT_DEPTH(listTmpDepth); + hasAbstractList = TclObjTypeHasProc(listPtr, indexProc) != 0; DECACHE_STACK_INFO(); - status = Tcl_ListObjLength(interp, listPtr, &listLen); + if (hasAbstractList) { + status = Tcl_ListObjLength(interp, listPtr, &listLen); + elements = NULL; + } else { + status = TclListObjGetElementsM( + interp, listPtr, &listLen, &elements); + } if (status != TCL_OK) { CACHE_STACK_INFO(); goto gotError; @@ -6554,18 +6562,22 @@ TEBCresume( TclNewObj(valuePtr); } else { DECACHE_STACK_INFO(); - status = Tcl_ListObjIndex( - interp, listPtr, valIndex, &valuePtr); - if (status != TCL_OK) { - /* Could happen for abstract lists */ - CACHE_STACK_INFO(); - goto gotError; + if (elements) { + valuePtr = elements[valIndex]; + } else { + status = Tcl_ListObjIndex( + interp, listPtr, valIndex, &valuePtr); + if (status != TCL_OK) { + /* Could happen for abstract lists */ + CACHE_STACK_INFO(); + goto gotError; + } + if (valuePtr == NULL) { + /* Permitted for Tcl_LOI to return NULL */ + TclNewObj(valuePtr); + } } CACHE_STACK_INFO(); - if (valuePtr == NULL) { - /* Permitted for Tcl_LOI to return NULL */ - TclNewObj(valuePtr); - } } varIndex = varListPtr->varIndexes[j]; -- cgit v0.12 From 4ee94e4f670279c82c6af59820e2d7d82c774ca5 Mon Sep 17 00:00:00 2001 From: apnadkarni Date: Wed, 12 Jul 2023 02:31:54 +0000 Subject: Add test --- tests/lseq.test | 21 +++++++++++++++++++++ 1 file changed, 21 insertions(+) diff --git a/tests/lseq.test b/tests/lseq.test index 6ec9bb2..a149908 100644 --- a/tests/lseq.test +++ b/tests/lseq.test @@ -21,6 +21,16 @@ testConstraint knownBug 0 testConstraint has64BitLengths [expr {$tcl_platform(pointerSize) == 8}] testConstraint has32BitLengths [expr {$tcl_platform(pointerSize) == 4}] +proc memusage {} { + set fd [open /proc/[pid]/statm] + set line [gets $fd] + if {[llength $line] != 7} { + error "Unexpected /proc/pid/statm format" + } + return [lindex $line 5] +} +testConstraint hasMemUsage [expr {![catch {memusage}]}] + # Arg errors test lseq-1.1 {error cases} -body { lseq @@ -707,6 +717,17 @@ test lseq-convertToList {does not result in a memory error} -body { list [catch {set var1 [lindex [lreplace [lseq 1 2] 1 1 hello] 0]} cres] $cres } -cleanup {unset var1 cres} -result {1 {can't set "var1": this is an error}} +test lseq-bug-54329e39c7 {does not cause memory bloat} -constraints { + hasMemUsage +} -body { + set l [lseq 1000000] + proc p l {foreach x $l {}} + set premem [memusage] + p $l + set postmem [memusage] + expr {($postmem - $premem) < 10} +} -result 1 + # cleanup ::tcltest::cleanupTests -- cgit v0.12