summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
authorMiguel Sofer <miguel.sofer@gmail.com>2004-12-10 13:09:07 (GMT)
committerMiguel Sofer <miguel.sofer@gmail.com>2004-12-10 13:09:07 (GMT)
commit624c39990f6db4c1318669baef61b8521e063a54 (patch)
tree979c2273d05fafbb74a038762775ac289c222445
parent38a95a62dcb1fc490f1d0b553eff6a0ddd209bb4 (diff)
downloadtcl-624c39990f6db4c1318669baef61b8521e063a54.zip
tcl-624c39990f6db4c1318669baef61b8521e063a54.tar.gz
tcl-624c39990f6db4c1318669baef61b8521e063a54.tar.bz2
optimised loops that initialise a proc's arguments and compiled local
variables, removing tests from inner loops.
-rw-r--r--ChangeLog8
-rw-r--r--generic/tclCompile.c147
-rw-r--r--generic/tclCompile.h10
-rw-r--r--generic/tclInt.h3
-rw-r--r--generic/tclProc.c116
5 files changed, 170 insertions, 114 deletions
diff --git a/ChangeLog b/ChangeLog
index fd6bdf6..d92ea0a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2004-12-10 Miguel Sofer <msofer@users.sf.net>
+ * generic/tclCompile.c (TclInitCompiledLocals):
+ * generic/tclCompile.h:
+ * generic/tclInt.h:
+ * generic/tclProc.c (TclObjInterpProc, TclCreateProc): optimised
+ loops that initialise a proc's arguments and compiled local
+ variables, removing tests from inner loops.
+
2004-12-10 Donal K. Fellows <dkf@users.sf.net>
* generic/tclInt.h: Move ensemble API decls here from tclNamesp.c
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 11383b7..a79d1ef 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.78 2004/10/08 15:39:52 dkf Exp $
+ * RCS: @(#) $Id: tclCompile.c,v 1.79 2004/12/10 13:09:13 msofer Exp $
*/
#include "tclInt.h"
@@ -1666,7 +1666,11 @@ TclInitByteCodeObj(objPtr, envPtr)
codePtr->nsPtr = namespacePtr;
codePtr->nsEpoch = namespacePtr->resolverEpoch;
codePtr->refCount = 1;
- codePtr->flags = 0;
+ if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) {
+ codePtr->flags = TCL_BYTECODE_RESOLVE_VARS;
+ } else {
+ codePtr->flags = 0;
+ }
codePtr->source = envPtr->source;
codePtr->procPtr = envPtr->procPtr;
@@ -1867,80 +1871,105 @@ TclInitCompiledLocals(interp, framePtr, nsPtr)
{
register CompiledLocal *localPtr;
Interp *iPtr = (Interp*) interp;
- Tcl_ResolvedVarInfo *vinfo, *resVarInfo;
+ Tcl_ResolvedVarInfo *resVarInfo;
Var *varPtr = framePtr->compiledLocals;
- Var *resolvedVarPtr;
- ResolverScheme *resPtr;
- int result;
-
- /*
- * Initialize the array of local variables stored in the call frame.
- * Some variables may have special resolution rules. In that case,
- * we call their "resolver" procs to get our hands on the variable,
- * and we make the compiled local a link to the real variable.
- */
-
- for (localPtr = framePtr->procPtr->firstLocalPtr;
- localPtr != NULL;
- localPtr = localPtr->nextPtr) {
+ int haveResolvers = (nsPtr->compiledVarResProc || iPtr->resolverPtr);
+ ByteCode *codePtr = (ByteCode *)
+ framePtr->procPtr->bodyPtr->internalRep.otherValuePtr;
+ if (codePtr->flags & TCL_BYTECODE_RESOLVE_VARS) {
+
/*
- * Check to see if this local is affected by namespace or
- * interp resolvers. The resolver to use is cached for the
- * next invocation of the procedure.
+ * This is the first run after a recompile, or else the resolver epoch
+ * has changed: update the resolver cache.
*/
- if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED))
- && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) {
- resPtr = iPtr->resolverPtr;
+ codePtr->flags &= ~TCL_BYTECODE_RESOLVE_VARS;
+
+ for (localPtr = framePtr->procPtr->firstLocalPtr; localPtr != NULL;
+ localPtr = localPtr->nextPtr) {
- if (nsPtr->compiledVarResProc) {
- result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
- localPtr->name, localPtr->nameLength,
- (Tcl_Namespace *) nsPtr, &vinfo);
- } else {
- result = TCL_CONTINUE;
+ if (localPtr->resolveInfo) {
+ if (localPtr->resolveInfo->deleteProc) {
+ localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
+ } else {
+ ckfree((char*)localPtr->resolveInfo);
+ }
+ localPtr->resolveInfo = NULL;
}
-
- while ((result == TCL_CONTINUE) && resPtr) {
- if (resPtr->compiledVarResProc) {
- result = (*resPtr->compiledVarResProc)(nsPtr->interp,
+ localPtr->flags &= ~VAR_RESOLVED;
+
+ if (haveResolvers &&
+ !(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY))) {
+ ResolverScheme *resPtr = iPtr->resolverPtr;
+ Tcl_ResolvedVarInfo *vinfo;
+ int result;
+
+ if (nsPtr->compiledVarResProc) {
+ result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
localPtr->name, localPtr->nameLength,
(Tcl_Namespace *) nsPtr, &vinfo);
+ } else {
+ result = TCL_CONTINUE;
}
- resPtr = resPtr->nextPtr;
- }
- if (result == TCL_OK) {
- localPtr->resolveInfo = vinfo;
- localPtr->flags |= VAR_RESOLVED;
- }
+
+ while ((result == TCL_CONTINUE) && resPtr) {
+ if (resPtr->compiledVarResProc) {
+ result = (*resPtr->compiledVarResProc)(nsPtr->interp,
+ localPtr->name, localPtr->nameLength,
+ (Tcl_Namespace *) nsPtr, &vinfo);
+ }
+ resPtr = resPtr->nextPtr;
+ }
+ if (result == TCL_OK) {
+ localPtr->resolveInfo = vinfo;
+ localPtr->flags |= VAR_RESOLVED;
+ }
+ }
}
+ }
- /*
- * Now invoke the resolvers to determine the exact variables that
- * should be used.
- */
-
- resVarInfo = localPtr->resolveInfo;
- resolvedVarPtr = NULL;
-
- if (resVarInfo && resVarInfo->fetchProc) {
- resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
- resVarInfo);
- }
+ /*
+ * Initialize the array of local variables stored in the call frame.
+ * Some variables may have special resolution rules. In that case,
+ * we call their "resolver" procs to get our hands on the variable,
+ * and we make the compiled local a link to the real variable.
+ */
- if (resolvedVarPtr) {
+ if (haveResolvers) {
+ for (localPtr = framePtr->procPtr->firstLocalPtr;
+ localPtr != NULL;
+ localPtr = localPtr->nextPtr) {
+ varPtr->value.objPtr = NULL;
varPtr->name = localPtr->name; /* will be just '\0' if temp var */
varPtr->nsPtr = NULL;
varPtr->hPtr = NULL;
varPtr->refCount = 0;
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
- varPtr->flags = 0;
- TclSetVarLink(varPtr);
- varPtr->value.linkPtr = resolvedVarPtr;
- resolvedVarPtr->refCount++;
- } else {
+ varPtr->flags = localPtr->flags;
+
+ /*
+ * Now invoke the resolvers to determine the exact variables that
+ * should be used.
+ */
+
+ resVarInfo = localPtr->resolveInfo;
+ if (resVarInfo && resVarInfo->fetchProc) {
+ Var *resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
+ resVarInfo);
+ if (resolvedVarPtr) {
+ resolvedVarPtr->refCount++;
+ varPtr->value.linkPtr = resolvedVarPtr;
+ varPtr->flags = VAR_LINK;
+ }
+ }
+ varPtr++;
+ }
+ } else {
+ for (localPtr = framePtr->procPtr->firstLocalPtr;
+ localPtr != NULL;
+ localPtr = localPtr->nextPtr) {
varPtr->value.objPtr = NULL;
varPtr->name = localPtr->name; /* will be just '\0' if temp var */
varPtr->nsPtr = NULL;
@@ -1949,8 +1978,8 @@ TclInitCompiledLocals(interp, framePtr, nsPtr)
varPtr->tracePtr = NULL;
varPtr->searchPtr = NULL;
varPtr->flags = localPtr->flags;
- }
- varPtr++;
+ varPtr++;
+ }
}
}
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index c950096..a50409b 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -8,7 +8,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.51 2004/11/03 21:20:30 davygrvy Exp $
+ * RCS: @(#) $Id: tclCompile.h,v 1.52 2004/12/10 13:09:14 msofer Exp $
*/
#ifndef _TCLCOMPILATION
@@ -273,6 +273,14 @@ typedef struct CompileEnv {
*/
#define TCL_BYTECODE_PRECOMPILED 0x0001
+
+/*
+ * When a bytecode is compiled, interp or namespace resolvers have not been
+ * applied yet: this is indicated by the TCL_BYTECODE_RESOLVE_VARS flag.
+ */
+
+#define TCL_BYTECODE_RESOLVE_VARS 0x0002
+
typedef struct ByteCode {
TclHandle interpHandle; /* Handle for interpreter containing the
* compiled code. Commands and their compile
diff --git a/generic/tclInt.h b/generic/tclInt.h
index c163c2b..11ddcf3 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -12,7 +12,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.204 2004/12/10 00:16:55 dkf Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.205 2004/12/10 13:09:14 msofer Exp $
*/
#ifndef _TCLINT
@@ -510,6 +510,7 @@ typedef struct Var {
#define VAR_ARGUMENT 0x100
#define VAR_TEMPORARY 0x200
#define VAR_RESOLVED 0x400
+#define VAR_IS_ARGS 0x800
/*
* Macros to ensure that various flag bits are set properly for variables.
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 6d46f81..5ae99c1 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -10,7 +10,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclProc.c,v 1.66 2004/11/25 16:37:15 dkf Exp $
+ * RCS: @(#) $Id: tclProc.c,v 1.67 2004/12/10 13:09:15 msofer Exp $
*/
#include "tclInt.h"
@@ -341,6 +341,7 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
procPtr->numArgs = numArgs;
procPtr->numCompiledLocals = numArgs;
}
+
for (i = 0; i < numArgs; i++) {
int fieldCount, nameLength, valueLength;
CONST char **fieldValues;
@@ -445,6 +446,12 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
ckfree((char *) fieldValues);
goto procError;
}
+ if ((i == numArgs - 1)
+ && (localPtr->nameLength == 4)
+ && (localPtr->name[0] == 'a')
+ && (strcmp(localPtr->name, "args") == 0)) {
+ localPtr->flags |= VAR_IS_ARGS;
+ }
}
localPtr = localPtr->nextPtr;
@@ -477,6 +484,12 @@ TclCreateProc(interp, nsPtr, procName, argsPtr, bodyPtr, procPtrPtr)
localPtr->defValuePtr = NULL;
}
strcpy(localPtr->name, fieldValues[0]);
+ if ((i == numArgs - 1)
+ && (localPtr->nameLength == 4)
+ && (localPtr->name[0] == 'a')
+ && (strcmp(localPtr->name, "args") == 0)) {
+ localPtr->flags |= VAR_IS_ARGS;
+ }
}
ckfree((char *) fieldValues);
@@ -910,7 +923,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
register Var *varPtr;
register CompiledLocal *localPtr;
char *procName;
- int nameLen, localCt, numArgs, argCt, i, result;
+ int nameLen, localCt, numArgs, argCt, i, imax, result;
/*
* This procedure generates an array "compiledLocals" that holds the
@@ -992,53 +1005,62 @@ TclObjInterpProc(clientData, interp, objc, objv)
numArgs = procPtr->numArgs;
varPtr = framePtr->compiledLocals;
localPtr = procPtr->firstLocalPtr;
- argCt = objc;
- for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) {
- if (!TclIsVarArgument(localPtr)) {
- Tcl_Panic("TclObjInterpProc: local variable %s is not argument but should be",
- localPtr->name);
- return TCL_ERROR;
- }
- if (TclIsVarTemporary(localPtr)) {
- Tcl_Panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i);
- return TCL_ERROR;
+ argCt = objc-1; /* set it to the number of args to the proc */
+ if (numArgs == 0) {
+ if (argCt) {
+ goto incorrectArgs;
+ } else {
+ goto runProc;
}
-
+ }
+ imax = ((argCt < numArgs - 1)? argCt : (numArgs - 1));
+ for (i = 1; i <= imax; i++) {
/*
- * Handle the special case of the last formal being "args". When
- * it occurs, assign it a list consisting of all the remaining
- * actual arguments.
+ * "Normal" arguments; last formal is special, depends on
+ * it being 'args'.
+ */
+ Tcl_Obj *objPtr = objv[i];
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* local var is a reference */
+ varPtr++;
+ localPtr = localPtr->nextPtr;
+ }
+ for (; i < numArgs; i++) {
+ /*
+ * This loop is entered if argCt < (numArgs-1).
+ * Set default values; last formal is special.
*/
-
- if ((i == numArgs) && ((localPtr->name[0] == 'a')
- && (strcmp(localPtr->name, "args") == 0))) {
- Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
- varPtr->value.objPtr = listPtr;
- Tcl_IncrRefCount(listPtr); /* local var is a reference */
- TclClearVarUndefined(varPtr);
- argCt = 0;
- break; /* done processing args */
- } else if (argCt > 0) {
- Tcl_Obj *objPtr = objv[i];
- varPtr->value.objPtr = objPtr;
- TclClearVarUndefined(varPtr);
- Tcl_IncrRefCount(objPtr); /* since the local variable now has
- * another reference to object. */
- } else if (localPtr->defValuePtr != NULL) {
+ if (localPtr->defValuePtr != NULL) {
Tcl_Obj *objPtr = localPtr->defValuePtr;
varPtr->value.objPtr = objPtr;
- TclClearVarUndefined(varPtr);
- Tcl_IncrRefCount(objPtr); /* since the local variable now has
- * another reference to object. */
+ Tcl_IncrRefCount(objPtr); /* local var is a reference */
+ varPtr++;
+ localPtr = localPtr->nextPtr;
} else {
goto incorrectArgs;
}
- varPtr++;
- localPtr = localPtr->nextPtr;
}
- if (argCt > 0) {
- Tcl_Obj **desiredObjs, *argObj;
+ /*
+ * When we get here, the last formal argument remains
+ * to be defined: localPtr and varPtr point to the last
+ * argument to be initialized.
+ */
+
+ if (localPtr->flags & VAR_IS_ARGS) {
+ Tcl_Obj *listPtr = Tcl_NewListObj(objc-numArgs, &(objv[numArgs]));
+ varPtr->value.objPtr = listPtr;
+ Tcl_IncrRefCount(listPtr); /* local var is a reference */
+ } else if (argCt == numArgs) {
+ Tcl_Obj *objPtr = objv[numArgs];
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* local var is a reference */
+ } else if ((argCt < numArgs) && (localPtr->defValuePtr != NULL)) {
+ Tcl_Obj *objPtr = localPtr->defValuePtr;
+ varPtr->value.objPtr = objPtr;
+ Tcl_IncrRefCount(objPtr); /* local var is a reference */
+ } else {
+ Tcl_Obj **desiredObjs, *argObj;
incorrectArgs:
/*
* Build up desired argument list for Tcl_WrongNumArgs
@@ -1087,6 +1109,7 @@ TclObjInterpProc(clientData, interp, objc, objv)
* Invoke the commands in the procedure's body.
*/
+ runProc:
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 1) {
fprintf(stdout, "Calling proc ");
@@ -1252,25 +1275,12 @@ TclProcCompileProc(interp, procPtr, bodyPtr, nsPtr, description, procName)
return result;
}
} else if (codePtr->nsEpoch != nsPtr->resolverEpoch) {
- register CompiledLocal *localPtr;
-
/*
* The resolver epoch has changed, but we only need to invalidate
* the resolver cache.
*/
- for (localPtr = procPtr->firstLocalPtr; localPtr != NULL;
- localPtr = localPtr->nextPtr) {
- localPtr->flags &= ~(VAR_RESOLVED);
- if (localPtr->resolveInfo) {
- if (localPtr->resolveInfo->deleteProc) {
- localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
- } else {
- ckfree((char*)localPtr->resolveInfo);
- }
- localPtr->resolveInfo = NULL;
- }
- }
+ codePtr->flags |= TCL_BYTECODE_RESOLVE_VARS;
}
return TCL_OK;
}