* generic/tclBasic.c: Reworked the handling of bytecode literals

	* generic/tclCompile.c: for #280 to fix the abysmal performance
	* generic/tclCompile.h: for deep recursion, replaced the linear
	* generic/tclExecute.c: search through the whole stack with
	* generic/tclInt.h: another hashtable and simplified the data
	structure used by the compiler (array instead of hashtable).
	Incidentially this also fixes the memory leak reported via [Bug
	2024937].

6 files changed, 171 insertions, 63 deletions

diff --git a/ChangeLog b/ChangeLog
index 6d06add..57158b1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2008-07-22  Andreas Kupries  <andreask@activestate.com>
+
+	* generic/tclBasic.c: Reworked the handling of bytecode literals
+	* generic/tclCompile.c: for #280 to fix the abysmal performance
+	* generic/tclCompile.h: for deep recursion, replaced the linear
+	* generic/tclExecute.c: search through the whole stack with
+	* generic/tclInt.h: another hashtable and simplified the data
+	structure used by the compiler (array instead of hashtable).
+	Incidentially this also fixes the memory leak reported via [Bug
+	2024937].
+
 2008-07-22  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclBasic.c:    Added numLevels field to CommandFrame, 
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index f7c667a..18a9857 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -16,7 +16,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.324 2008/07/22 21:02:27 msofer Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.325 2008/07/22 21:41:49 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -498,9 +498,11 @@ Tcl_CreateInterp(void)
     iPtr->linePBodyPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
     iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
     iPtr->lineLAPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
+    iPtr->lineLABCPtr = (Tcl_HashTable*) ckalloc (sizeof (Tcl_HashTable));
     Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
     Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
     Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
+    Tcl_InitHashTable(iPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
 
     iPtr->activeVarTracePtr = NULL;
 
@@ -1539,6 +1541,19 @@ DeleteInterpProc(
 	Tcl_DeleteHashTable(iPtr->lineLAPtr);
 	ckfree((char*) iPtr->lineLAPtr);
 	iPtr->lineLAPtr = NULL;
+
+	if (iPtr->lineLABCPtr->numEntries) {
+	    /*
+	     * When the interp goes away we have nothing on the stack, so
+	     * there are no arguments, so this table has to be empty.
+	     */
+
+	    Tcl_Panic ("Argument location tracking table not empty");
+	}
+
+	Tcl_DeleteHashTable (iPtr->lineLABCPtr);
+	ckfree((char*) iPtr->lineLABCPtr);
+	iPtr->lineLABCPtr = NULL;
     }
 
     Tcl_DeleteHashTable(&iPtr->varTraces);
@@ -5359,6 +5374,81 @@ TclArgumentRelease(
     }
 }
 
+
+void
+TclArgumentBCEnter(interp,codePtr,cfPtr)
+     Tcl_Interp* interp;
+     void*       codePtr;
+     CmdFrame*   cfPtr;
+{
+    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++) {
+
+	    ExtIndex* eiPtr = &eclPtr->eiloc[i];
+	    Tcl_Obj*  obj   = eiPtr->obj;
+	    int new;
+	    Tcl_HashEntry*  hPtr;
+	    CFWordBC* cfwPtr;
+
+	    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 */
+    } /* if */
+}
+
+void
+TclArgumentBCRelease(interp,codePtr)
+     Tcl_Interp* interp;
+     void*       codePtr;
+{
+    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);
+
+	    cfwPtr->refCount --;
+	    if (cfwPtr->refCount > 0) { continue; }
+
+	    ckfree ((char*) cfwPtr);
+	    Tcl_DeleteHashEntry (hPtr);
+	} /* for */
+    } /* if */
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -5403,46 +5493,20 @@ TclArgumentGet(
     }
 
     /*
-     * Check if the Tcl_Obj has location information as a bytecode literal. We
-     * have to scan the stack up and check all bytecode frames for a possible
-     * definition.
+     * Check if the Tcl_Obj has location information as a bytecode literal, in
+     * that stack.
      */
 
-    for (framePtr = iPtr->cmdFramePtr; framePtr;
-	    framePtr = framePtr->nextPtr) {
-	const ByteCode *codePtr;
-	Tcl_HashEntry *hePtr;
-
-	if (framePtr->type != TCL_LOCATION_BC) {
-	    continue;
-	}
-
-	codePtr = framePtr->data.tebc.codePtr;
-	hePtr   = Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
-
-	if (hePtr) {
-	    ExtCmdLoc *eclPtr = (ExtCmdLoc*) Tcl_GetHashValue(hePtr);
-	    Tcl_HashEntry *hlPtr = Tcl_FindHashEntry(&eclPtr->litIndex,
-		    (char *) obj);
-
-	    if (hlPtr) {
-		/*
-		 * Convert from the current invoker CmdFrame to a CmdFrame
-		 * refering to the actual word location. We are directly
-		 * manipulating the relevant command frame in the frame stack.
-		 * That is no problem because TEBC is already setting the pc
-		 * for each invokation, so moving it somewhere will not affect
-		 * the following commands.
-		 */
-
-		ExtIndex *eiPtr = (ExtIndex*) Tcl_GetHashValue(hlPtr);
+    hPtr = Tcl_FindHashEntry (iPtr->lineLABCPtr, (char *) obj);
+    if (hPtr) {
+	CFWordBC* cfwPtr = (CFWordBC*) Tcl_GetHashValue (hPtr);
+	ExtIndex* eiPtr = cfwPtr->eiPtr;
 
-		framePtr->data.tebc.pc = (char *) (codePtr->codeStart +
-			eiPtr->pc);
-		*cfPtrPtr = framePtr;
-		*wordPtr  = eiPtr->word;
-	    }
-	}
+	framePtr = cfwPtr->framePtr;
+	framePtr->data.tebc.pc = ((ByteCode*) framePtr->data.tebc.codePtr)->codeStart + eiPtr->pc;
+	*cfPtrPtr = cfwPtr->framePtr;
+	*wordPtr  = eiPtr->word;
+	return;
     }
 }
 
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 88d8b86..79a9313 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.150 2008/07/21 22:50:34 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.151 2008/07/22 21:41:51 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -801,8 +801,6 @@ TclCleanupByteCode(
 	if (hePtr) {
 	    ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
 	    int i;
-	    Tcl_HashSearch hSearch;
-	    Tcl_HashEntry *hlPtr;
 
 	    if (eclPtr->type == TCL_LOCATION_SOURCE) {
 		Tcl_DecrRefCount(eclPtr->path);
@@ -816,14 +814,10 @@ TclCleanupByteCode(
 	    }
 
 	    /* Release index of literals as well. */
-	    for (hlPtr = Tcl_FirstHashEntry(&eclPtr->litIndex, &hSearch);
-		 hlPtr != NULL;
-		 hlPtr = Tcl_NextHashEntry(&hSearch)) {
-		ExtIndex* eiPtr = (ExtIndex*) Tcl_GetHashValue (hlPtr);
-		ckfree((char*) eiPtr);
-		Tcl_DeleteHashEntry (hlPtr);
+	    if (eclPtr->eiloc != NULL) {
+		ckfree((char *) eclPtr->eiloc);
 	    }
-	    Tcl_DeleteHashTable (&eclPtr->litIndex);
+
 	    ckfree((char *) eclPtr);
 	    Tcl_DeleteHashEntry(hePtr);
 	}
@@ -913,7 +907,9 @@ TclInitCompileEnv(
     envPtr->extCmdMapPtr->nloc = 0;
     envPtr->extCmdMapPtr->nuloc = 0;
     envPtr->extCmdMapPtr->path = NULL;
-    Tcl_InitHashTable(&envPtr->extCmdMapPtr->litIndex, TCL_ONE_WORD_KEYS);
+    envPtr->extCmdMapPtr->eiloc = NULL;
+    envPtr->extCmdMapPtr->neiloc = 0;
+    envPtr->extCmdMapPtr->nueiloc = 0;
 
     if (invoker == NULL) {
         /*
@@ -2476,15 +2472,30 @@ TclEnterCmdWordIndex (eclPtr, obj, pc, word)
      int        pc;
      int        word;
 {
-    int       new;
-    ExtIndex* eiPtr = (ExtIndex*) ckalloc (sizeof (ExtIndex));
+    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;
 
-    Tcl_SetHashValue (Tcl_CreateHashEntry (&eclPtr->litIndex,
-					   (char*) obj, &new),
-		      eiPtr);
+    eclPtr->nueiloc ++;
 }
 
 /*
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index a27bbd9..ec3cbbf 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.94 2008/07/21 22:50:34 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.95 2008/07/22 21:41:55 andreas_kupries Exp $
  */
 
 #ifndef _TCLCOMPILATION
@@ -134,6 +134,8 @@ typedef struct ECL {
 				 * command. */
 } ECL;
 
+/* ExtIndex defined in tclInt.h */
+
 typedef struct ExtCmdLoc {
     int type;			/* Context type. */
     Tcl_Obj *path;		/* Path of the sourced file the command is
@@ -141,14 +143,11 @@ 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'. */
-    Tcl_HashTable litIndex;     /* HashValue is ExtIndex* */
+    ExtIndex* eiloc;
+    int neiloc;
+    int nueiloc;
 } ExtCmdLoc;
 
-typedef struct ExtIndex {
-  int pc;   /* Instruction pointer of a command in ExtCmdLoc.loc[.] */
-  int word; /* Index of word in ExtCmdLoc.loc[cmd]->line[.] */
-} ExtIndex;
-
 EXTERN void TclEnterCmdWordIndex (ExtCmdLoc *eclPtr, Tcl_Obj* obj,
 				  int pc, int word);
 
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index b26d77e..0102f5a 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.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: tclExecute.c,v 1.386 2008/07/22 21:02:28 msofer Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.387 2008/07/22 21:41:55 andreas_kupries Exp $
  */
 
 #include "tclInt.h"
@@ -1877,6 +1877,9 @@ TclExecuteByteCode(
 	bcFramePtr->data.tebc.pc = NULL;
 	bcFramePtr->cmd.str.cmd = NULL;
 	bcFramePtr->cmd.str.len = 0;
+
+	TclArgumentBCEnter((Tcl_Interp*) iPtr,codePtr,bcFramePtr);
+
 #if (USE_NR_TEBC)
     } else if (tailcall) {
 	    goto tailcallEntry;	    
@@ -7757,6 +7760,8 @@ TclExecuteByteCode(
 	}
     }
 
+    TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr);
+
 #if USE_NR_TEBC
     oldBottomPtr = bottomPtr->prevBottomPtr;
 #endif
diff --git a/generic/tclInt.h b/generic/tclInt.h
index dad62a8..7566e24 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -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: tclInt.h,v 1.377 2008/07/22 21:02:30 msofer Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.378 2008/07/22 21:41:55 andreas_kupries Exp $
  */
 
 #ifndef _TCLINT
@@ -1158,6 +1158,19 @@ 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 */
+} CFWordBC;
+
 /*
  * The following macros define the allowed values for the type field of the
  * CmdFrame structure above. Some of the values occur only in the extended
@@ -1877,6 +1890,7 @@ typedef struct Interp {
 				 * body. It is keyed by the address of the
 				 * Proc structure for a procedure. The values
 				 * are "struct ExtCmdLoc*" (See tclCompile.h) */
+    Tcl_HashTable* lineLABCPtr;
     Tcl_HashTable* lineLAPtr;   /* This table remembers for each argument of a
 				 * command on the execution stack the index of
 				 * the argument in the command, and the
@@ -2513,6 +2527,10 @@ MODULE_SCOPE void       TclArgumentEnter(Tcl_Interp* interp,
 			    Tcl_Obj* objv[], int objc, CmdFrame* cf);
 MODULE_SCOPE void       TclArgumentRelease(Tcl_Interp* interp,
 			    Tcl_Obj* objv[], int objc);
+MODULE_SCOPE void       TclArgumentBCEnter(Tcl_Interp* interp,
+			    void* codePtr, CmdFrame* cfPtr);
+MODULE_SCOPE void       TclArgumentBCRelease(Tcl_Interp* interp,
+			    void* codePtr);
 MODULE_SCOPE void       TclArgumentGet(Tcl_Interp* interp, Tcl_Obj* obj,
 			    CmdFrame** cfPtrPtr, int* wordPtr);
 MODULE_SCOPE int	TclArraySet(Tcl_Interp *interp,