diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclCompile.c | 4 | ||||
| -rw-r--r-- | generic/tclCompile.h | 6 | ||||
| -rw-r--r-- | generic/tclExecute.c | 94 | ||||
| -rw-r--r-- | tests/info.test | 42 |
5 files changed, 149 insertions, 4 deletions
@@ -1,3 +1,10 @@ +2010-02-02 Andreas Kupries <andreask@activestate.com> + + * generic/tclCompile.c: [Bug 2933089]: A literal sharing problem with + * generic/tclCompile.h: 'info frame' affects not only 8.6 but 8.5 as + * generic/tclExecute.h: well. Backported the fix done in 8.6, without + * tests/info.test: changes. New testcase info-39.1. + 2010-02-02 Donal K. Fellows <dkf@users.sf.net> * generic/tclVar.c (Tcl_ArrayObjCmd): [Bug 2939073]: Stop the [array diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5f4a5a2..0e0333f 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.12 2009/08/26 02:26:14 dgp Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.146.2.13 2010/02/02 20:51:46 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1003,6 +1003,8 @@ TclInitCompileEnv( TclStackFree(interp, ctxPtr); } + envPtr->extCmdMapPtr->start = envPtr->line; + /* * Initialize the data about invisible continuation lines as empty, * i.e. not used. The caller (TclSetByteCodeFromAny) will set this up, if diff --git a/generic/tclCompile.h b/generic/tclCompile.h index a86e8f1..cb036c5 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.90.2.7 2009/08/25 21:01:05 andreas_kupries Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.90.2.8 2010/02/02 20:51:47 andreas_kupries Exp $ */ #ifndef _TCLCOMPILATION @@ -139,6 +139,10 @@ typedef struct ECL { typedef struct ExtCmdLoc { int type; /* Context type. */ + int start; /* Starting line for compiled script. Needed + * for the extended recompile check in + * TclCompEvalObj. */ + Tcl_Obj *path; /* Path of the sourced file the command is * in. */ ECL *loc; /* Command word locations (lines). */ diff --git a/generic/tclExecute.c b/generic/tclExecute.c index 7974db5..cf26e87 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -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: tclExecute.c,v 1.369.2.12 2009/07/14 16:33:12 andreas_kupries Exp $ + * RCS: @(#) $Id: tclExecute.c,v 1.369.2.13 2010/02/02 20:51:47 andreas_kupries Exp $ */ #include "tclInt.h" @@ -1441,6 +1441,98 @@ TclCompEvalObj( } /* + * #280. + * Literal sharing fix. This part of the fix is not required by 8.4 + * because it eval-directs any literals, so just saving the argument + * locations per command in bytecode is enough, embedded 'eval' + * commands, etc. get the correct information. + * + * It had be backported for 8.5 because we can force the separate + * compiling of a literal (in a proc body) by putting it into a control + * command with dynamic pieces, and then such literal may be shared + * and require their line-information to be reset, as for 8.6, as + * described below. + * + * In 8.6 all the embedded script are compiled, and the resulting + * bytecode stored in the literal. Now the shared literal has bytecode + * with location data for _one_ particular location this literal is + * found at. If we get executed from a different location the bytecode + * has to be recompiled to get the correct locations. Not doing this + * will execute the saved bytecode with data for a different location, + * causing 'info frame' to point to the wrong place in the sources. + * + * Future optimizations ... + * (1) Save the location data (ExtCmdLoc) keyed by start line. In that + * case we recompile once per location of the literal, but not + * continously, because the moment we have all locations we do not + * need to recompile any longer. + * + * (2) Alternative: Do not recompile, tell the execution engine the + * offset between saved starting line and actual one. Then modify + * the users to adjust the locations they have by this offset. + * + * (3) Alternative 2: Do not fully recompile, adjust just the location + * information. + */ + + { + Tcl_HashEntry *hePtr = + Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr); + + if (hePtr) { + ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); + int redo = 0; + + if (invoker) { + CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame)); + *ctxPtr = *invoker; + + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr used instead + */ + + TclGetSrcInfoForPc(ctxPtr); + if (ctxPtr->type == TCL_LOCATION_SOURCE) { + /* + * The reference made by 'TclGetSrcInfoForPc' is + * dead. + */ + + Tcl_DecrRefCount(ctxPtr->data.eval.path); + ctxPtr->data.eval.path = NULL; + } + } + + if (word < ctxPtr->nline) { + /* + * Note: We do not care if the line[word] is -1. This + * is a difference and requires a recompile (location + * changed from absolute to relative, literal is used + * fixed and through variable) + * + * Example: + * test info-32.0 using literal of info-24.8 + * (dict with ... vs set body ...). + */ + + redo = ((eclPtr->type == TCL_LOCATION_SOURCE) + && (eclPtr->start != ctxPtr->line[word])) + || ((eclPtr->type == TCL_LOCATION_BC) + && (ctxPtr->type == TCL_LOCATION_SOURCE)); + } + + TclStackFree(interp, ctxPtr); + } + + if (redo) { + goto recompileObj; + } + } + } + + /* * Increment the code's ref count while it is being executed. If * afterwards no references to it remain, free the code. */ diff --git a/tests/info.test b/tests/info.test index 5c0478c..0196162 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.10 2009/11/09 22:36:39 dgp Exp $ +# RCS: @(#) $Id: info.test,v 1.47.2.11 2010/02/02 20:51:47 andreas_kupries Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -1702,6 +1702,46 @@ type source line 1689 file info.test cmd {info frame 0} proc ::a level 0 type source line 1693 file info.test cmd {info frame 0} proc ::a level 0} # ------------------------------------------------------------------------- +# literal sharing 2, bug 2933089 + +test info-39.1 {location information not confused by literal sharing, bug 2933089} -setup { + set result {} + + proc print_one {} {} + proc test_info_frame {} { + set x 1 + set y x + + if "$x != 1" { + } else { + print_one + } ;#line 1717^ + + if "$$y != 1" { + } else { + print_one + } ;#line 1722^ + # Do not put the comments listing the line numbers into the + # branches. We need shared literals, and the comments would + # them different, thus unshared. + } + + proc get_frame_info { cmd_str op } { + lappend ::result [reduce [eval {info frame 9}]] + } + trace add execution print_one enter get_frame_info +} -body { + test_info_frame; + join $result \n +} -cleanup { + trace remove execution print_one enter get_frame_info + rename get_frame_info {} + rename test_info_frame {} + rename print_one {} +} -result {type source line 1717 file info.test cmd print_one proc ::test_info_frame level 1 +type source line 1722 file info.test cmd print_one proc ::test_info_frame level 1} + +# ------------------------------------------------------------------------- # cleanup catch {namespace delete test_ns_info1 test_ns_info2} |