summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog7
-rw-r--r--generic/tclCompile.c4
-rw-r--r--generic/tclCompile.h6
-rw-r--r--generic/tclExecute.c94
-rw-r--r--tests/info.test42
5 files changed, 149 insertions, 4 deletions
diff --git a/ChangeLog b/ChangeLog
index 7c87350..83b65a0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -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}