2016-12-01
| ||
22:18 | • Ticket [507d9b9651] upvar shortcut for procs status still Open with 4 other changes artifact: 8bdf971099 user: dkf | |
22:07 | [507d9b9651a3c903] Possible implementation of auto-upvar for procedures. check-in: 6e39d87cbc user: dkf tags: dah-proc-arg-upvar | |
2016-11-26
| ||
12:48 | • Ticket [507d9b9651] upvar shortcut for procs status still Open with 3 other changes artifact: 6a5ed60445 user: dah | |
12:43 | • New ticket [507d9b9651]. artifact: e184db058f user: dah | |
Ticket UUID: | 507d9b9651a3c90339c8808b48cc55b08459c0e9 | |||
Title: | upvar shortcut for procs | |||
Type: | RFE | Version: | ||
Submitter: | dah | Created on: | 2016-11-26 12:43:19 | |
Subsystem: | 07. Variables | Assigned To: | nobody | |
Priority: | 5 Medium | Severity: | Minor | |
Status: | Open | Last Modified: | 2016-12-01 22:18:10 | |
Resolution: | None | Closed By: | nobody | |
Closed on: | ||||
Description: |
Proposed patch against trunk to short circuit variable linking for procs (and perhaps tclOO if the approach taken in the patch is acceptable). This adds support for the '*' syntax to formal parameters to declare that the formal will be a future link to some variable. The approach taken emits no bytecodes -- they're not necessary because the syntax allows Tcl to know at compile time how to handle the parameters. Why do at runtime, when it can be done at compile time? It should yield a speed boost to hot code using it in place of upvar calls and impact on other code should be neglible. There are issues with the patch, namely, errors need proper handling. But all tests passed (in 8.6.6). I consider this just a hack at this time until someone that knows better thinks otherwise. Included below is a bench.tcl script to demo how this would look (also in patch). # doNothing - 77107 microseconds per iteration # doHack - 82073 microseconds per iteration # doUpvar - 163975 microseconds per iteration proc doNothing {a b} { set a bar set b baz } proc doHack {*a *b} { set a bar set b baz } proc doUpvar {a b} { upvar $a la upvar $b lb set la bar set lb baz } proc bench {} { # Warmup the caches first set c {} set d {} for {set i 0} {$i < 100000} {incr i} { doUpvar c d } puts [time { for {set i 0} {$i < 100000} {incr i} { doNothing c d } }] set a {} set b {} puts [time { for {set i 0} {$i < 100000} {incr i} { doHack a b } }] puts [time { for {set i 0} {$i < 100000} {incr i} { doUpvar c d } }] } | |||
User Comments: |
dkf added on 2016-12-01 22:18:10:
See the dah-proc-arg-upvar branch. dah added on 2016-11-26 12:48:03: Ok since I see no option for attaching a file I'll just paste it. diff -Naur trunk.orig/bench.tcl trunk/bench.tcl --- trunk.orig/bench.tcl 1970-01-01 01:00:00.000000000 +0100 +++ trunk/bench.tcl 2016-11-26 11:39:38.373273113 +0100 @@ -0,0 +1,51 @@ +# doNothing - 77107 microseconds per iteration +# doHack - 82073 microseconds per iteration +# doUpvar - 163975 microseconds per iteration + +proc doNothing {a b} { + set a bar + set b baz +} + +proc doHack {*a *b} { + set a bar + set b baz +} + +proc doUpvar {a b} { + upvar $a la + upvar $b lb + set la bar + set lb baz +} + +proc bench {} { + # Warmup the caches first + set c {} + set d {} + for {set i 0} {$i < 100000} {incr i} { + doUpvar c d + } + + puts [time { + for {set i 0} {$i < 100000} {incr i} { + doNothing c d + } + }] + + set a {} + set b {} + puts [time { + for {set i 0} {$i < 100000} {incr i} { + doHack a b + } + }] + + puts [time { + for {set i 0} {$i < 100000} {incr i} { + doUpvar c d + } + }] +} + +bench diff -Naur trunk.orig/generic/tclInt.h trunk/generic/tclInt.h --- trunk.orig/generic/tclInt.h 2016-11-25 12:47:54.000000000 +0100 +++ trunk/generic/tclInt.h 2016-11-26 11:09:53.565198884 +0100 @@ -1696,6 +1696,7 @@ #define CMD_COMPILES_EXPANDED 0x08 #define CMD_REDEF_IN_PROGRESS 0x10 #define CMD_VIA_RESOLVER 0x20 +#define CMD_HAS_ARG_LINKS 0x40 /* diff -Naur trunk.orig/generic/tclProc.c trunk/generic/tclProc.c --- trunk.orig/generic/tclProc.c 2016-11-25 12:47:54.000000000 +0100 +++ trunk/generic/tclProc.c 2016-11-26 11:35:07.129261832 +0100 @@ -627,6 +627,7 @@ localPtr = localPtr->nextPtr; } else { + char *varName = fieldValues[0]; /* * Allocate an entry in the runtime procedure frame's array of * local variables for the argument. @@ -639,10 +640,35 @@ procPtr->lastLocalPtr->nextPtr = localPtr; procPtr->lastLocalPtr = localPtr; } + + localPtr->flags = 0; + /* + * Names that begin with an asterisk shall be handled as a + * link var to be linked at some point in the future. + */ + if (*varName == '*' && nameLength > 1) { + if (fieldCount == 2) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "procedure \"%s\": formal parameter \"%s\" " + " is to be a link and can't have a default value", + procName, fieldValues[0])); + ckfree(fieldValues); + /* TODO: SET SOME ERROR CODE */ + goto procError; + } + varName++; + nameLength--; + /* + * Indicate this argument is to be a future link var. + * Does there need to be a new VAR_FUTURE_LINK flag? + */ + localPtr->flags = VAR_LINK; + } + localPtr->nextPtr = NULL; localPtr->nameLength = nameLength; localPtr->frameIndex = i; - localPtr->flags = VAR_ARGUMENT; + localPtr->flags |= VAR_ARGUMENT; localPtr->resolveInfo = NULL; if (fieldCount == 2) { @@ -652,7 +678,7 @@ } else { localPtr->defValuePtr = NULL; } - memcpy(localPtr->name, fieldValues[0], nameLength + 1); + memcpy(localPtr->name, varName, nameLength + 1); if ((i == numArgs - 1) && (localPtr->nameLength == 4) && (localPtr->name[0] == 'a') @@ -1331,6 +1357,7 @@ LocalCache *localCachePtr; CompiledLocal *localPtr; int new; + char hasArgLinks = 0; /* * Cache the names and initial values of local variables; store the @@ -1361,6 +1388,11 @@ varPtr++; i++; } + if (!hasArgLinks && (localPtr->flags & VAR_LINK)) { + hasArgLinks = 1; + procPtr->cmdPtr->flags |= CMD_HAS_ARG_LINKS; + } + namePtr++; localPtr = localPtr->nextPtr; } @@ -1448,19 +1480,67 @@ goto correctArgs; } } - imax = ((argCt < numArgs-1) ? argCt : numArgs-1); - for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) { - /* - * "Normal" arguments; last formal is special, depends on it being - * 'args'. - */ - - Tcl_Obj *objPtr = argObjs[i]; - - varPtr->flags = 0; - varPtr->value.objPtr = objPtr; - Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ + /* TODO need sane error handling */ + if (procPtr->cmdPtr->flags & CMD_HAS_ARG_LINKS) { + CallFrame *upFramePtr; + Var *otherPtr, *aPtr; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + char done = 1; + + imax = ((argCt < numArgs) ? argCt : numArgs); + for (i = 0; i < imax; i++, localPtr = localPtr->nextPtr, + varPtr++, defPtr ? defPtr++ : defPtr) { + Tcl_Obj *objPtr = argObjs[i]; + if (TclIsVarLink(localPtr) && objPtr) { + if (TclObjGetFrame(interp, NULL, &upFramePtr) == -1) { + goto incorrectArgs; + } + /* + * Locate the other variable. + */ + ((Interp *)interp)->varFramePtr = upFramePtr; + otherPtr = TclObjLookupVarEx(interp, objPtr, NULL, + TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1, + /*createPart2*/ 1, &aPtr); + ((Interp *)interp)->varFramePtr = framePtr; + if (otherPtr == NULL) { + goto incorrectArgs; + } + varPtr->flags = VAR_LINK; + varPtr->value.linkPtr = otherPtr; + if (TclIsVarInHash(otherPtr)) { + VarHashRefCount(otherPtr)++; + } + } else { + if (i != numArgs-1) { + varPtr->flags = 0; + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ + } else { + /* The last non-linked arg is special. */ + done = 0; + break; + } + } + } + if (done && argCt == numArgs) { + goto correctArgs; + } + } else { + imax = ((argCt < numArgs-1) ? argCt : numArgs-1); + for (i = 0; i < imax; i++, varPtr++, defPtr ? defPtr++ : defPtr) { + /* + * "Normal" arguments; last formal is special, depends on it being + * 'args'. + */ + + Tcl_Obj *objPtr = argObjs[i]; + varPtr->flags = 0; + varPtr->value.objPtr = objPtr; + Tcl_IncrRefCount(objPtr); /* Local var is a reference. */ + } } + for (; i < numArgs-1; i++, varPtr++, defPtr ? defPtr++ : defPtr) { /* * This loop is entered if argCt < (numArgs-1). Set default values; diff -Naur trunk.orig/tests/proc.test trunk/tests/proc.test --- trunk.orig/tests/proc.test 2016-11-25 12:47:54.000000000 +0100 +++ trunk/tests/proc.test 2016-11-26 11:37:35.565268005 +0100 @@ -383,6 +383,20 @@ interp delete slave unset lambda } {} + +test proc-8.1 {Argument linking} -body { + proc P {*a} {set a 1} + set a {} + P a +} -result 1 + +test proc-8.2 {Argument linking, and defaults} -body { + proc P {*a {foo bar} args} {return $foo} + set a {} + P a +} -result {bar} + + # cleanup catch {rename p ""} |