summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog23
-rw-r--r--generic/tclBasic.c137
-rw-r--r--generic/tclCompile.c63
-rw-r--r--generic/tclCompile.h12
-rw-r--r--generic/tclExecute.c12
-rw-r--r--generic/tclInt.h20
-rw-r--r--tests/info.test20
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}
generated by cgit v0.12 at 2024-11-10 11:47:54 (GMT)