diff options
| -rw-r--r-- | ChangeLog | 8 | ||||
| -rw-r--r-- | generic/tclCompile.c | 147 | ||||
| -rw-r--r-- | generic/tclCompile.h | 10 | ||||
| -rw-r--r-- | generic/tclInt.h | 3 | ||||
| -rw-r--r-- | generic/tclProc.c | 116 |
5 files changed, 170 insertions, 114 deletions
@@ -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; } |