summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--ChangeLog23
-rw-r--r--generic/tclBasic.c140
-rw-r--r--generic/tclCompile.c71
-rw-r--r--generic/tclCompile.h13
-rw-r--r--generic/tclExecute.c14
-rw-r--r--generic/tclInt.h20
-rw-r--r--tests/info.test20
7 files changed, 169 insertions, 132 deletions
diff --git a/ChangeLog b/ChangeLog
index ad05f98..d2abbe5 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.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).
+
2009-06-13 Don Porter <dgp@users.sourceforge.net>
* generic/tclCompile.c: The value stashed in iPtr->compiledProcPtr
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));
diff --git a/tests/info.test b/tests/info.test
index b30a4be..b655e30 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.24.2.11 2008/07/28 20:01:12 andreas_kupries Exp $
+# RCS: @(#) $Id: info.test,v 1.24.2.12 2009/07/14 16:31:49 andreas_kupries Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -1205,6 +1205,24 @@ test info-38.6 {location information for uplevel, ppl, proc-proc-literal} -const
* {type source line 1200 file info.test cmd datal proc ::tcltest::RunTest}}
# -------------------------------------------------------------------------
+# literal sharing
+
+test info-39.0 {location information not confused by literal sharing} -constraints tip280 -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 1214 file info.test cmd {info frame 0} proc ::foo::bar level 0
+type source line 1215 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-05 15:24:45 (GMT)