summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorandreas_kupries <akupries@shaw.ca>2008-07-22 21:40:03 (GMT)
committerandreas_kupries <akupries@shaw.ca>2008-07-22 21:40:03 (GMT)
commit1a2015301662b5c0554f2f7ccfef588da923588b (patch)
treecef9d19da7d093c66b64a11ba40714de761a2840
parentc24d3516daee359922217e9267ba9e0e8aad1ce0 (diff)
downloadtcl-1a2015301662b5c0554f2f7ccfef588da923588b.zip
tcl-1a2015301662b5c0554f2f7ccfef588da923588b.tar.gz
tcl-1a2015301662b5c0554f2f7ccfef588da923588b.tar.bz2
* 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].
-rw-r--r--ChangeLog11
-rw-r--r--generic/tclBasic.c137
-rw-r--r--generic/tclCompile.c43
-rw-r--r--generic/tclCompile.h10
-rw-r--r--generic/tclExecute.c7
-rw-r--r--generic/tclInt.h20
6 files changed, 169 insertions, 59 deletions
diff --git a/ChangeLog b/ChangeLog
index 53267af..6803811 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-21 Andreas Kupries <andreask@activestate.com>
* generic/tclBasic.c: Extended the existing TIP #280 system (info
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 4ad59c7..6ec5763 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.29 2008/07/21 19:37:40 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclBasic.c,v 1.75.2.30 2008/07/22 21:40:24 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -361,9 +361,11 @@ Tcl_CreateInterp()
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);
#endif
iPtr->activeVarTracePtr = NULL;
@@ -1226,6 +1228,19 @@ DeleteInterpProc(interp)
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;
}
#endif
ckfree((char *) iPtr);
@@ -4413,7 +4428,82 @@ TclArgumentRelease(interp,objv,objc)
Tcl_DeleteHashEntry (hPtr);
}
}
+
+
+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 */
+}
+
/*
*----------------------------------------------------------------------
*
@@ -4457,43 +4547,20 @@ TclArgumentGet(interp,obj,cfPtrPtr,wordPtr)
}
/*
- * 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 = 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;
}
}
#endif
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index d8e22e2..a1747ba 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.9 2008/07/21 19:37:43 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.43.2.10 2008/07/22 21:40:26 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -702,8 +702,6 @@ TclCleanupByteCode(codePtr)
if (hePtr) {
ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
int i;
- Tcl_HashSearch hSearch;
- Tcl_HashEntry *hlPtr;
if (eclPtr->type == TCL_LOCATION_SOURCE) {
Tcl_DecrRefCount (eclPtr->path);
@@ -717,14 +715,10 @@ TclCleanupByteCode(codePtr)
}
/* 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);
}
@@ -817,7 +811,9 @@ TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
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) {
/* Initialize the compiler for relative counting */
@@ -2496,15 +2492,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 ++;
}
#endif
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 8192aa4..adde52c 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.3 2008/07/21 19:37:43 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.33.2.4 2008/07/22 21:40:31 andreas_kupries Exp $
*/
#ifndef _TCLCOMPILATION
@@ -146,12 +146,10 @@ 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 the command in ExtCmdLoc.loc[.] */
- int word; /* Index of word in ExtCmdLoc.loc[cmd]->line[.] */
-} ExtIndex;
EXTERN void TclEnterCmdWordIndex _ANSI_ARGS_((
ExtCmdLoc *eclPtr, Tcl_Obj* obj, int pc, int word));
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index b94785d..7d0eb11 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.25 2008/04/14 16:25:49 dgp Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.94.2.26 2008/07/22 21:40:31 andreas_kupries Exp $
*/
#include "tclInt.h"
@@ -1245,6 +1245,8 @@ 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
@@ -4514,6 +4516,9 @@ TclExecuteByteCode(interp, codePtr)
ckfree((char *) catchStackPtr);
}
eePtr->stackTop = initStackTop;
+
+ TclArgumentBCRelease((Tcl_Interp*) iPtr,codePtr);
+
return result;
#undef STATIC_CATCH_STACK_SIZE
}
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 18f1c70..7de3d01 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.31 2008/07/21 19:37:43 andreas_kupries Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.118.2.32 2008/07/22 21:40:32 andreas_kupries Exp $
*/
#ifndef _TCLINT
@@ -916,6 +916,19 @@ typedef struct CFWord {
int word; /* Index of the word in the command */
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;
#endif /* TCL_TIP280 */
/*
@@ -1505,6 +1518,7 @@ typedef struct Interp {
* values are "struct ExtCmdLoc*" (See
* tclCompile.h).
*/
+ Tcl_HashTable* lineLABCPtr;
Tcl_HashTable* lineLAPtr;
/* This table remembers for each
* argument of a command on the
@@ -1858,6 +1872,10 @@ EXTERN void TclArgumentEnter _ANSI_ARGS_((Tcl_Interp* interp,
Tcl_Obj* objv[], int objc, CmdFrame* cf));
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));
+EXTERN void TclArgumentBCRelease _ANSI_ARGS_((Tcl_Interp* interp,
+ void* codePtr));
EXTERN void TclArgumentGet _ANSI_ARGS_((Tcl_Interp* interp, Tcl_Obj* obj,
CmdFrame** cfPtrPtr, int* wordPtr));