Tcl Source Code

View Ticket
Login
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 ""}