* generic/tclBasic.c (DeleteInterpProc,TclArgumentBCEnter,

	TclArgumentBCRelease, TclArgumentGet):
	* generic/tclCompile.c (EnterCmdWordIndex, TclCleanupByteCode,
	TclInitCompileEnv, TclCompileScript):
	* generic/tclCompile.h (ExtCmdLoc):
	* generic/tclExecute.c (TclExecuteByteCode):
	* generic/tclInt.h (ExtIndex, CFWordBC):
	* tests/info.test (info-39.0):

	Backport of some changes made to the Tcl head, to handle literal
	sharing better. The code here is much simpler (trimmed down)
	compared to the head as the 8.5 branch is not bytecode compiling
	whole files, and doesn't compile eval'd code either.

	Reworked the handling of literal command arguments in bytecode to
	be saved (compiler) and used (execution) per command (See the
	TCL_INVOKE_STK* instructions), and not per the whole bytecode.
	This removes the problems with location data caused by literal
	sharing in proc bodies. Simplified the associated datastructures
	(ExtIndex is gone, as is the function EnterCmdWordIndex).

7 files changed, 163 insertions, 124 deletions

diff --git a/ChangeLog b/ChangeLog
index 90e401e..2382491 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,26 @@
+2009-07-14  Andreas Kupries  <andreask@activestate.com>
+
+	* generic/tclBasic.c (DeleteInterpProc,TclArgumentBCEnter,
+	TclArgumentBCRelease, TclArgumentGet):
+	* generic/tclCompile.c (EnterCmdWordIndex, TclCleanupByteCode,
+	TclInitCompileEnv, TclCompileScript):
+	* generic/tclCompile.h (ExtCmdLoc): 
+	* generic/tclExecute.c (TclExecuteByteCode):
+	* generic/tclInt.h (ExtIndex, CFWordBC):
+	* tests/info.test (info-39.0):
+
+	Backport of some changes made to the Tcl head, to handle literal
+	sharing better. The code here is much simpler (trimmed down)
+	compared to the head as the 8.5 branch is not bytecode compiling
+	whole files, and doesn't compile eval'd code either.
+	
+	Reworked the handling of literal command arguments in bytecode to
+	be saved (compiler) and used (execution) per command (See the
+	TCL_INVOKE_STK* instructions), and not per the whole bytecode.
+	This removes the problems with location data caused by literal
+	sharing in proc bodies. Simplified the associated datastructures
+	(ExtIndex is gone, as is the function EnterCmdWordIndex).
+
 2009-07-01  Pat Thoyts  <patthoyts@users.sourceforge.net>
 
 	* win/tclWinInt.h:   Handle the GetUserName API call via the
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9a159be..8ce2527 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.9 2008/08/14 02:12:06 das Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.295.2.10 2009/07/14 16:33:12 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -1409,9 +1409,7 @@ DeleteInterpProc(
 		ckfree((char *) eclPtr->loc);
 	    }
 
-	    if (eclPtr->eiloc != NULL) {
-		ckfree((char *) eclPtr->eiloc);
-	    }
+	    Tcl_DeleteHashTable (&eclPtr->litInfo);
 
 	    ckfree((char *) eclPtr);
 	    Tcl_DeleteHashEntry(hPtr);
@@ -4626,46 +4624,68 @@ TclArgumentRelease(interp,objv,objc)
  */
 
 void
-TclArgumentBCEnter(interp,codePtr,cfPtr)
+TclArgumentBCEnter(interp,objv,objc,codePtr,cfPtr,pc)
      Tcl_Interp* interp;
+     Tcl_Obj*    objv[];
+     int         objc;
      void*       codePtr;
      CmdFrame*   cfPtr;
+     int         pc;
 {
     Interp*        iPtr  = (Interp*) interp;
     Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
 
     if (hePtr) {
 	ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
-	int i;
+	hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc);
 
-	for (i=0; i < eclPtr->nueiloc; i++) {
+	if (hePtr) {
+	    int  cmd  = (int) Tcl_GetHashValue(hePtr);
+	    ECL* ePtr = &eclPtr->loc[cmd];
+	    int word;
 
-	    ExtIndex* eiPtr = &eclPtr->eiloc[i];
-	    Tcl_Obj*  obj   = eiPtr->obj;
-	    int new;
-	    Tcl_HashEntry*  hPtr;
-	    CFWordBC* cfwPtr;
+	    /*
+	     * A few truths ...
+	     * (1) ePtr->nline == objc
+	     * (2) (ePtr->line[word] < 0) => !literal, for all words
+	     * (3) (word == 0) => !literal
+	     *
+	     * Item (2) is why we can use objv to get the literals, and do not
+	     * have to save them at compile time.
+	     */
 
-	    hPtr = Tcl_CreateHashEntry (iPtr->lineLABCPtr, (char*) obj, &new);
-	    if (new) {
-		/*
-		 * The word is not on the stack yet, remember the current location
-		 * and initialize references.
-		 */
-		cfwPtr = (CFWordBC*) ckalloc (sizeof (CFWordBC));
-		cfwPtr->framePtr = cfPtr;
-		cfwPtr->eiPtr    = eiPtr;
-		cfwPtr->refCount = 1;
-		Tcl_SetHashValue (hPtr, cfwPtr);
-	    } else {
-		/*
-		 * The word is already on the stack, its current location is not
-		 * relevant. Just remember the reference to prevent early removal.
-		 */
-		cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
-		cfwPtr->refCount ++;
-	    }
-	} /* for */
+	    for (word = 1; word < objc; word++) {
+		if (ePtr->line[word] >= 0) {
+		    int isnew;
+		    Tcl_HashEntry* hPtr =
+			Tcl_CreateHashEntry (iPtr->lineLABCPtr,
+					     (char*) objv[word], &isnew);
+		    CFWordBC* cfwPtr = (CFWordBC*) ckalloc (sizeof (CFWordBC));
+
+		    cfwPtr->framePtr = cfPtr;
+		    cfwPtr->pc       = pc;
+		    cfwPtr->word     = word;
+
+		    if (isnew) {
+			/*
+			 * The word is not on the stack yet, remember the
+			 * current location and initialize references.
+			 */
+			cfwPtr->prevPtr = NULL;
+		    } else {
+			/*
+			 * The object is already on the stack, however it may
+			 * have a different location now (literal sharing may
+			 * map multiple location to a single Tcl_Obj*. Save
+			 * the old information in the new structure.
+			 */
+			cfwPtr->prevPtr = (CFWordBC*) Tcl_GetHashValue(hPtr);
+		    }
+
+		    Tcl_SetHashValue (hPtr, cfwPtr);
+		}
+	    } /* for */
+	} /* if */
     } /* if */
 }
 
@@ -4690,33 +4710,48 @@ TclArgumentBCEnter(interp,codePtr,cfPtr)
  */
 
 void
-TclArgumentBCRelease(interp,codePtr)
+TclArgumentBCRelease(interp,objv,objc,codePtr,pc)
      Tcl_Interp* interp;
+     Tcl_Obj*    objv[];
+     int         objc;
      void*       codePtr;
+     int         pc;
 {
     Interp*        iPtr  = (Interp*) interp;
     Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
 
     if (hePtr) {
 	ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
-	int i;
+	hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc);
 
-	for (i=0; i < eclPtr->nueiloc; i++) {
-	    Tcl_Obj*       obj  = eclPtr->eiloc[i].obj;
-	    Tcl_HashEntry* hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj);
-	    CFWordBC* cfwPtr;
+	if (hePtr) {
+	    int  cmd  = (int) Tcl_GetHashValue(hePtr);
+	    ECL* ePtr = &eclPtr->loc[cmd];
+	    int word;
 
-	    if (!hPtr) { continue; }
-
-	    cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
-
-	    cfwPtr->refCount --;
-	    if (cfwPtr->refCount > 0) { continue; }
+	    /*
+	     * Iterate in reverse order, to properly match our pop to the push
+	     * in TclArgumentBCEnter().
+	     */
+	    for (word = objc-1; word >= 1; word--) {
+		if (ePtr->line[word] >= 0) {
+		    Tcl_HashEntry* hPtr = Tcl_FindHashEntry(iPtr->lineLABCPtr,
+						    (char *) objv[word]);
+		    if (hPtr) {
+			CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
+ 
+			if (cfwPtr->prevPtr) {
+			    Tcl_SetHashValue(hPtr, cfwPtr->prevPtr);
+			} else {
+			    Tcl_DeleteHashEntry(hPtr);
+			}
 
-	    ckfree ((char*) cfwPtr);
-	    Tcl_DeleteHashEntry (hPtr);
-	} /* for */
-    } /* if */
+			ckfree((char *) cfwPtr);
+		    }
+		}
+	    }
+	}
+    }
 }
 
 /*
@@ -4779,15 +4814,15 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr)
      */
 
     hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj);
+
     if (hPtr) {
 	CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
-	ExtIndex* eiPtr = cfwPtr->eiPtr;
 
 	framePtr = cfwPtr->framePtr;
 	framePtr->data.tebc.pc = (char *) (((ByteCode*)
-		framePtr->data.tebc.codePtr)->codeStart + eiPtr->pc);
+		framePtr->data.tebc.codePtr)->codeStart + cfwPtr->pc);
 	*cfPtrPtr = cfwPtr->framePtr;
-	*wordPtr  = eiPtr->word;
+	*wordPtr  = cfwPtr->word;
 	return;
     }
 }
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index c7b311b..e671fcf 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.7 2009/06/13 14:25:12 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.146.2.8 2009/07/14 16:33:12 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -414,9 +414,6 @@ static void		EnterCmdExtentData(CompileEnv *envPtr,
 			    int cmdNumber, int numSrcBytes, int numCodeBytes);
 static void		EnterCmdStartData(CompileEnv *envPtr,
 			    int cmdNumber, int srcOffset, int codeOffset);
-
-static void             EnterCmdWordIndex (ExtCmdLoc *eclPtr, Tcl_Obj* obj,
-			    int pc, int word);
 static void		FreeByteCodeInternalRep(Tcl_Obj *objPtr);
 static int		GetCmdLocEncodingSize(CompileEnv *envPtr);
 #ifdef TCL_COMPILE_STATS
@@ -817,10 +814,7 @@ TclCleanupByteCode(
 		ckfree((char *) eclPtr->loc);
 	    }
 
-	    /* Release index of literals as well. */
-	    if (eclPtr->eiloc != NULL) {
-		ckfree((char *) eclPtr->eiloc);
-	    }
+	    Tcl_DeleteHashTable (&eclPtr->litInfo);
 
 	    ckfree((char *) eclPtr);
 	    Tcl_DeleteHashEntry(hePtr);
@@ -912,9 +906,7 @@ TclInitCompileEnv(
     envPtr->extCmdMapPtr->nloc = 0;
     envPtr->extCmdMapPtr->nuloc = 0;
     envPtr->extCmdMapPtr->path = NULL;
-    envPtr->extCmdMapPtr->eiloc = NULL;
-    envPtr->extCmdMapPtr->neiloc = 0;
-    envPtr->extCmdMapPtr->nueiloc = 0;
+    Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS);
 
     if (invoker == NULL ||
 	(invoker->type == TCL_LOCATION_EVAL_LIST)) {
@@ -1473,13 +1465,6 @@ TclCompileScript(
 		     */
 		    objIndex = TclRegisterNewLiteral(envPtr,
 			    tokenPtr[1].start, tokenPtr[1].size);
-
-		    if (eclPtr->type == TCL_LOCATION_SOURCE) {
-			EnterCmdWordIndex (eclPtr,
-					   envPtr->literalArrayPtr[objIndex].objPtr,
-					   envPtr->codeNext - envPtr->codeStart,
-					   wordIdx);
-		    }
 		}
 		TclEmitPush(objIndex, envPtr);
 	    } /* for loop */
@@ -1509,6 +1494,15 @@ TclCompileScript(
 		TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
 		TclAdjustStackDepth((1-wordIdx), envPtr);
 	    } else if (wordIdx > 0) {
+		/*
+		 * Save PC -> command map for the TclArgumentBC* functions.
+		 */
+
+		int isnew;
+		Tcl_HashEntry* hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo,
+			   (char*) (envPtr->codeNext - envPtr->codeStart), &isnew);
+		Tcl_SetHashValue(hePtr, (char*) wlineat);
+
 		if (wordIdx <= 255) {
 		    TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
 		} else {
@@ -2448,39 +2442,6 @@ EnterCmdWordData(
     eclPtr->nuloc ++;
 }
 
-static void
-EnterCmdWordIndex (
-     ExtCmdLoc *eclPtr,
-     Tcl_Obj*   obj,
-     int        pc,
-     int        word)
-{
-    ExtIndex* eiPtr;
-
-    if (eclPtr->nueiloc >= eclPtr->neiloc) {
-	/*
-	 * Expand the ExtIndex array by allocating more storage from the heap. The
-	 * currently allocated ECL entries are stored from eclPtr->loc[0] up
-	 * to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
-	 */
-
-	size_t currElems = eclPtr->neiloc;
-	size_t newElems = (currElems ? 2*currElems : 1);
-	size_t newBytes = newElems * sizeof(ExtIndex);
-
-	eclPtr->eiloc = (ExtIndex *) ckrealloc((char *)(eclPtr->eiloc), newBytes);
-	eclPtr->neiloc = newElems;
-    }
-
-    eiPtr = &eclPtr->eiloc[eclPtr->nueiloc];
-
-    eiPtr->obj  = obj;
-    eiPtr->pc   = pc;
-    eiPtr->word = word;
-
-    eclPtr->nueiloc ++;
-}
-
 /*
  *----------------------------------------------------------------------
  *
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 1e32569..2eb8489 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.5 2008/08/14 02:22:15 das Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.90.2.6 2009/07/14 16:33:12 andreas_kupries Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -141,9 +141,13 @@ typedef struct ExtCmdLoc {
     ECL *loc;			/* Command word locations (lines). */
     int nloc;			/* Number of allocated entries in 'loc'. */
     int nuloc;			/* Number of used entries in 'loc'. */
-    ExtIndex* eiloc;
-    int neiloc;
-    int nueiloc;
+    Tcl_HashTable litInfo;      /* Indexed by bytecode 'PC', to have the
+				 * information accessible per command and
+				 * argument, not per whole bytecode. Value is
+				 * index of command in 'loc', giving us the
+				 * literals to associate with line information
+				 * as command argument, see
+				 * TclArgumentBCEnter() */
 } ExtCmdLoc;
 
 /*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index a63508e..7974db5 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.11 2009/07/01 15:29:48 patthoyts Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.369.2.12 2009/07/14 16:33:12 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -1730,8 +1730,6 @@ TclExecuteByteCode(
     bcFramePtr->cmd.str.cmd = NULL;
     bcFramePtr->cmd.str.len = 0;
 
-    TclArgumentBCEnter((Tcl_Interp*) iPtr,codePtr,bcFramePtr);
-
 #ifdef TCL_COMPILE_DEBUG
     if (tclTraceExec >= 2) {
 	PrintByteCodeInfo(codePtr);
@@ -2322,10 +2320,16 @@ TclExecuteByteCode(
 
 	    bcFramePtr->data.tebc.pc = (char *) pc;
 	    iPtr->cmdFramePtr = bcFramePtr;
+	    TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc,
+			       codePtr, bcFramePtr,
+			       pc - codePtr->codeStart);
 	    DECACHE_STACK_INFO();
 	    result = TclEvalObjvInternal(interp, objc, objv,
 		    /* call from TEBC */(char *) -1, -1, 0);
 	    CACHE_STACK_INFO();
+	    TclArgumentBCRelease((Tcl_Interp*) iPtr, objv, objc,
+				 codePtr,
+				 pc - codePtr->codeStart);
 	    iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
 
 	    if (result == TCL_OK) {
@@ -7401,8 +7405,6 @@ TclExecuteByteCode(
 	}
     }
 
-    TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr);
-
     /*
      * Restore the stack to the state it had previous to this bytecode.
      */
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 5d7e6ab..b7e34c9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -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: tclInt.h,v 1.362.2.6 2009/04/27 21:45:20 ferrieux Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.362.2.7 2009/07/14 16:33:12 andreas_kupries Exp $
  */
 
 #ifndef _TCLINT
@@ -1147,17 +1147,11 @@ typedef struct CFWord {
     int       refCount;  /* #times the word is on the stack */
 } CFWord;
 
-typedef struct ExtIndex {
-    Tcl_Obj* obj; /* Reference to the word */
-    int pc;   /* Instruction pointer of a command in ExtCmdLoc.loc[.] */
-    int word; /* Index of word in ExtCmdLoc.loc[cmd]->line[.] */
-} ExtIndex;
-
-
 typedef struct CFWordBC {
     CmdFrame* framePtr;  /* CmdFrame to acess */
-    ExtIndex* eiPtr;     /* Word info: PC and index */
-    int       refCount;  /* #times the word is on the stack */
+    int pc;   /* Instruction pointer of a command in ExtCmdLoc.loc[.] */
+    int word; /* Index of word in ExtCmdLoc.loc[cmd]->line[.] */
+    struct CFWordBC* prevPtr;
 } CFWordBC;
 
 /*
@@ -2472,9 +2466,11 @@ MODULE_SCOPE void       TclArgumentRelease(Tcl_Interp* interp,
 MODULE_SCOPE void       TclArgumentGet(Tcl_Interp* interp, Tcl_Obj* obj,
 			    CmdFrame** cfPtrPtr, int* wordPtr);
 MODULE_SCOPE void       TclArgumentBCEnter(Tcl_Interp* interp,
-			    void* codePtr, CmdFrame* cfPtr);
+			    Tcl_Obj* objv[], int objc,
+			    void* codePtr, CmdFrame* cfPtr, int pc);
 MODULE_SCOPE void       TclArgumentBCRelease(Tcl_Interp* interp,
-			    void* codePtr);
+			    Tcl_Obj* objv[], int objc,
+			    void* codePtr, int pc);
 MODULE_SCOPE int	TclArraySet(Tcl_Interp *interp,
 			    Tcl_Obj *arrayNameObj, Tcl_Obj *arrayElemObj);
 MODULE_SCOPE double	TclBignumToDouble(mp_int *bignum);
diff --git a/tests/info.test b/tests/info.test
index f450809..5e1e43d 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.7 2008/10/14 18:16:42 dgp Exp $
+# RCS: @(#) $Id: info.test,v 1.47.2.8 2009/07/14 16:33:12 andreas_kupries Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -1411,6 +1411,24 @@ test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -match
 * {type source line 1406 file info.test cmd datal proc ::tcltest::RunTest}}
 
 # -------------------------------------------------------------------------
+# literal sharing
+
+test info-39.0 {location information not confused by literal sharing} -body {
+    namespace eval ::foo {}
+    proc ::foo::bar {} {
+	lappend res {}
+	lappend res [reduce [eval {info frame 0}]]
+	lappend res [reduce [eval {info frame 0}]]
+	return $res
+    }
+    set res [::foo::bar]
+    namespace delete ::foo
+    join $res \n
+} -result {
+type source line 1420 file info.test cmd {info frame 0} proc ::foo::bar level 0
+type source line 1421 file info.test cmd {info frame 0} proc ::foo::bar level 0}
+
+# -------------------------------------------------------------------------
 
 # cleanup
 catch {namespace delete test_ns_info1 test_ns_info2}