From ab493437ef6fb750de339bb51d29743250bcde32 Mon Sep 17 00:00:00 2001 From: andreas_kupries Date: Fri, 25 Jul 2008 20:30:24 +0000 Subject: * tests/info.test: Tests 38.* added, exactly testing the tracking of location for uplevel scripts. * generic/tclCompile.c (TclInitCompileEnv): Reorganized the initialization of the #280 location information to match the flow in TclEvalObjEx to get more absolute contexts. * generic/tclBasic.c (TclEvalObjEx): Moved the pure-list optimization out of the eval-direct code path to be done always, i.e. even when a compile is requested. This way we do not loose the association between #280 location information and the list elements, if any. --- ChangeLog | 15 ++++++ generic/tclBasic.c | 131 ++++++++++++++++++++++++++------------------------- generic/tclCompile.c | 45 ++++++++++-------- generic/tclProc.c | 4 +- tests/compile.test | 4 +- tests/info.test | 111 ++++++++++++++++++++++++++++++++++++++----- 6 files changed, 211 insertions(+), 99 deletions(-) diff --git a/ChangeLog b/ChangeLog index ff7ad5a..b0cb633 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,18 @@ +2008-07-25 Andreas Kupries + + * tests/info.test: Tests 38.* added, exactly testing the tracking + of location for uplevel scripts. + + * generic/tclCompile.c (TclInitCompileEnv): Reorganized the + initialization of the #280 location information to match the flow + in TclEvalObjEx to get more absolute contexts. + + * generic/tclBasic.c (TclEvalObjEx): Moved the pure-list + optimization out of the eval-direct code path to be done always, + i.e. even when a compile is requested. This way we do not loose + the association between #280 location information and the list + elements, if any. + 2008-07-23 Andreas Kupries * tests/info.test: Reordered the tests to have monotonously diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 9cb5707..917a8a5 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -14,7 +14,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.295.2.4 2008/07/23 20:47:30 andreas_kupries Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.295.2.5 2008/07/25 20:30:34 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1409,6 +1409,10 @@ DeleteInterpProc( ckfree((char *) eclPtr->loc); } + if (eclPtr->eiloc != NULL) { + ckfree((char *) eclPtr->eiloc); + } + ckfree((char *) eclPtr); Tcl_DeleteHashEntry(hPtr); } @@ -4755,7 +4759,7 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr) ((List *)obj->internalRep.twoPtrValue.ptr1)->canonicalFlag)) { return; } - + /* * First look for location information recorded in the argument * stack. That is nearest. @@ -4920,79 +4924,80 @@ TclEvalObjEx( Tcl_IncrRefCount(objPtr); - if (flags & TCL_EVAL_DIRECT) { - /* - * We're not supposed to use the compiler or byte-code interpreter. - * Let Tcl_EvalEx evaluate the command directly (and probably more - * slowly). - * - * Pure List Optimization (no string representation). In this case, we - * can safely use Tcl_EvalObjv instead and get an appreciable - * improvement in execution speed. This is because it allows us to - * avoid a setFromAny step that would just pack everything into a - * string and back out again. - * - * This restriction has been relaxed a bit by storing in lists whether - * they are "canonical" or not (a canonical list being one that is - * either pure or that has its string rep derived by - * UpdateStringOfList from the internal rep). - */ + /* Pure List Optimization (no string representation). In this case, we can + * safely use Tcl_EvalObjv instead and get an appreciable improvement in + * execution speed. This is because it allows us to avoid a setFromAny + * step that would just pack everything into a string and back out again. + * + * This also preserves any associations between list elements and location + * information for such elements. + * + * This restriction has been relaxed a bit by storing in lists whether + * they are "canonical" or not (a canonical list being one that is either + * pure or that has its string rep derived by UpdateStringOfList from the + * internal rep). + */ - if (objPtr->typePtr == &tclListType) { /* is a list... */ - List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; + if (objPtr->typePtr == &tclListType) { /* is a list... */ + List *listRepPtr = objPtr->internalRep.twoPtrValue.ptr1; - if (objPtr->bytes == NULL || /* ...without a string rep */ - listRepPtr->canonicalFlag) {/* ...or that is canonical */ - /* - * TIP #280 Structures for tracking lines. As we know that - * this is dynamic execution we ignore the invoker, even if - * known. - */ + if (objPtr->bytes == NULL || /* ...without a string rep */ + listRepPtr->canonicalFlag) {/* ...or that is canonical */ + /* + * TIP #280 Structures for tracking lines. As we know that this is + * dynamic execution we ignore the invoker, even if known. + */ - int nelements; - Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr); - CmdFrame *eoFramePtr = (CmdFrame *) - TclStackAlloc(interp, sizeof(CmdFrame)); + int nelements; + Tcl_Obj **elements, *copyPtr = TclListObjCopy(NULL, objPtr); + CmdFrame *eoFramePtr = (CmdFrame *) + TclStackAlloc(interp, sizeof(CmdFrame)); - eoFramePtr->type = TCL_LOCATION_EVAL_LIST; - eoFramePtr->level = (iPtr->cmdFramePtr == NULL? - 1 : iPtr->cmdFramePtr->level + 1); - eoFramePtr->framePtr = iPtr->framePtr; - eoFramePtr->nextPtr = iPtr->cmdFramePtr; + eoFramePtr->type = TCL_LOCATION_EVAL_LIST; + eoFramePtr->level = (iPtr->cmdFramePtr == NULL? + 1 : iPtr->cmdFramePtr->level + 1); + eoFramePtr->framePtr = iPtr->framePtr; + eoFramePtr->nextPtr = iPtr->cmdFramePtr; - eoFramePtr->nline = 0; - eoFramePtr->line = NULL; + eoFramePtr->nline = 0; + eoFramePtr->line = NULL; - eoFramePtr->cmd.listPtr = objPtr; - Tcl_IncrRefCount(eoFramePtr->cmd.listPtr); - eoFramePtr->data.eval.path = NULL; + eoFramePtr->cmd.listPtr = objPtr; + Tcl_IncrRefCount(eoFramePtr->cmd.listPtr); + eoFramePtr->data.eval.path = NULL; - /* - * TIP #280 We do _not_ compute all the line numbers for the - * words in the command. For the eval of a pure list the most - * sensible choice is to put all words on line 1. Given that - * we neither need memory for them nor compute anything. - * 'line' is left NULL. The two places using this information - * (TclInfoFrame, and TclInitCompileEnv), are special-cased to - * use the proper line number directly instead of accessing - * the 'line' array. - */ + /* + * TIP #280 We do _not_ compute all the line numbers for the words + * in the command. For the eval of a pure list the most sensible + * choice is to put all words on line 1. Given that we neither + * need memory for them nor compute anything. 'line' is left + * NULL. The two places using this information (TclInfoFrame, and + * TclInitCompileEnv), are special-cased to use the proper line + * number directly instead of accessing the 'line' array. + */ - Tcl_ListObjGetElements(NULL, copyPtr, - &nelements, &elements); + Tcl_ListObjGetElements(NULL, copyPtr, + &nelements, &elements); - iPtr->cmdFramePtr = eoFramePtr; - result = Tcl_EvalObjv(interp, nelements, elements, - flags); + iPtr->cmdFramePtr = eoFramePtr; + result = Tcl_EvalObjv(interp, nelements, elements, + flags); - Tcl_DecrRefCount(copyPtr); - iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; - Tcl_DecrRefCount(eoFramePtr->cmd.listPtr); - TclStackFree(interp, eoFramePtr); + Tcl_DecrRefCount(copyPtr); + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; + Tcl_DecrRefCount(eoFramePtr->cmd.listPtr); + TclStackFree(interp, eoFramePtr); - goto done; - } + goto done; } + } + + if (flags & TCL_EVAL_DIRECT) { + /* + * We're not supposed to use the compiler or byte-code interpreter. + * Let Tcl_EvalEx evaluate the command directly (and probably more + * slowly). + */ /* * TIP #280. Propagate context as much as we can. Especially if the diff --git a/generic/tclCompile.c b/generic/tclCompile.c index e557860..3c7ca6e 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.146.2.5 2008/07/23 20:47:32 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.146.2.6 2008/07/25 20:30:44 andreas_kupries Exp $ */ #include "tclInt.h" @@ -933,7 +933,22 @@ TclInitCompileEnv( * ...) which may make change the type as well. */ - if ((invoker->nline <= word) || (invoker->line[word] < 0)) { + CmdFrame* ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); + int pc = 0; + + *ctxPtr = *invoker; + + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr is used instead. + */ + + TclGetSrcInfoForPc(ctxPtr); + pc = 1; + } + + if ((ctxPtr->nline <= word) || (ctxPtr->line[word] < 0)) { /* * Word is not a literal, relative counting. */ @@ -941,45 +956,37 @@ TclInitCompileEnv( envPtr->line = 1; envPtr->extCmdMapPtr->type = (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); - } else { - CmdFrame *ctxPtr; - int pc = 0; - - ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); - *ctxPtr = *invoker; - if (invoker->type == TCL_LOCATION_BC) { + if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { /* - * Note: Type BC => ctx.data.eval.path is not used. - * ctx.data.tebc.codePtr is used instead. + * The reference made by 'TclGetSrcInfoForPc' is dead. */ - - TclGetSrcInfoForPc(ctxPtr); - pc = 1; + Tcl_DecrRefCount(ctxPtr->data.eval.path); } - + } else { envPtr->line = ctxPtr->line[word]; envPtr->extCmdMapPtr->type = ctxPtr->type; if (ctxPtr->type == TCL_LOCATION_SOURCE) { + envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path; + if (pc) { /* * The reference 'TclGetSrcInfoForPc' made is transfered. */ - envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path; ctxPtr->data.eval.path = NULL; } else { /* * We have a new reference here. */ - envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path; - Tcl_IncrRefCount(envPtr->extCmdMapPtr->path); + Tcl_IncrRefCount(ctxPtr->data.eval.path); } } - TclStackFree(interp, ctxPtr); } + + TclStackFree(interp, ctxPtr); } envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; diff --git a/generic/tclProc.c b/generic/tclProc.c index f9e6822..2b7c5f7 100644 --- a/generic/tclProc.c +++ b/generic/tclProc.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclProc.c,v 1.139.2.1 2008/07/21 19:38:19 andreas_kupries Exp $ + * RCS: @(#) $Id: tclProc.c,v 1.139.2.2 2008/07/25 20:30:47 andreas_kupries Exp $ */ #include "tclInt.h" @@ -2162,7 +2162,7 @@ TclProcCleanupProc( /* * TIP #280: Release the location data associated with this Proc * structure, if any. The interpreter may not exist (For example for - * procbody structurues created by tbcload. + * procbody structures created by tbcload. */ if (!iPtr) { diff --git a/tests/compile.test b/tests/compile.test index fe2deea..6785855 100644 --- a/tests/compile.test +++ b/tests/compile.test @@ -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: compile.test,v 1.48 2007/12/13 15:26:06 dgp Exp $ +# RCS: @(#) $Id: compile.test,v 1.48.2.1 2008/07/25 20:30:58 andreas_kupries Exp $ package require tcltest 2 namespace import -force ::tcltest::* @@ -276,7 +276,7 @@ test compile-11.9 {Tcl_Append*: ensure Tcl_ResetResult is used properly} { # TclReleaseLiteral. They are only effective when tcl is compiled # with TCL_MEM_DEBUG # -# Special test for leak on interp delete [Bug 467523]. +# Special test for leak on interp delete [Bug 467523]. test compile-12.1 {testing literal leak on interp delete} -setup { proc getbytes {} { set lines [split [memory info] "\n"] diff --git a/tests/info.test b/tests/info.test index 66b19b4..2596dea 100644 --- a/tests/info.test +++ b/tests/info.test @@ -13,7 +13,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: info.test,v 1.47.2.4 2008/07/23 21:42:45 andreas_kupries Exp $ +# RCS: @(#) $Id: info.test,v 1.47.2.5 2008/07/25 20:30:58 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -746,15 +746,15 @@ test info-22.2 {info frame, bad level absolute} {!singleTestInterp} { catch {info frame 9} msg set msg } {bad level "9"} -test info-22.3 {info frame, current, relative} { +test info-22.3 {info frame, current, relative} -match glob -body { info frame 0 -} {type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest} -test info-22.4 {info frame, current, relative, nested} { +} -result {type source line 750 file * cmd {info frame 0} proc ::tcltest::RunTest} +test info-22.4 {info frame, current, relative, nested} -match glob -body { set res [info frame 0] -} {type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest} -test info-22.5 {info frame, current, absolute} {!singleTestInterp} { +} -result {type source line 753 file * cmd {info frame 0} proc ::tcltest::RunTest} +test info-22.5 {info frame, current, absolute} -constraints {!singleTestInterp} -match glob -body { reduce [info frame 7] -} {type eval line 2 cmd {info frame 7} proc ::tcltest::RunTest} +} -result {type source line 756 file * cmd {info frame 7} proc ::tcltest::RunTest} test info-22.6 {info frame, global, relative} {!singleTestInterp} { reduce [info frame -6] } {type source line 758 file info.test cmd test\ info-22.6\ \{info\ frame,\ global,\ relative\}\ \{!singleTestInter level 0} @@ -783,11 +783,11 @@ test info-23.2 {eval'd info frame, dynamic} {!singleTestInterp} { set script {info frame} eval $script } 8 -test info-23.3 {eval'd info frame, literal} { +test info-23.3 {eval'd info frame, literal} -match glob -body { eval { info frame 0 } -} {type eval line 2 cmd {info frame 0} proc ::tcltest::RunTest} +} -result {type source line 788 file * cmd {info frame 0} proc ::tcltest::RunTest} test info-23.4 {eval'd info frame, semi-dynamic} { eval info frame 0 } {type eval line 1 cmd {info frame 0} proc ::tcltest::RunTest} @@ -1301,7 +1301,7 @@ namespace delete foo # ------------------------------------------------------------------------- -test info-37.0 {eval pure list, single line} { +test info-37.0 {eval pure list, single line} -match glob -body { # Basically, counting the newline in the word seen through $foo # doesn't really make sense. It makes a bit of sense if the word # would have been a string literal in the command list. @@ -1319,12 +1319,97 @@ test info-37.0 {eval pure list, single line} { }] eval $cmd set res -} {10 {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} -9 {type eval line 2 cmd etrace proc ::tcltest::RunTest} -8 {type eval line 1 cmd foreac proc ::tcltest::RunTest}} +} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type eval line 2 cmd etrace proc ::tcltest::RunTest} +* {type eval line 1 cmd foreac proc ::tcltest::RunTest}} # ------------------------------------------------------------------------- +# 6 cases. +## DV. direct-var - unchanged +## DPV direct-proc-var - ditto +## PPV proc-proc-var - ditto +## DL. direct-literal - now tracking absolute location +## DPL direct-proc-literal - ditto +## PPL proc-proc-literal - ditto +## ### ### ### ######### ######### #########" + +proc control {vv script} { + upvar 1 $vv var + return [uplevel 1 $script] +} + +proc datal {} { + control y { + set y PPL + etrace + } +} + +proc datav {} { + set script { + set y PPV + etrace + } + control y $script +} + +test info-38.1 {location information for uplevel, dv, direct-var} -match glob -body { + set script { + set y DV. + etrace + } + join [lrange [uplevel \#0 $script] 0 2] \n +} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type eval line 3 cmd etrace proc ::tcltest::RunTest} +* {type source line 1362 file info.test cmd {uplevel \\#0 $script} proc ::tcltest::RunTest}} + +test info-38.2 {location information for uplevel, dl, direct-literal} -match glob -body { + join [lrange [uplevel \#0 { + set y DL. + etrace + }] 0 2] \n +} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1370 file info.test cmd etrace proc ::tcltest::RunTest} +* {type source line 1368 file info.test cmd uplevel\\ \\\\ proc ::tcltest::RunTest}} + +test info-38.3 {location information for uplevel, dpv, direct-proc-var} -match glob -body { + set script { + set y DPV + etrace + } + join [lrange [control y $script] 0 3] \n +} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type eval line 3 cmd etrace proc ::control} +* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1381 file info.test cmd {control y $script} proc ::tcltest::RunTest}} + +test info-38.4 {location information for uplevel, dpv, direct-proc-literal} -match glob -body { + join [lrange [control y { + set y DPL + etrace + }] 0 3] \n +} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1390 file info.test cmd etrace proc ::control} +* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1388 file info.test cmd control proc ::tcltest::RunTest}} + +test info-38.5 {location information for uplevel, ppv, proc-proc-var} -match glob -body { + join [lrange [datav] 0 4] \n +} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type eval line 3 cmd etrace proc ::control} +* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1354 file info.test cmd {control y $script} proc ::datav level 1} +* {type source line 1398 file info.test cmd datav proc ::tcltest::RunTest}} + +test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match glob -body { + join [lrange [datal] 0 4] \n +} -result {* {type source line 728 file info.test cmd {info frame $level} proc ::etrace level 0} +* {type source line 1345 file info.test cmd etrace proc ::control} +* {type source line 1339 file info.test cmd {uplevel 1 $script} proc ::control} +* {type source line 1343 file info.test cmd control proc ::datal level 1} +* {type source line 1406 file info.test cmd datal proc ::tcltest::RunTest}} + # ------------------------------------------------------------------------- # cleanup -- cgit v0.12