* 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.

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}