summaryrefslogtreecommitdiffstats
path: root/generic/tclExecute.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclExecute.c')
-rw-r--r--generic/tclExecute.c304
1 files changed, 63 insertions, 241 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 1d3a825..c244b08 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -34,14 +34,14 @@
#endif
/*
- * A mask (should be 2**n-1) that is used to work out when the bytecode engine
- * should call Tcl_AsyncReady() to see whether there is a signal that needs
- * handling.
+ * A counter that is used to work out when the bytecode engine should call
+ * Tcl_AsyncReady() to see whether there is a signal that needs handling, and
+ * other expensive periodic operations.
*/
-#ifndef ASYNC_CHECK_COUNT_MASK
-# define ASYNC_CHECK_COUNT_MASK 63
-#endif /* !ASYNC_CHECK_COUNT_MASK */
+#ifndef ASYNC_CHECK_COUNT
+# define ASYNC_CHECK_COUNT 64
+#endif /* !ASYNC_CHECK_COUNT */
/*
* Boolean flag indicating whether the Tcl bytecode interpreter has been
@@ -325,7 +325,7 @@ VarHashCreateVar(
NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -346,7 +346,7 @@ VarHashCreateVar(
NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
default: \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -357,7 +357,7 @@ VarHashCreateVar(
#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -366,7 +366,7 @@ VarHashCreateVar(
#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
do{ \
if ((condition) < 0) { \
- TclNewIntObj(objResultPtr, -1); \
+ TclNewLongObj(objResultPtr, -1); \
} else { \
objResultPtr = TCONST((condition) > 0); \
} \
@@ -512,7 +512,7 @@ VarHashCreateVar(
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
- ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
+ ? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
#else /* !TCL_WIDE_INT_IS_LONG */
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
@@ -532,7 +532,7 @@ VarHashCreateVar(
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
- ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
+ ? TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
#endif /* TCL_WIDE_INT_IS_LONG */
@@ -1274,7 +1274,7 @@ TclStackFree(
Tcl_Obj **markerPtr, *marker;
if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
- ckfree((char *) freePtr);
+ ckfree(freePtr);
return;
}
@@ -1498,11 +1498,9 @@ ExprObjCallback(
*
* Results:
* A (ByteCode *) is returned pointing to the resulting ByteCode.
- * The caller must manage its refCount and arrange for a call to
- * TclCleanupByteCode() when the last reference disappears.
*
* Side effects:
- * The Tcl_ObjType of objPtr is changed to the "bytecode" type,
+ * The Tcl_ObjType of objPtr is changed to the "exprcode" type,
* and the ByteCode is kept in the internal rep (along with context
* data for checking validity) for faster operations the next time
* CompileExprObj is called on the same value.
@@ -1535,7 +1533,7 @@ CompileExprObj(
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
|| (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)) {
- FreeExprCodeInternalRep(objPtr);
+ TclFreeIntRep(objPtr);
}
}
if (objPtr->typePtr != &exprCodeType) {
@@ -1543,11 +1541,10 @@ CompileExprObj(
* TIP #280: No invoker (yet) - Expression compilation.
*/
- int length;
- const char *string = TclGetStringFromObj(objPtr, &length);
+ const char *string = TclGetString(objPtr);
- TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
- TclCompileExpr(interp, string, length, &compEnv, 0);
+ TclInitCompileEnv(interp, &compEnv, string, objPtr->length, NULL, 0);
+ TclCompileExpr(interp, string, objPtr->length, &compEnv, 0);
/*
* Successful compilation. If the expression yielded no instructions,
@@ -1555,7 +1552,7 @@ CompileExprObj(
*/
if (compEnv.codeNext == compEnv.codeStart) {
- TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1),
+ TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, 0),
&compEnv);
}
@@ -1566,10 +1563,8 @@ CompileExprObj(
*/
TclEmitOpcode(INST_DONE, &compEnv);
- TclInitByteCodeObj(objPtr, &compEnv);
- objPtr->typePtr = &exprCodeType;
+ codePtr = TclInitByteCodeObj(objPtr, &exprCodeType, &compEnv);
TclFreeCompileEnv(&compEnv);
- codePtr = objPtr->internalRep.twoPtrValue.ptr1;
if (iPtr->varFramePtr->localCachePtr) {
codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
codePtr->localCachePtr->refCount++;
@@ -1643,10 +1638,7 @@ FreeExprCodeInternalRep(
{
ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1;
- objPtr->typePtr = NULL;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
}
/*
@@ -2032,7 +2024,7 @@ TclNRExecuteByteCode(
* sizeof(void *);
int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
- codePtr->refCount++;
+ TclPreserveByteCode(codePtr);
/*
* Reserve the stack, setup the TEBCdataPtr (TD) and CallFrame
@@ -2121,8 +2113,14 @@ TEBCresume(
* sporadically: no special need for speed.
*/
- int instructionCount = 0; /* Counter that is used to work out when to
- * call Tcl_AsyncReady() */
+ unsigned interruptCounter = 1;
+ /* Counter that is used to work out when to
+ * call Tcl_AsyncReady(). This must be 1
+ * initially so that we call the async-check
+ * stanza early, otherwise there are command
+ * sequences that can make the interpreter
+ * busy-loop without an opportunity to
+ * recognise an interrupt. */
const char *curInstName;
#ifdef TCL_COMPILE_DEBUG
int traceInstructions; /* Whether we are doing instruction-level
@@ -2320,10 +2318,11 @@ TEBCresume(
/*
* Check for asynchronous handlers [Bug 746722]; we do the check every
- * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).
+ * ASYNC_CHECK_COUNT instructions.
*/
- if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
+ if ((--interruptCounter) == 0) {
+ interruptCounter = ASYNC_CHECK_COUNT;
DECACHE_STACK_INFO();
if (TclAsyncReady(iPtr)) {
result = Tcl_AsyncInvoke(interp, result);
@@ -2537,7 +2536,7 @@ TEBCresume(
/* FIXME: What is the right thing to trace? */
fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
- Tcl_GetString(valuePtr));
+ TclGetString(valuePtr));
}
fflush(stdout);
}
@@ -2684,154 +2683,18 @@ TEBCresume(
NEXT_INST_F(5, 0, 0);
}
- case INST_STR_CONCAT1: {
- int appendLen = 0;
- char *bytes, *p;
- Tcl_Obj **currPtr;
- int onlyb = 1;
+ case INST_STR_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
- /*
- * Detect only-bytearray-or-null case.
- */
-
- for (currPtr=&OBJ_AT_DEPTH(opnd-1); currPtr<=&OBJ_AT_TOS; currPtr++) {
- if (((*currPtr)->typePtr != &tclByteArrayType)
- && ((*currPtr)->bytes != tclEmptyStringRep)) {
- onlyb = 0;
- break;
- } else if (((*currPtr)->typePtr == &tclByteArrayType) &&
- ((*currPtr)->bytes != NULL)) {
- onlyb = 0;
- break;
- }
- }
-
- /*
- * Compute the length to be appended.
- */
-
- if (onlyb) {
- for (currPtr = &OBJ_AT_DEPTH(opnd-2);
- appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
- if ((*currPtr)->bytes != tclEmptyStringRep) {
- Tcl_GetByteArrayFromObj(*currPtr, &length);
- appendLen += length;
- }
- }
- } else {
- for (currPtr = &OBJ_AT_DEPTH(opnd-2);
- appendLen >= 0 && currPtr <= &OBJ_AT_TOS; currPtr++) {
- bytes = TclGetStringFromObj(*currPtr, &length);
- if (bytes != NULL) {
- appendLen += length;
- }
- }
- }
-
- if (appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
- }
-
- /*
- * If nothing is to be appended, just return the first object by
- * dropping all the others from the stack; this saves both the
- * computation and copy of the string rep of the first object,
- * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'.
- */
-
- if (appendLen == 0) {
- TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
- NEXT_INST_V(2, (opnd-1), 0);
- }
-
- /*
- * If the first object is shared, we need a new obj for the result;
- * otherwise, we can reuse the first object. In any case, make sure it
- * has enough room to accomodate all the concatenated bytes. Note that
- * if it is unshared its bytes are copied by ckrealloc, so that we set
- * the loop parameters to avoid copying them again: p points to the
- * end of the already copied bytes, currPtr to the second object.
- */
-
- objResultPtr = OBJ_AT_DEPTH(opnd-1);
- if (!onlyb) {
- bytes = TclGetStringFromObj(objResultPtr, &length);
- if (length + appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
- INT_MAX);
- }
-#ifndef TCL_COMPILE_DEBUG
- if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
- TclFreeIntRep(objResultPtr);
- objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1);
- objResultPtr->length = length + appendLen;
- p = TclGetString(objResultPtr) + length;
- currPtr = &OBJ_AT_DEPTH(opnd - 2);
- } else
-#endif
- {
- p = ckalloc(length + appendLen + 1);
- TclNewObj(objResultPtr);
- objResultPtr->bytes = p;
- objResultPtr->length = length + appendLen;
- currPtr = &OBJ_AT_DEPTH(opnd - 1);
- }
-
- /*
- * Append the remaining characters.
- */
-
- for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
- bytes = TclGetStringFromObj(*currPtr, &length);
- if (bytes != NULL) {
- memcpy(p, bytes, (size_t) length);
- p += length;
- }
- }
- *p = '\0';
- } else {
- bytes = (char *) Tcl_GetByteArrayFromObj(objResultPtr, &length);
- if (length + appendLen < 0) {
- /* TODO: convert panic to error ? */
- Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
- INT_MAX);
- }
-#ifndef TCL_COMPILE_DEBUG
- if (!Tcl_IsShared(objResultPtr)) {
- bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
- length + appendLen);
- p = bytes + length;
- currPtr = &OBJ_AT_DEPTH(opnd - 2);
- } else
-#endif
- {
- TclNewObj(objResultPtr);
- bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
- length + appendLen);
- p = bytes;
- currPtr = &OBJ_AT_DEPTH(opnd - 1);
- }
-
- /*
- * Append the remaining characters.
- */
-
- for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
- if ((*currPtr)->bytes != tclEmptyStringRep) {
- bytes = (char *) Tcl_GetByteArrayFromObj(*currPtr,&length);
- memcpy(p, bytes, (size_t) length);
- p += length;
- }
- }
+ if (TCL_OK != TclStringCatObjv(interp, /* inPlace */ 1,
+ opnd, &OBJ_AT_DEPTH(opnd-1), &objResultPtr)) {
+ TRACE_ERROR(interp);
+ goto gotError;
}
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
- }
case INST_CONCAT_STK:
/*
@@ -4665,7 +4528,7 @@ TEBCresume(
NEXT_INST_F(1, 0, 1);
}
case INST_INFO_LEVEL_NUM:
- TclNewIntObj(objResultPtr, iPtr->varFramePtr->level);
+ TclNewLongObj(objResultPtr, iPtr->varFramePtr->level);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_INFO_LEVEL_ARGS: {
@@ -5034,7 +4897,7 @@ TEBCresume(
TRACE_ERROR(interp);
goto gotError;
}
- TclNewIntObj(objResultPtr, length);
+ TclNewLongObj(objResultPtr, length);
TRACE_APPEND(("%d\n", length));
NEXT_INST_F(1, 1, 1);
@@ -5282,23 +5145,10 @@ TEBCresume(
toIdx = objc-1;
}
if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) {
- /*
- * BEWARE! This is looking inside the implementation of the
- * list type.
- */
-
- List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1;
-
- if (listPtr->refCount == 1) {
- for (index=toIdx+1; index<objc ; index++) {
- TclDecrRefCount(objv[index]);
- }
- listPtr->elemCount = toIdx+1;
- listPtr->canonicalFlag = 1;
- TclInvalidateStringRep(valuePtr);
- TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
- NEXT_INST_F(9, 0, 0);
- }
+ Tcl_ListObjReplace(interp, valuePtr,
+ toIdx + 1, LIST_MAX, 0, NULL);
+ TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
+ NEXT_INST_F(9, 0, 0);
}
objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
} else {
@@ -5518,7 +5368,7 @@ TEBCresume(
case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
length = Tcl_GetCharLength(valuePtr);
- TclNewIntObj(objResultPtr, length);
+ TclNewLongObj(objResultPtr, length);
TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
@@ -5869,45 +5719,19 @@ TEBCresume(
NEXT_INST_V(1, 3, 1);
case INST_STR_FIND:
- ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
- ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
-
- match = -1;
- if (length2 > 0 && length2 <= length) {
- end = ustring1 + length - length2 + 1;
- for (p=ustring1 ; p<end ; p++) {
- if ((*p == *ustring2) &&
- memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
- match = p - ustring1;
- break;
- }
- }
- }
+ match = TclStringFind(OBJ_UNDER_TOS, OBJ_AT_TOS, 0);
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
- TclNewIntObj(objResultPtr, match);
+ TclNewLongObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
case INST_STR_FIND_LAST:
- ustring1 = Tcl_GetUnicodeFromObj(OBJ_AT_TOS, &length); /* Haystack */
- ustring2 = Tcl_GetUnicodeFromObj(OBJ_UNDER_TOS, &length2);/* Needle */
-
- match = -1;
- if (length2 > 0 && length2 <= length) {
- for (p=ustring1+length-length2 ; p>=ustring1 ; p--) {
- if ((*p == *ustring2) &&
- memcmp(ustring2,p,sizeof(Tcl_UniChar)*length2) == 0) {
- match = p - ustring1;
- break;
- }
- }
- }
+ match = TclStringLast(OBJ_UNDER_TOS, OBJ_AT_TOS, INT_MAX - 1);
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
-
- TclNewIntObj(objResultPtr, match);
+ TclNewLongObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
case INST_STR_CLASS:
@@ -6111,7 +5935,7 @@ TEBCresume(
type1 = TCL_NUMBER_WIDE;
}
}
- TclNewIntObj(objResultPtr, type1);
+ TclNewLongObj(objResultPtr, type1);
TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
NEXT_INST_F(1, 1, 1);
@@ -6304,7 +6128,7 @@ TEBCresume(
if (l1 > 0L) {
objResultPtr = TCONST(0);
} else {
- TclNewIntObj(objResultPtr, -1);
+ TclNewLongObj(objResultPtr, -1);
}
TRACE(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
@@ -7204,7 +7028,7 @@ TEBCresume(
NEXT_INST_F(1, 0, -1);
case INST_PUSH_RETURN_CODE:
- TclNewIntObj(objResultPtr, result);
+ TclNewLongObj(objResultPtr, result);
TRACE(("=> %u\n", result));
NEXT_INST_F(1, 0, 1);
@@ -8128,9 +7952,7 @@ TEBCresume(
}
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
- if (codePtr->refCount-- <= 1) {
- TclCleanupByteCode(codePtr);
- }
+ TclReleaseByteCode(codePtr);
TclStackFree(interp, TD); /* free my stack */
return result;
@@ -9098,7 +8920,7 @@ ExecuteExtendedBinaryMathOp(
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
mp_init(&bigResult);
- mp_expt_d(&big1, big2.dp[0], &bigResult);
+ mp_expt_d_ex(&big1, big2.dp[0], &bigResult, 1);
mp_clear(&big1);
mp_clear(&big2);
BIG_RESULT(&bigResult);
@@ -9622,9 +9444,9 @@ PrintByteCodeInfo(
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
- fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
- codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
- iPtr->compileEpoch);
+ fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %" TCL_LL_MODIFIER "u, epoch %" TCL_LL_MODIFIER "u, interp 0x%p (epoch %" TCL_LL_MODIFIER "u)\n",
+ codePtr, (Tcl_WideInt)codePtr->refCount, (Tcl_WideInt)codePtr->compileEpoch, iPtr,
+ (Tcl_WideInt)iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
@@ -9721,7 +9543,7 @@ ValidatePcAndStackTop(
TclNewLiteralStringObj(message, "\n executing ");
Tcl_IncrRefCount(message);
Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL);
- fprintf(stderr,"%s\n", Tcl_GetString(message));
+ fprintf(stderr,"%s\n", TclGetString(message));
Tcl_DecrRefCount(message);
} else {
fprintf(stderr, "\n");
@@ -9771,7 +9593,7 @@ IllegalExprOperandType(
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
int numBytes;
- const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
+ const char *bytes = TclGetStringFromObj(opndPtr, &numBytes);
if (numBytes == 0) {
description = "empty string";
@@ -10184,7 +10006,7 @@ TclExprFloatError(
"unknown floating-point error, errno = %d", errno);
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN",
- Tcl_GetString(objPtr), NULL);
+ TclGetString(objPtr), NULL);
Tcl_SetObjResult(interp, objPtr);
}
}
@@ -10400,7 +10222,7 @@ EvalStatsCmd(
if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
numByteCodeLits++;
}
- (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
+ (void) TclGetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
strBytesIfUnshared += (entryPtr->refCount * (length+1));
@@ -10622,7 +10444,7 @@ EvalStatsCmd(
Tcl_SetObjResult(interp, objPtr);
} else {
Tcl_Channel outChan;
- char *str = Tcl_GetStringFromObj(objv[1], &length);
+ char *str = TclGetStringFromObj(objv[1], &length);
if (length) {
if (strcmp(str, "stdout") == 0) {