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

5 files changed, 127 insertions, 131 deletions

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index dbdcd7c..78bc47f 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.75.2.34 2008/08/14 02:12:25 das Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.75.2.35 2009/07/14 16:31:48 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -50,7 +50,6 @@ static int            EvalEx _ANSI_ARGS_((Tcl_Interp *interp, CONST char *script
 static int            EvalTokensStandard _ANSI_ARGS_((Tcl_Interp *interp,
 						      Tcl_Token *tokenPtr,
 						      int count, int line));
-
 #endif
 
 #ifdef USE_DTRACE
@@ -1202,9 +1201,7 @@ DeleteInterpProc(interp)
 		ckfree ((char*) eclPtr->loc);
 	    }
 
-            if (eclPtr->eiloc != NULL) {
-		ckfree ((char*) eclPtr->eiloc);
-	    }
+	    Tcl_DeleteHashTable (&eclPtr->litInfo);
 
 	    ckfree ((char*) eclPtr);
 	    Tcl_DeleteHashEntry (hPtr);
@@ -4454,46 +4451,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  word;
+	    int  cmd  = (int) Tcl_GetHashValue(hePtr);
+	    ECL* ePtr = &eclPtr->loc[cmd];
 
-	    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 */
 }
 
@@ -4518,33 +4537,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;
-
-	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 (!hPtr) { continue; }
-
-	    cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
+	hePtr = Tcl_FindHashEntry(&eclPtr->litInfo, (char*) pc);
 
-	    cfwPtr->refCount --;
-	    if (cfwPtr->refCount > 0) { continue; }
+	if (hePtr) {
+	    int  cmd  = (int) Tcl_GetHashValue(hePtr);
+	    ECL* ePtr = &eclPtr->loc[cmd];
+	    int word;
 
-	    ckfree ((char*) cfwPtr);
-	    Tcl_DeleteHashEntry (hPtr);
-	} /* for */
-    } /* if */
+	    /*
+	     * 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);
+		    }
+		}
+	    }
+	}
+    }
 }
 
 /*
@@ -4608,12 +4642,12 @@ 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 = ((ByteCode*) framePtr->data.tebc.codePtr)->codeStart + eiPtr->pc;
+	framePtr->data.tebc.pc = ((ByteCode*)
+		  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 98ccc50..b6d486e 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.43.2.14 2009/06/13 14:38:44 dgp Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.43.2.15 2009/07/14 16:31:49 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -308,9 +308,6 @@ static void		EnterCmdWordData _ANSI_ARGS_((
     			    ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token* tokenPtr,
 			    CONST char* cmd, int len, int numWords, int line,
 			    int** lines));
-
-static void		EnterCmdWordIndex _ANSI_ARGS_((
-    			    ExtCmdLoc *eclPtr, Tcl_Obj* obj, int pc, int word));
 #endif
 
 
@@ -709,7 +706,7 @@ TclCleanupByteCode(codePtr)
 	    if (eclPtr->type == TCL_LOCATION_SOURCE) {
 		Tcl_DecrRefCount (eclPtr->path);
 	    }
-	    for (i=0; i< eclPtr->nuloc; i++) {
+	    for (i=0; i < eclPtr->nuloc; i++) {
 		ckfree ((char*) eclPtr->loc[i].line);
 	    }
 
@@ -717,10 +714,7 @@ TclCleanupByteCode(codePtr)
 		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);
@@ -815,9 +809,7 @@ TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
     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)) {
@@ -1276,14 +1268,6 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
 
 			objIndex = TclRegisterNewLiteral(envPtr,
 				tokenPtr[1].start, tokenPtr[1].size);
-#ifdef TCL_TIP280
-			if (eclPtr->type == TCL_LOCATION_SOURCE) {
-			    EnterCmdWordIndex (eclPtr,
-					       envPtr->literalArrayPtr[objIndex].objPtr,
-					       envPtr->codeNext - envPtr->codeStart,
-					       wordIdx);
-			}
-#endif
 		    }
 		    TclEmitPush(objIndex, envPtr);
 		} else {
@@ -1304,6 +1288,16 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
 	     */
 	    
 	    if (wordIdx > 0) {
+#ifdef TCL_TIP280
+		/*
+		 * 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);
+#endif
 		if (wordIdx <= 255) {
 		    TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
 		} else {
@@ -1326,7 +1320,7 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
 	     * the reduced form now
 	     */
 	    ckfree ((char*) eclPtr->loc [wlineat].line);
-	    eclPtr->loc [wlineat].line = wlines;
+	    eclPtr->loc [wlineat].line    = wlines;
 #endif
 	} /* end if parse.numWords > 0 */
 
@@ -2462,7 +2456,7 @@ EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, wlines)
 	size_t currBytes = currElems * sizeof(ECL);
 	size_t newBytes  = newElems  * sizeof(ECL);
 	ECL *  newPtr    = (ECL *) ckalloc((unsigned) newBytes);
-	
+
 	/*
 	 * Copy from old ECL array to new, free old ECL array if
 	 * needed.
@@ -2500,39 +2494,6 @@ EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, wlines)
     *wlines = wwlines;
     eclPtr->nuloc ++;
 }
-
-static void
-EnterCmdWordIndex (eclPtr, obj, pc, word)
-     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 ++;
-}
 #endif
 
 /*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 69b0c82..b3431f8 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.33.2.6 2008/08/14 02:12:27 das Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.33.2.7 2009/07/14 16:31:49 andreas_kupries Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -140,15 +140,20 @@ typedef struct ECL {
   int  nline;     /* Number of words in the command */
   int* line;      /* line information for all words in the command */
 } ECL;
+
 typedef struct ExtCmdLoc {
   int      type;  /* Context type */
   Tcl_Obj* path;  /* Path of the sourced file the command is in */
   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;
 #endif
 
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 065024c..8dcf877 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.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: tclExecute.c,v 1.94.2.28 2009/03/20 14:22:54 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.94.2.29 2009/07/14 16:31:49 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -1245,8 +1245,6 @@ TclExecuteByteCode(interp, codePtr)
     bcFrame.data.tebc.pc       = NULL;
     bcFrame.cmd.str.cmd        = NULL;
     bcFrame.cmd.str.len        = 0;
-
-    TclArgumentBCEnter((Tcl_Interp*) iPtr,codePtr,&bcFrame);
 #endif
 
 #ifdef TCL_COMPILE_DEBUG
@@ -1584,12 +1582,18 @@ TclExecuteByteCode(interp, codePtr)
 #ifdef TCL_TIP280
 	    bcFrame.data.tebc.pc = pc;
 	    iPtr->cmdFramePtr = &bcFrame;
+	    TclArgumentBCEnter((Tcl_Interp*) iPtr, objv, objc,
+			       codePtr, &bcFrame,
+			       pc - codePtr->codeStart);
 #endif
 	    DECACHE_STACK_INFO();
 	    Tcl_ResetResult(interp);
 	    result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
 	    CACHE_STACK_INFO();
 #ifdef TCL_TIP280
+	    TclArgumentBCRelease((Tcl_Interp*) iPtr,  objv, objc,
+				 codePtr,
+				 pc - codePtr->codeStart);
 	    iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
 #endif
 
@@ -4523,10 +4527,6 @@ TclExecuteByteCode(interp, codePtr)
     }
     eePtr->stackTop = initStackTop;
 
-#ifdef TCL_TIP280
-    TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr);
-#endif
-
     return result;
 #undef STATIC_CATCH_STACK_SIZE
 }
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 43870e7..fc56e6e 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.118.2.33 2009/04/27 22:10:28 ferrieux Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.118.2.34 2009/07/14 16:31:49 andreas_kupries Exp $
  */
 
 #ifndef _TCLINT
@@ -917,17 +917,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,literal}[.] */
+    struct CFWordBC* prevPtr;
 } CFWordBC;
 #endif /* TCL_TIP280 */
 
@@ -1873,9 +1867,11 @@ EXTERN void TclArgumentEnter   _ANSI_ARGS_((Tcl_Interp* interp,
 EXTERN void TclArgumentRelease _ANSI_ARGS_((Tcl_Interp* interp,
 					    Tcl_Obj* objv[], int objc));
 EXTERN void TclArgumentBCEnter _ANSI_ARGS_((Tcl_Interp* interp,
-					    void* codePtr, CmdFrame* cfPtr));
+					    Tcl_Obj* objv[], int objc,
+					    void* codePtr, CmdFrame* cfPtr, int pc));
 EXTERN void TclArgumentBCRelease _ANSI_ARGS_((Tcl_Interp* interp,
-					      void* codePtr));
+					      Tcl_Obj* objv[], int objc,
+					      void* codePtr, int pc));
 
 EXTERN void TclArgumentGet     _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj,
 					    CmdFrame** cfPtrPtr, int* wordPtr));