Attachment "noopProc.patch" to
ticket [451441ffff]
added by
msofer
2001-08-18 06:23:32.
Index: generic/tclProc.c
===================================================================
RCS file: /cvsroot/tcl/tcl/generic/tclProc.c,v
retrieving revision 1.25
diff -u -r1.25 tclProc.c
--- generic/tclProc.c 2001/04/27 22:11:51 1.25
+++ generic/tclProc.c 2001/08/17 23:13:15
@@ -27,6 +27,8 @@
static void ProcBodyUpdateString _ANSI_ARGS_((Tcl_Obj *objPtr));
static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
char *procName, int nameLen, int returnCode));
+static int TclCompileNoOp _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Parse *parsePtr, struct CompileEnv *envPtr));
/*
* The ProcBodyObjType type
@@ -146,6 +148,51 @@
procPtr->cmdPtr = (Command *) cmd;
+
+ /*
+ * Optimize for noop procs: if the argument list is just "args"
+ * and the body is empty, define a compileProc.
+ *
+ * Notes:
+ * - cannot be done for any argument list without having different
+ * compiled/not-compiled behaviour in the "wrong argument #" case
+ * - Should be enhanced to handle also non-empty bodies that contain
+ * only comments; parsing the body will make the compilation of
+ * other procs slower
+ */
+
+ {
+ char *txt;
+ txt = Tcl_GetString(objv[2]);
+
+ while(*txt == ' ') txt++;
+
+ if ((txt[0] == 'a') && (memcmp(txt, "args", 4) == 0)) {
+ txt +=4;
+ while(*txt != '\0') {
+ if (*txt != ' ') goto done;;
+ txt++;
+ }
+
+ /*
+ * The argument list is just "args"; check the body
+ */
+
+ txt = Tcl_GetString(objv[3]);
+ while(*txt != '\0') {
+ if (!isspace(*txt)) goto done;
+ txt++;
+ }
+
+ /*
+ * The body is just spaces: link the compileProc
+ */
+
+ ((Command *) cmd)->compileProc = TclCompileNoOp;
+ }
+ }
+
+ done:
return TCL_OK;
}
@@ -1582,4 +1629,49 @@
Tcl_Obj *objPtr; /* the object to update */
{
panic("called ProcBodyUpdateString");
+}
+
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileNoOp --
+ *
+ * Procedure called to compile noOp's
+ *
+ * Results:
+ * The return value is TCL_OK, indicating successful compilation.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute a noOp at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileNoOp(interp, parsePtr, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ Tcl_Parse *parsePtr; /* Points to a parse structure for the
+ * command created by Tcl_ParseCommand. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Tcl_Token *tokenPtr;
+ int i, code;
+
+ envPtr->maxStackDepth = 1;
+ tokenPtr = parsePtr->tokenPtr;
+ for(i = 1; i < parsePtr->numWords; i++) {
+ tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ code = TclCompileTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (code != TCL_OK) return code;
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+ }
+ TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), envPtr);
+ return TCL_OK;
}
Index: tests/proc.test
===================================================================
RCS file: /cvsroot/tcl/tcl/tests/proc.test,v
retrieving revision 1.8
diff -u -r1.8 proc.test
--- tests/proc.test 2000/05/03 00:14:36 1.8
+++ tests/proc.test 2001/08/17 23:14:45
@@ -294,6 +294,23 @@
set result
} {procedure "t": formal parameter "z" has default value inconsistent with precompiled body}
+test proc-5.1 {Bytecompiling noop; test for correct argument substitution} {
+ proc p args {} ; # this will be bytecompiled into t
+ proc t {} {
+ set ct 0
+ set a 0
+ set b 0
+ trace add variable a read {incr ct ;#}
+ trace add variable b write {incr ct ;#}
+ p $a ccccccw {bfe} {$a} [incr b] [incr a] {[incr b]} {$a} hello
+ set ct
+ }
+ set result [t]
+ catch {rename p ""}
+ catch {rename t ""}
+ set result
+} {3}
+
# cleanup
catch {rename p ""}
catch {rename t ""}
