From 6b9dcf87ecc79d795e79e3d6d8e03b894f36a6cc Mon Sep 17 00:00:00 2001 From: oehhar Date: Wed, 17 Jul 2013 16:02:36 +0000 Subject: Start notifier thread again if we were forked, to solve Rivet bug 55153 - RFE [a0bc856dcd] --- ChangeLog | 6 ++++++ unix/tclUnixNotfy.c | 21 +++++++++++++++++++++ 2 files changed, 27 insertions(+) diff --git a/ChangeLog b/ChangeLog index d7ada95..bdbbd4a 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2013-07-17 Harald Oehlmann + + * tclUnixNotify.c Tcl_InitNotifier: RFE [a0bc856dcd] + Start notifier thread again if we were forked, to solve Rivet bug + 55153. + 2013-07-05 Kevin B. Kenny * library/tzdata/Africa/Casablanca: diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index aacc8d2d..2ad1932 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -120,6 +120,15 @@ static Tcl_ThreadDataKey dataKey; static int notifierCount = 0; /* + * The following static stores the process ID of the initialized notifier + * thread. If it changes, we have passed a fork and we should start a new + * notifier thread. + * + * You must hold the notifierMutex lock before accessing this variable. + */ +static pid_t processIDInitialized = 0; + +/* * The following variable points to the head of a doubly-linked list of * ThreadSpecificData structures for all threads that are currently waiting on * an event. @@ -275,11 +284,23 @@ Tcl_InitNotifier(void) */ Tcl_MutexLock(¬ifierMutex); + /* + * Check if my process id changed, e.g. I was forked + * In this case, restart the notifier thread and close the + * pipe to the original notifier thread + */ + if (notifierCount > 0 && processIDInitialized != getpid()) { + notifierCount = 0; + processIDInitialized = 0; + close(triggerPipe); + triggerPipe = -1; + } if (notifierCount == 0) { if (TclpThreadCreate(¬ifierThread, NotifierThreadProc, NULL, TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) { Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread"); } + processIDInitialized = getpid(); } notifierCount++; -- cgit v0.12 From ec06295d4ed7d6f865b8d73925bfb24d8f478f45 Mon Sep 17 00:00:00 2001 From: oehhar Date: Mon, 22 Jul 2013 08:45:37 +0000 Subject: Test file tests/unixForkEvent.test added --- tests/unixForkEvent.test | 50 ++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 50 insertions(+) create mode 100644 tests/unixForkEvent.test diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test new file mode 100644 index 0000000..fee45fd --- /dev/null +++ b/tests/unixForkEvent.test @@ -0,0 +1,50 @@ +# This file contains a collection of tests for the procedures in the file +# tclEvent.c, which includes the "update", and "vwait" Tcl +# commands. Sourcing this file into Tcl runs the tests and generates +# output for errors. No output means no errors were found. +# +# Copyright (c) 1995-1997 Sun Microsystems, Inc. +# Copyright (c) 1998-1999 by Scriptics Corporation. +# +# See the file "license.terms" for information on usage and redistribution +# of this file, and for a DISCLAIMER OF ALL WARRANTIES. + +package require tcltest 2 +namespace import -force ::tcltest::* + +testConstraint testfork [llength [info commands testfork]] +testConstraint threaded [expr { + ([info exist tcl_platform(threaded)] && $tcl_platform(threaded)) + && $tcl_platform(os) ne "Darwin" +}] + +# Test if the notifier thread is well initialized in a forked interpreter +# by Tcl_InitNotifier +test unixforkevent-1.1 {fork and test writeable event} \ + -constraints {threaded testfork} \ + -body { + set folder [makeDirectory unixtestfork] + set pid [testfork] + if {$pid == 0} { + # we are the forked process + set result initialized + set h [open [file join $folder test.txt] w] + fileevent $h writable\ + "set result writable;\ + after cancel [after 1000 {set result timeout}]" + vwait result + close $h + makeFile $result result.txt $folder + exit + } + # we are the original process + while {![file readable [file join $folder result.txt]]} {} + viewFile result.txt $folder + } \ + -result {writable} \ + -cleanup { + catch { removeFolder $folder } + } + +::tcltest::cleanupTests +return -- cgit v0.12 From 978b54229dc68812a5ccaa0050324d215db91520 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Jul 2013 10:10:00 +0000 Subject: Fix bug which hangs iocmd.tf-32.1 --- unix/tclUnixNotfy.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index 88e290e..6e8b5fa 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -291,8 +291,8 @@ Tcl_InitNotifier(void) if (TclpThreadCreate(¬ifierThread, NotifierThreadProc, NULL, TCL_THREAD_STACK_DEFAULT, TCL_THREAD_JOINABLE) != TCL_OK) { Tcl_Panic("Tcl_InitNotifier: unable to start notifier thread"); - processIDInitialized = getpid(); } + processIDInitialized = getpid(); } notifierCount++; -- cgit v0.12 From f9820a2863b758aa1d07274355cd62f9ecbddae1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Jul 2013 10:11:05 +0000 Subject: Test-case should pass on Darwin or with non-threaded build as well. --- tests/unixForkEvent.test | 11 +++-------- 1 file changed, 3 insertions(+), 8 deletions(-) diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test index fee45fd..a0c3f19 100644 --- a/tests/unixForkEvent.test +++ b/tests/unixForkEvent.test @@ -1,7 +1,6 @@ # This file contains a collection of tests for the procedures in the file -# tclEvent.c, which includes the "update", and "vwait" Tcl -# commands. Sourcing this file into Tcl runs the tests and generates -# output for errors. No output means no errors were found. +# tclUnixNotify.c. Sourcing this file into Tcl runs the tests and +# generates output for errors. No output means no errors were found. # # Copyright (c) 1995-1997 Sun Microsystems, Inc. # Copyright (c) 1998-1999 by Scriptics Corporation. @@ -13,15 +12,11 @@ package require tcltest 2 namespace import -force ::tcltest::* testConstraint testfork [llength [info commands testfork]] -testConstraint threaded [expr { - ([info exist tcl_platform(threaded)] && $tcl_platform(threaded)) - && $tcl_platform(os) ne "Darwin" -}] # Test if the notifier thread is well initialized in a forked interpreter # by Tcl_InitNotifier test unixforkevent-1.1 {fork and test writeable event} \ - -constraints {threaded testfork} \ + -constraints testfork \ -body { set folder [makeDirectory unixtestfork] set pid [testfork] -- cgit v0.12 From a038288139470e7a32c1e711fcfdbd64212e87e4 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Jul 2013 10:57:44 +0000 Subject: Use pthread_atfork() when available. --- unix/configure | 209 +++++++++++++++++++++++++++------------------------- unix/configure.in | 7 +- unix/tclUnixNotfy.c | 90 +++++++++++++++++++++- 3 files changed, 202 insertions(+), 104 deletions(-) diff --git a/unix/configure b/unix/configure index 6faa7d8..ee194b7 100755 --- a/unix/configure +++ b/unix/configure @@ -16759,6 +16759,113 @@ done #-------------------------------------------------------------------- +# Check for support of pthread_atfork function +#-------------------------------------------------------------------- + + +for ac_func in pthread_atfork +do +as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` +echo "$as_me:$LINENO: checking for $ac_func" >&5 +echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 +if eval "test \"\${$as_ac_var+set}\" = set"; then + echo $ECHO_N "(cached) $ECHO_C" >&6 +else + cat >conftest.$ac_ext <<_ACEOF +/* confdefs.h. */ +_ACEOF +cat confdefs.h >>conftest.$ac_ext +cat >>conftest.$ac_ext <<_ACEOF +/* end confdefs.h. */ +/* Define $ac_func to an innocuous variant, in case declares $ac_func. + For example, HP-UX 11i declares gettimeofday. */ +#define $ac_func innocuous_$ac_func + +/* System header to define __stub macros and hopefully few prototypes, + which can conflict with char $ac_func (); below. + Prefer to if __STDC__ is defined, since + exists even on freestanding compilers. */ + +#ifdef __STDC__ +# include +#else +# include +#endif + +#undef $ac_func + +/* Override any gcc2 internal prototype to avoid an error. */ +#ifdef __cplusplus +extern "C" +{ +#endif +/* We use char because int might match the return type of a gcc2 + builtin and then its argument prototype would still apply. */ +char $ac_func (); +/* The GNU C library defines this for functions which it implements + to always fail with ENOSYS. Some functions are actually named + something starting with __ and the normal name is an alias. */ +#if defined (__stub_$ac_func) || defined (__stub___$ac_func) +choke me +#else +char (*f) () = $ac_func; +#endif +#ifdef __cplusplus +} +#endif + +int +main () +{ +return f != $ac_func; + ; + return 0; +} +_ACEOF +rm -f conftest.$ac_objext conftest$ac_exeext +if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 + (eval $ac_link) 2>conftest.er1 + ac_status=$? + grep -v '^ *+' conftest.er1 >conftest.err + rm -f conftest.er1 + cat conftest.err >&5 + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); } && + { ac_try='test -z "$ac_c_werror_flag" + || test ! -s conftest.err' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; } && + { ac_try='test -s conftest$ac_exeext' + { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 + (eval $ac_try) 2>&5 + ac_status=$? + echo "$as_me:$LINENO: \$? = $ac_status" >&5 + (exit $ac_status); }; }; then + eval "$as_ac_var=yes" +else + echo "$as_me: failed program was:" >&5 +sed 's/^/| /' conftest.$ac_ext >&5 + +eval "$as_ac_var=no" +fi +rm -f conftest.err conftest.$ac_objext \ + conftest$ac_exeext conftest.$ac_ext +fi +echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 +echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 +if test `eval echo '${'$as_ac_var'}'` = yes; then + cat >>confdefs.h <<_ACEOF +#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 +_ACEOF + +fi +done + + +#-------------------------------------------------------------------- # Check for support of isnan() function or macro #-------------------------------------------------------------------- @@ -17439,108 +17546,6 @@ _ACEOF fi done - -for ac_func in pthread_atfork -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define $ac_func to an innocuous variant, in case declares $ac_func. - For example, HP-UX 11i declares gettimeofday. */ -#define $ac_func innocuous_$ac_func - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef $ac_func - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - fi cat >>confdefs.h <<\_ACEOF diff --git a/unix/configure.in b/unix/configure.in index e22a7d3..f47b882 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -491,6 +491,12 @@ SC_ENABLE_LANGINFO AC_CHECK_FUNCS(chflags) #-------------------------------------------------------------------- +# Check for support of pthread_atfork function +#-------------------------------------------------------------------- + +AC_CHECK_FUNCS(pthread_atfork) + +#-------------------------------------------------------------------- # Check for support of isnan() function or macro #-------------------------------------------------------------------- @@ -513,7 +519,6 @@ if test "`uname -s`" = "Darwin" ; then if test $tcl_corefoundation = yes; then AC_CHECK_HEADERS(libkern/OSAtomic.h) AC_CHECK_FUNCS(OSSpinLockLock) - AC_CHECK_FUNCS(pthread_atfork) fi AC_DEFINE(USE_VFORK, 1, [Should we use vfork() instead of fork()?]) AC_DEFINE(TCL_DEFAULT_ENCODING, "utf-8", diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index 6e8b5fa..f414c3f 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -202,7 +202,13 @@ static Tcl_ThreadId notifierThread; #ifdef TCL_THREADS static void NotifierThreadProc(ClientData clientData); -#endif +#ifdef HAVE_PTHREAD_ATFORK +static int atForkInit = 0; +static void AtForkPrepare(void); +static void AtForkParent(void); +static void AtForkChild(void); +#endif /* HAVE_PTHREAD_ATFORK */ +#endif /* TCL_THREADS */ static int FileHandlerEventProc(Tcl_Event *evPtr, int flags); /* @@ -276,6 +282,21 @@ Tcl_InitNotifier(void) */ Tcl_MutexLock(¬ifierMutex); +#ifdef HAVE_PTHREAD_ATFORK + /* + * Install pthread_atfork handlers to reinitialize the notifier in the + * child of a fork. + */ + + if (!atForkInit) { + int result = pthread_atfork(AtForkPrepare, AtForkParent, AtForkChild); + + if (result) { + Tcl_Panic("Tcl_InitNotifier: pthread_atfork failed"); + } + atForkInit = 1; + } +#endif /* * Check if my process id changed, e.g. I was forked * In this case, restart the notifier thread and close the @@ -1251,6 +1272,73 @@ NotifierThreadProc( TclpThreadExit (0); } + +#ifdef HAVE_PTHREAD_ATFORK +/* + *---------------------------------------------------------------------- + * + * AtForkPrepare -- + * + * Lock the notifier in preparation for a fork. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AtForkPrepare(void) +{ +} + +/* + *---------------------------------------------------------------------- + * + * AtForkParent -- + * + * Unlock the notifier in the parent after a fork. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AtForkParent(void) +{ +} + +/* + *---------------------------------------------------------------------- + * + * AtForkChild -- + * + * Unlock and reinstall the notifier in the child after a fork. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +AtForkChild(void) +{ + Tcl_InitNotifier(); +} +#endif /* HAVE_PTHREAD_ATFORK */ + #endif /* TCL_THREADS */ #endif /* HAVE_COREFOUNDATION */ -- cgit v0.12 From 7a32d8f6e8b39e52c94b3a375a95bd3b6669c12e Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 22 Jul 2013 11:11:10 +0000 Subject: Tcl_InitNotifier() call in TestforkObjCmd() is only necessary when pthread_atfork() is not available. --- unix/tclUnixTest.c | 3 +++ 1 file changed, 3 insertions(+) diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c index 39cddef..2fc1647 100644 --- a/unix/tclUnixTest.c +++ b/unix/tclUnixTest.c @@ -574,9 +574,12 @@ TestforkObjCmd( "Cannot fork", NULL); return TCL_ERROR; } +#ifndef HAVE_PTHREAD_ATFORK + /* Only needed when pthread_atfork is not present. */ if (pid==0) { Tcl_InitNotifier(); } +#endif Tcl_SetObjResult(interp, Tcl_NewIntObj(pid)); return TCL_OK; } -- cgit v0.12 From c75e578cb3af78543a31ac6ad4676324c9ce6b6c Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 23 Jul 2013 18:01:36 +0000 Subject: Stop checking stack depth in [catch] compiler. Stack depth is checked in compiles of *all* Tcl commands/scripts/bodies in debug builds already. --- generic/tclCompCmds.c | 10 ---------- 1 file changed, 10 deletions(-) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 7fe0728..bde6f96 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -544,7 +544,6 @@ TclCompileCatchCmd( JumpFixup jumpFixup; Tcl_Token *cmdTokenPtr, *resultNameTokenPtr, *optsNameTokenPtr; int resultIndex, optsIndex, range; - int initStackDepth = envPtr->currStackDepth; DefineLineInformation; /* TIP #280 */ /* @@ -742,15 +741,6 @@ TclCompileCatchCmd( TclEmitOpcode( INST_POP, envPtr); } - /* - * Result of all this, on either branch, should have been to leave one - * operand -- the return code -- on the stack. - */ - - if (envPtr->currStackDepth != initStackDepth + 1) { - Tcl_Panic("in TclCompileCatchCmd, currStackDepth = %d should be %d", - envPtr->currStackDepth, initStackDepth+1); - } return TCL_OK; } -- cgit v0.12 From 717285df9ed06247a6236610722e8fd22d124464 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 23 Jul 2013 18:03:39 +0000 Subject: Remove outdated comment. Stack depths are well checked now. --- generic/tclCompCmdsSZ.c | 3 --- 1 file changed, 3 deletions(-) diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 320ed57..d8587be 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -991,9 +991,6 @@ TclSubstCompile( * Instructions are added to envPtr to execute the "switch" command at * runtime. * - * FIXME: - * Stack depths are probably not calculated correctly. - * *---------------------------------------------------------------------- */ -- cgit v0.12 From 1ea19bb4bad3984855b928d2a5213314b1111e47 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 23 Jul 2013 20:11:00 +0000 Subject: Remove outdated, disabled code. --- generic/tclCompile.c | 503 --------------------------------------------------- 1 file changed, 503 deletions(-) diff --git a/generic/tclCompile.c b/generic/tclCompile.c index a52ad3e..e4da2ba 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -16,8 +16,6 @@ #include "tclCompile.h" #include -#define REWRITE - /* * Table of all AuxData types. */ @@ -564,10 +562,6 @@ static void EnterCmdExtentData(CompileEnv *envPtr, int cmdNumber, int numSrcBytes, int numCodeBytes); static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); -#ifndef REWRITE -static Command * FindCompiledCommandFromToken(Tcl_Interp *interp, - Tcl_Token *tokenPtr); -#endif static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); @@ -1672,56 +1666,6 @@ TclWordKnownAtCompileTime( return 1; } -#ifndef REWRITE -/* - * --------------------------------------------------------------------- - * - * FindCompiledCommandFromToken -- - * - * A simple helper that looks up a command's compiler from its token. - * - * --------------------------------------------------------------------- - */ - -static Command * -FindCompiledCommandFromToken( - Tcl_Interp *interp, - Tcl_Token *tokenPtr) -{ - Tcl_DString ds; - Command *cmdPtr; - - /* - * If we have a non-trivial token or are suppressing compilation, we stop - * right now. - */ - - if ((tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) - || (((Interp *) interp)->flags & DONT_COMPILE_CMDS_INLINE)) { - return NULL; - } - - /* - * We copy the string before trying to find the command by name. We used - * to modify the string in place, but this is not safe because the name - * resolution handlers could have side effects that rely on the unmodified - * string. - */ - - Tcl_DStringInit(&ds); - TclDStringAppendToken(&ds, &tokenPtr[1]); - cmdPtr = (Command *) Tcl_FindCommand(interp, Tcl_DStringValue(&ds), NULL, - /*flags*/ 0); - if (cmdPtr != NULL && (cmdPtr->compileProc == NULL - || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) - || (cmdPtr->flags & CMD_HAS_EXEC_TRACES))) { - cmdPtr = NULL; - } - Tcl_DStringFree(&ds); - return cmdPtr; -} -#endif - /* *---------------------------------------------------------------------- * @@ -1740,8 +1684,6 @@ FindCompiledCommandFromToken( *---------------------------------------------------------------------- */ -#ifdef REWRITE - static int ExpandRequested( Tcl_Token *tokenPtr, @@ -2071,7 +2013,6 @@ CompileCommandTokens( return cmdIdx; } -#endif void TclCompileScript( @@ -2084,7 +2025,6 @@ TclCompileScript( * first null character. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { -#ifdef REWRITE int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last * command this routine compiles into bytecode. * Initial value of -1 indicates this routine @@ -2198,449 +2138,6 @@ TclCompileScript( envPtr->codeNext--; envPtr->currStackDepth++; } -#else - int lastTopLevelCmdIndex = -1; - /* Index of most recent toplevel command in - * the command location table. Initialized to - * avoid compiler warning. */ - int startCodeOffset = -1; /* Offset of first byte of current command's - * code. Init. to avoid compiler warning. */ - unsigned char *entryCodeNext = envPtr->codeNext; - const char *p, *next; - Command *cmdPtr; - Tcl_Token *tokenPtr; - int bytesLeft, isFirstCmd, wordIdx, currCmdIndex, commandLength, objIndex; - /* TIP #280 */ - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; - int *wlines, wlineat, cmdLine, *clNext; - Tcl_Parse parse, *parsePtr = &parse; - - if (envPtr->iPtr == NULL) { - Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); - } - - if (numBytes < 0) { - numBytes = strlen(script); - } - Tcl_ResetResult(interp); - isFirstCmd = 1; - - /* - * Each iteration through the following loop compiles the next command - * from the script. - */ - - p = script; - bytesLeft = numBytes; - cmdLine = envPtr->line; - clNext = envPtr->clNext; - do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { - /* - * Compile bytecodes to report the parse error at runtime. - */ - - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - parsePtr->term + 1 - parsePtr->commandStart); - TclCompileSyntaxError(interp, envPtr); - break; - } - - /* - * TIP #280: We have to count newlines before the command even in the - * degenerate case when the command has no words. (See test - * info-30.33). - * So make that counting here, and not in the (numWords > 0) branch - * below. - */ - - TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); - TclAdvanceContinuations(&cmdLine, &clNext, - parsePtr->commandStart - envPtr->source); - - if (parsePtr->numWords > 0) { - int expand = 0; /* Set if there are dynamic expansions to - * handle */ - - /* - * If not the first command, pop the previous command's result - * and, if we're compiling a top level command, update the last - * command's code size to account for the pop instruction. - */ - - if (!isFirstCmd) { - TclEmitOpcode(INST_POP, envPtr); - envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - startCodeOffset; - } - - /* - * Determine the actual length of the command. - */ - - commandLength = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + commandLength-1) { - /* - * The command terminator character (such as ; or ]) is the - * last character in the parsed command. Reduce the length by - * one so that the trace message doesn't include the - * terminator character. - */ - - commandLength -= 1; - } - -#ifdef TCL_COMPILE_DEBUG - /* - * If tracing, print a line for each top level command compiled. - */ - - if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parsePtr->commandStart, - TclMin(commandLength, 55)); - fprintf(stdout, "\n"); - } -#endif - - /* - * Check whether expansion has been requested for any of the - * words. - */ - - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; - break; - } - } - - /* - * If expansion was requested, check if the command declares that - * it knows how to compile it. Note that if expansion is requested - * for the first word, this check will fail as the token type will - * inhibit it. (Checked inside FindCompiledCommandFromToken.) This - * is as it should be. - */ - - if (expand) { - cmdPtr = FindCompiledCommandFromToken(interp, - parsePtr->tokenPtr); - if (cmdPtr && (cmdPtr->flags & CMD_COMPILES_EXPANDED)) { - expand = 0; - } - } - - envPtr->numCommands++; - currCmdIndex = envPtr->numCommands - 1; - lastTopLevelCmdIndex = currCmdIndex; - startCodeOffset = envPtr->codeNext - envPtr->codeStart; - EnterCmdStartData(envPtr, currCmdIndex, - parsePtr->commandStart - envPtr->source, startCodeOffset); - - /* - * Should only start issuing instructions after the "command has - * started" so that the command range is correct in the bytecode. - */ - - if (expand) { - StartExpanding(envPtr); - } - - /* - * TIP #280. Scan the words and compute the extended location - * information. The map first contain full per-word line - * information for use by the compiler. This is later replaced by - * a reduced form which signals non-literal words, stored in - * 'wlines'. - */ - - EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, - parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->commandSize, parsePtr->numWords, cmdLine, - clNext, &wlines, envPtr); - wlineat = eclPtr->nuloc - 1; - - /* - * Each iteration of the following loop compiles one word from the - * command. - */ - - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; wordIdx++, - tokenPtr += tokenPtr->numComponents + 1) { - /* - * Note the parse location information. - */ - - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; - envPtr->clNext = eclPtr->loc[wlineat].next[wordIdx]; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * The word is not a simple string of characters. - */ - - CompileTokens(envPtr, tokenPtr, interp); - if (expand && tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); - } - continue; - } - - /* - * This is a simple string of literal characters (i.e. we know - * it absolutely and can use it directly). If this is the - * first word and the command has a compile procedure, let it - * compile the command. - */ - - if ((wordIdx == 0) && !expand) { - cmdPtr = FindCompiledCommandFromToken(interp, tokenPtr); - if (cmdPtr) { - int savedNumCmds = envPtr->numCommands; - unsigned savedCodeNext = - envPtr->codeNext - envPtr->codeStart; - int update = 0; - int startStackDepth = envPtr->currStackDepth; - - /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclNRExecuteByteCode(). Do emit an INST_START_CMD - * in special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] - * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. - */ - - if (envPtr->atCmdStart == 1) { - if (savedCodeNext != 0) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, 1) - } - } else if (envPtr->atCmdStart == 0) { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; - } - - if (cmdPtr->compileProc(interp, parsePtr, cmdPtr, - envPtr) == TCL_OK) { - /* - * Confirm that the command compiler generated a - * single value on the stack as its result. This - * is only done in debugging mode, as it *should* - * be correct and normal users have no reasonable - * way to fix it anyway. - */ - -#ifdef TCL_COMPILE_DEBUG - int diff = envPtr->currStackDepth-startStackDepth; - - if (diff != 1) { - Tcl_Panic("bad stack adjustment when compiling" - " %.*s (was %d instead of 1)", - parsePtr->tokenPtr->size, - parsePtr->tokenPtr->start, diff); - } -#endif - if (update) { - /* - * Fix the bytecode length. - */ - - unsigned char *fixPtr = envPtr->codeStart - + savedCodeNext + 1; - unsigned fixLen = envPtr->codeNext - - envPtr->codeStart - savedCodeNext; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } - - if (envPtr->atCmdStart == 1 && savedCodeNext != 0) { - /* - * Decrease the number of commands being started - * at the current point. Note that this depends on - * the exact layout of the INST_START_CMD's - * operands, so be careful! - */ - - TclIncrUInt4AtPtr(envPtr->codeNext - 4, -1); - } - - /* - * Restore numCommands and codeNext to their correct - * values, removing any commands compiled before the - * failure to produce bytecode got reported. [Bugs - * 705406 and 735055] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; - - /* - * And the stack depth too!! [Bug 3614102]. - */ - - envPtr->currStackDepth = startStackDepth; - } - - /* - * No compile procedure so push the word. If the command - * was found, push a CmdName object to reduce runtime - * lookups. Mark this as a command name literal to reduce - * shimmering. - */ - - objIndex = TclRegisterNewCmdLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (cmdPtr) { - TclSetCmdNameObj(interp, - TclFetchLiteral(envPtr, objIndex), cmdPtr); - } - } else { - /* - * Simple argument word of a command. We reach this if and - * only if the command word was not compiled for whatever - * reason. Register the literal's location for use by - * uplevel, etc. commands, should they encounter it - * unmodified. We care only if the we are in a context - * which already allows absolute counting. - */ - - objIndex = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - - if (envPtr->clNext) { - TclContinuationsEnterDerived( - TclFetchLiteral(envPtr, objIndex), - tokenPtr[1].start - envPtr->source, - eclPtr->loc[wlineat].next[wordIdx]); - } - } - TclEmitPush(objIndex, envPtr); - } /* for loop */ - - /* - * Emit an invoke instruction for the command. We skip this if a - * compile procedure was found for the command. - */ - assert(wordIdx > 0); - - if (expand) { - /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. - * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). - * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. - */ - - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - envPtr->expandCount--; - TclAdjustStackDepth(1 - wordIdx, envPtr); - } else { - /* - * Save PC -> command map for the TclArgumentBC* functions. - */ - - int isnew; - Tcl_HashEntry *hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, - INT2PTR(envPtr->codeNext - envPtr->codeStart), - &isnew); - - Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); - if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); - } - } - - /* - * Update the compilation environment structure and record the - * offsets of the source and code for the command. - */ - - finishCommand: - EnterCmdExtentData(envPtr, currCmdIndex, commandLength, - (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - isFirstCmd = 0; - - /* - * TIP #280: Free full form of per-word line data and insert the - * reduced form now - */ - - ckfree(eclPtr->loc[wlineat].line); - ckfree(eclPtr->loc[wlineat].next); - eclPtr->loc[wlineat].line = wlines; - eclPtr->loc[wlineat].next = NULL; - } /* end if parsePtr->numWords > 0 */ - - /* - * Advance to the next command in the script. - */ - - next = parsePtr->commandStart + parsePtr->commandSize; - bytesLeft -= next - p; - p = next; - - /* - * TIP #280: Track lines in the just compiled command. - */ - - TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); - TclAdvanceContinuations(&cmdLine, &clNext, p - envPtr->source); - Tcl_FreeParse(parsePtr); - } while (bytesLeft > 0); - - /* - * TIP #280: Bring the line counts in the CompEnv up to date. - * See tests info-30.33,34,35 . - */ - - envPtr->line = cmdLine; - envPtr->clNext = clNext; - - /* - * If the source script yielded no instructions (e.g., if it was empty), - * push an empty string as the command's result. - */ - - if (envPtr->codeNext == entryCodeNext) { - PushStringLiteral(envPtr, ""); - } -#endif } /* -- cgit v0.12 From 8f13e41a87de841f8b7552e04e74caeaca8b4b5b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Jul 2013 12:13:01 +0000 Subject: more disabled code removal --- generic/tclAssembly.c | 7 ------- generic/tclEnsemble.c | 46 ---------------------------------------------- 2 files changed, 53 deletions(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 9b9b6f8..6bf2fa8 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -930,11 +930,9 @@ TclCompileAssembleCmd( { Tcl_Token *tokenPtr; /* Token in the input script */ -#if 1 int numCommands = envPtr->numCommands; int offset = envPtr->codeNext - envPtr->codeStart; int depth = envPtr->currStackDepth; -#endif /* * Make sure that the command has a single arg that is a simple word. @@ -956,7 +954,6 @@ TclCompileAssembleCmd( if (TCL_ERROR == TclAssembleCode(envPtr, tokenPtr[1].start, tokenPtr[1].size, TCL_EVAL_DIRECT)) { -#if 1 Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( "\n (\"%.*s\" body, line %d)", parsePtr->tokenPtr->size, parsePtr->tokenPtr->start, @@ -965,10 +962,6 @@ TclCompileAssembleCmd( envPtr->codeNext = envPtr->codeStart + offset; envPtr->currStackDepth = depth; TclCompileSyntaxError(interp, envPtr); -#else - Tcl_ResetResult(interp); - return TCL_ERROR; -#endif } return TCL_OK; } diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c index bab63c9..ad11785 100644 --- a/generic/tclEnsemble.c +++ b/generic/tclEnsemble.c @@ -3205,7 +3205,6 @@ CompileBasicNArgCommand( * compiled. */ CompileEnv *envPtr) /* Holds resulting instructions. */ { -#if 1 Tcl_Obj *objPtr = Tcl_NewObj(); Tcl_IncrRefCount(objPtr); @@ -3213,51 +3212,6 @@ CompileBasicNArgCommand( TclCompileInvocation(interp, parsePtr->tokenPtr, objPtr, parsePtr->numWords, envPtr); Tcl_DecrRefCount(objPtr); -#else - Tcl_Token *tokenPtr; - Tcl_Obj *objPtr; - char *bytes; - int length, i, literal; - DefineLineInformation; - - /* - * Push the name of the command we're actually dispatching to as part of - * the implementation. - */ - - objPtr = Tcl_NewObj(); - Tcl_GetCommandFullName(interp, (Tcl_Command) cmdPtr, objPtr); - bytes = Tcl_GetStringFromObj(objPtr, &length); - literal = TclRegisterNewCmdLiteral(envPtr, bytes, length); - TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, literal), cmdPtr); - TclEmitPush(literal, envPtr); - TclDecrRefCount(objPtr); - - /* - * Push the words of the command. - */ - - tokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=1 ; inumWords ; i++) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - PushLiteral(envPtr, tokenPtr[1].start, tokenPtr[1].size); - } else { - SetLineInformation(i); - CompileTokens(envPtr, tokenPtr, interp); - } - tokenPtr = TokenAfter(tokenPtr); - } - - /* - * Do the standard dispatch. - */ - - if (i <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, i, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, i, envPtr); - } -#endif return TCL_OK; } -- cgit v0.12 From f9e25fe5e7e67249f73b8f5926b3b5549c0e212e Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Jul 2013 13:58:35 +0000 Subject: Mark commands with potential to compile expansion arguments (as [list] does). --- generic/tclCompCmds.c | 9 +++++++++ generic/tclCompCmdsGR.c | 4 ++++ generic/tclCompCmdsSZ.c | 5 +++++ 3 files changed, 18 insertions(+) diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index bde6f96..8edb2d9 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -87,6 +87,7 @@ TclCompileAppendCmd( int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -973,6 +974,7 @@ TclCompileDictGetCmd( * case is legal, but too special and magic for us to deal with here). */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1010,6 +1012,7 @@ TclCompileDictExistsCmd( * case is legal, but too special and magic for us to deal with here). */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1047,6 +1050,7 @@ TclCompileDictUnsetCmd( * compile to bytecode. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } @@ -1192,6 +1196,7 @@ TclCompileDictMergeCmd( * argument, the only thing to do is to verify the dict-ness. */ + /* TODO: Consider support for compiling expanded args. (less likely) */ if (parsePtr->numWords < 2) { PushStringLiteral(envPtr, ""); return TCL_OK; @@ -1712,6 +1717,7 @@ TclCompileDictAppendCmd( * speed quite so much. ;-) */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords<4 || parsePtr->numWords>100) { return TCL_ERROR; } @@ -1764,6 +1770,8 @@ TclCompileDictLappendCmd( * There must be three arguments after the command. */ + /* TODO: Consider support for compiling expanded args. */ + /* Probably not. Why is INST_DICT_LAPPEND limited to one value? */ if (parsePtr->numWords != 4) { return TCL_ERROR; } @@ -1810,6 +1818,7 @@ TclCompileDictWithCmd( * There must be at least one argument after the command. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { return TCL_ERROR; } diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index fc68509..150c378 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -60,6 +60,7 @@ TclCompileGlobalCmd( int localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords < 2) { return TCL_ERROR; @@ -820,6 +821,7 @@ TclCompileLappendCmd( return TCL_ERROR; } + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords; if (numWords == 1) { return TCL_ERROR; @@ -1061,6 +1063,7 @@ TclCompileLindexCmd( * Quit if too few args. */ + /* TODO: Consider support for compiling expanded args. */ if (numWords <= 1) { return TCL_ERROR; } @@ -1583,6 +1586,7 @@ TclCompileLsetCmd( * Check argument count. */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { /* * Fail at run time, not in compilation. diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index d8587be..d1eb9db 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -2818,6 +2818,7 @@ TclCompileUnsetCmd( Tcl_Obj *leadingWord; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ numWords = parsePtr->numWords-1; flags = 1; varTokenPtr = TokenAfter(parsePtr->tokenPtr); @@ -3173,6 +3174,7 @@ CompileAssociativeBinaryOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ for (words=1 ; wordsnumWords ; words++) { tokenPtr = TokenAfter(tokenPtr); CompileWord(envPtr, tokenPtr, interp, words); @@ -3256,6 +3258,7 @@ CompileComparisonOpCmd( Tcl_Token *tokenPtr; DefineLineInformation; /* TIP #280 */ + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords < 3) { PUSH("1"); } else if (parsePtr->numWords == 3) { @@ -3593,6 +3596,7 @@ TclCompileMinusOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. @@ -3638,6 +3642,7 @@ TclCompileDivOpCmd( DefineLineInformation; /* TIP #280 */ int words; + /* TODO: Consider support for compiling expanded args. */ if (parsePtr->numWords == 1) { /* * Fallback to direct eval to report syntax error. -- cgit v0.12 From 7682f9c4cd7dfb3439a27d03b4531358798ff443 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 24 Jul 2013 16:51:04 +0000 Subject: Demonstrate and fix memory leak in Tcl_ParseVar(). --- generic/tclParse.c | 1 + tests/parse.test | 21 +++++++++++++++++++++ 2 files changed, 22 insertions(+) diff --git a/generic/tclParse.c b/generic/tclParse.c index 96c2a10..e475fb8 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -1566,6 +1566,7 @@ Tcl_ParseVar( code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens, NULL, 1, NULL, NULL); + Tcl_FreeParse(parsePtr); TclStackFree(interp, parsePtr); if (code != TCL_OK) { return NULL; diff --git a/tests/parse.test b/tests/parse.test index 4605914..d7de5ff 100644 --- a/tests/parse.test +++ b/tests/parse.test @@ -23,6 +23,7 @@ testConstraint testparsevarname [llength [info commands testparsevarname]] testConstraint testparsevar [llength [info commands testparsevar]] testConstraint testasync [llength [info commands testasync]] testConstraint testcmdtrace [llength [info commands testcmdtrace]] +testConstraint memory [llength [info commands memory]] test parse-1.1 {Tcl_ParseCommand procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 @@ -674,6 +675,26 @@ test parse-13.5 {Tcl_ParseVar procedure, error looking up variable} testparsevar unset -nocomplain abc list [catch {testparsevar {$abc([bogus x y z])}} msg] $msg } {1 {invalid command name "bogus"}} +test parse-13.6 {Tcl_ParseVar memory leak} -constraints memory -setup { + proc getbytes {} { + return [lindex [split [memory info] \n] 3 3] + } +} -body { + set a() foo + set end [getbytes] + for {set i 0} {$i < 5} {incr i} { + set vn {} + set res [testparsevar [append vn $ a([string repeat {[]} 19]) bar]] + if {$res ne {foo bar}} {error "Unexpected result: $res"} + + set tmp $end + set end [getbytes] + } + expr {$end - $tmp} +} -cleanup { + unset -nocomplain a end i vn res tmp + rename getbytes {} +} -result 0 test parse-14.1 {Tcl_ParseBraces procedure, computing string length} testparser { testparser [bytestring "foo\0 bar"] -1 -- cgit v0.12 From e048f90718b9ad348b7ea46ad2196e19502042c1 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Jul 2013 06:59:08 +0000 Subject: Put Cygwin's tclWinError.o in PLAT_OBJS, not in DL_OBJS --- unix/Makefile.in | 5 ++++- unix/configure | 3 ++- unix/tcl.m4 | 3 ++- 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/unix/Makefile.in b/unix/Makefile.in index b5ca879..163f4b5 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -335,7 +335,10 @@ TOMMATH_OBJS = bncore.o bn_reverse.o bn_fast_s_mp_mul_digs.o \ bn_mp_unsigned_bin_size.o bn_mp_xor.o bn_mp_zero.o bn_s_mp_add.o \ bn_s_mp_mul_digs.o bn_s_mp_sqr.o bn_s_mp_sub.o -STUB_LIB_OBJS = tclStubLib.o tclTomMathStubLib.o tclOOStubLib.o ${COMPAT_OBJS} +STUB_LIB_OBJS = tclStubLib.o \ + tclTomMathStubLib.o \ + tclOOStubLib.o \ + ${COMPAT_OBJS} UNIX_OBJS = tclUnixChan.o tclUnixEvent.o tclUnixFCmd.o \ tclUnixFile.o tclUnixPipe.o tclUnixSock.o \ diff --git a/unix/configure b/unix/configure index ef47ac5..4d0ecef 100755 --- a/unix/configure +++ b/unix/configure @@ -7170,7 +7170,8 @@ fi SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" - DL_OBJS="tclLoadDl.o tclWinError.o" + DL_OBJS="tclLoadDl.o" + PLAT_OBJS="tclWinError.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" diff --git a/unix/tcl.m4 b/unix/tcl.m4 index b9b6532..a95cf63 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -1224,7 +1224,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [ SHLIB_CFLAGS="" SHLIB_LD='${CC} -shared' SHLIB_SUFFIX=".dll" - DL_OBJS="tclLoadDl.o tclWinError.o" + DL_OBJS="tclLoadDl.o" + PLAT_OBJS="tclWinError.o" DL_LIBS="-ldl" CC_SEARCH_FLAGS="" LD_SEARCH_FLAGS="" -- cgit v0.12 From 69fbd6c489ee246d40067e6a6394419ecb9a6b07 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Jul 2013 08:29:56 +0000 Subject: Make sure that the notifierMutex and notifierCV in a forked child cannot block anything, even though the initialization of the Notifier Thread in the parent is not finished yet. --- unix/tclUnixNotfy.c | 2 ++ 1 file changed, 2 insertions(+) diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c index f414c3f..ec721ca 100644 --- a/unix/tclUnixNotfy.c +++ b/unix/tclUnixNotfy.c @@ -1335,6 +1335,8 @@ AtForkParent(void) static void AtForkChild(void) { + notifierMutex = NULL; + notifierCV = NULL; Tcl_InitNotifier(); } #endif /* HAVE_PTHREAD_ATFORK */ -- cgit v0.12 From 7fb69e61c80a0f943d0cbc01e7f4ba39eb2cb737 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Thu, 25 Jul 2013 14:24:39 +0000 Subject: Move test for pthread_atfork inside SC_ENABLE_THREADS --- unix/configure | 105 ++---------------------------------------------------- unix/configure.in | 1 - unix/tcl.m4 | 2 +- 3 files changed, 3 insertions(+), 105 deletions(-) diff --git a/unix/configure b/unix/configure index 9fa5673..217e5d4 100755 --- a/unix/configure +++ b/unix/configure @@ -4796,7 +4796,8 @@ echo "$as_me: WARNING: Don't know how to find pthread lib on your system - you m ac_saved_libs=$LIBS LIBS="$LIBS $THREADS_LIBS" -for ac_func in pthread_attr_setstacksize + +for ac_func in pthread_attr_setstacksize pthread_atfork do as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` echo "$as_me:$LINENO: checking for $ac_func" >&5 @@ -5303,108 +5304,6 @@ echo "${ECHO_T}no (default)" >&6 -for ac_func in pthread_atfork -do -as_ac_var=`echo "ac_cv_func_$ac_func" | $as_tr_sh` -echo "$as_me:$LINENO: checking for $ac_func" >&5 -echo $ECHO_N "checking for $ac_func... $ECHO_C" >&6 -if eval "test \"\${$as_ac_var+set}\" = set"; then - echo $ECHO_N "(cached) $ECHO_C" >&6 -else - cat >conftest.$ac_ext <<_ACEOF -/* confdefs.h. */ -_ACEOF -cat confdefs.h >>conftest.$ac_ext -cat >>conftest.$ac_ext <<_ACEOF -/* end confdefs.h. */ -/* Define $ac_func to an innocuous variant, in case declares $ac_func. - For example, HP-UX 11i declares gettimeofday. */ -#define $ac_func innocuous_$ac_func - -/* System header to define __stub macros and hopefully few prototypes, - which can conflict with char $ac_func (); below. - Prefer to if __STDC__ is defined, since - exists even on freestanding compilers. */ - -#ifdef __STDC__ -# include -#else -# include -#endif - -#undef $ac_func - -/* Override any gcc2 internal prototype to avoid an error. */ -#ifdef __cplusplus -extern "C" -{ -#endif -/* We use char because int might match the return type of a gcc2 - builtin and then its argument prototype would still apply. */ -char $ac_func (); -/* The GNU C library defines this for functions which it implements - to always fail with ENOSYS. Some functions are actually named - something starting with __ and the normal name is an alias. */ -#if defined (__stub_$ac_func) || defined (__stub___$ac_func) -choke me -#else -char (*f) () = $ac_func; -#endif -#ifdef __cplusplus -} -#endif - -int -main () -{ -return f != $ac_func; - ; - return 0; -} -_ACEOF -rm -f conftest.$ac_objext conftest$ac_exeext -if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5 - (eval $ac_link) 2>conftest.er1 - ac_status=$? - grep -v '^ *+' conftest.er1 >conftest.err - rm -f conftest.er1 - cat conftest.err >&5 - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); } && - { ac_try='test -z "$ac_c_werror_flag" - || test ! -s conftest.err' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; } && - { ac_try='test -s conftest$ac_exeext' - { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5 - (eval $ac_try) 2>&5 - ac_status=$? - echo "$as_me:$LINENO: \$? = $ac_status" >&5 - (exit $ac_status); }; }; then - eval "$as_ac_var=yes" -else - echo "$as_me: failed program was:" >&5 -sed 's/^/| /' conftest.$ac_ext >&5 - -eval "$as_ac_var=no" -fi -rm -f conftest.err conftest.$ac_objext \ - conftest$ac_exeext conftest.$ac_ext -fi -echo "$as_me:$LINENO: result: `eval echo '${'$as_ac_var'}'`" >&5 -echo "${ECHO_T}`eval echo '${'$as_ac_var'}'`" >&6 -if test `eval echo '${'$as_ac_var'}'` = yes; then - cat >>confdefs.h <<_ACEOF -#define `echo "HAVE_$ac_func" | $as_tr_cpp` 1 -_ACEOF - -fi -done - - #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 #------------------------------------------------------------------------ diff --git a/unix/configure.in b/unix/configure.in index 5a7125e..37de8be 100644 --- a/unix/configure.in +++ b/unix/configure.in @@ -93,7 +93,6 @@ fi #------------------------------------------------------------------------ SC_ENABLE_THREADS -AC_CHECK_FUNCS(pthread_atfork) #------------------------------------------------------------------------ # Embedded configuration information, encoding to use for the values, TIP #59 diff --git a/unix/tcl.m4 b/unix/tcl.m4 index 879d810..f484989 100644 --- a/unix/tcl.m4 +++ b/unix/tcl.m4 @@ -679,7 +679,7 @@ AC_DEFUN([SC_ENABLE_THREADS], [ ac_saved_libs=$LIBS LIBS="$LIBS $THREADS_LIBS" - AC_CHECK_FUNCS(pthread_attr_setstacksize) + AC_CHECK_FUNCS(pthread_attr_setstacksize pthread_atfork) AC_CHECK_FUNC(pthread_attr_get_np,tcl_ok=yes,tcl_ok=no) if test $tcl_ok = yes ; then AC_DEFINE(HAVE_PTHREAD_ATTR_GET_NP, 1, -- cgit v0.12 From 9b087e12907c940eed87b510213ca363ef8d5a4b Mon Sep 17 00:00:00 2001 From: oehhar Date: Thu, 25 Jul 2013 17:20:02 +0000 Subject: Fixed test case variable clash with 'folder' --- tests/unixForkEvent.test | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/tests/unixForkEvent.test b/tests/unixForkEvent.test index a0c3f19..cbe582e 100644 --- a/tests/unixForkEvent.test +++ b/tests/unixForkEvent.test @@ -18,27 +18,27 @@ testConstraint testfork [llength [info commands testfork]] test unixforkevent-1.1 {fork and test writeable event} \ -constraints testfork \ -body { - set folder [makeDirectory unixtestfork] + set myFolder [makeDirectory unixtestfork] set pid [testfork] if {$pid == 0} { # we are the forked process set result initialized - set h [open [file join $folder test.txt] w] + set h [open [file join $myFolder test.txt] w] fileevent $h writable\ "set result writable;\ after cancel [after 1000 {set result timeout}]" vwait result close $h - makeFile $result result.txt $folder + makeFile $result result.txt $myFolder exit } # we are the original process - while {![file readable [file join $folder result.txt]]} {} - viewFile result.txt $folder + while {![file readable [file join $myFolder result.txt]]} {} + viewFile result.txt $myFolder } \ -result {writable} \ -cleanup { - catch { removeFolder $folder } + catch { removeFolder $myFolder } } ::tcltest::cleanupTests -- cgit v0.12 From c86bd1b78ad2eec0899db1c0927048cf9f0ed435 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 26 Jul 2013 13:21:30 +0000 Subject: [6585b21ca8] [regexp {(\w).*?\1} abb] failed to match. Thanks to Tom Lane for passing on the discovery in Postgres. --- generic/regexec.c | 7 +------ tests/regexp.test | 4 ++++ 2 files changed, 5 insertions(+), 6 deletions(-) diff --git a/generic/regexec.c b/generic/regexec.c index c902209..205fcc2 100644 --- a/generic/regexec.c +++ b/generic/regexec.c @@ -512,12 +512,7 @@ cfindloop( return er; } if ((shorter) ? end == estop : end == begin) { - /* - * No point in trying again. - */ - - *coldp = cold; - return REG_NOMATCH; + break; } /* diff --git a/tests/regexp.test b/tests/regexp.test index 8138054..362f425 100644 --- a/tests/regexp.test +++ b/tests/regexp.test @@ -728,6 +728,10 @@ test regexp-22.5 {Bug 3610026} -setup { } -cleanup { unset -nocomplain e cp } -returnCodes error -match glob -result {*too many colors*} +test regexp-22.6 {Bug 6585b21ca8} { + expr {[regexp {(\w).*?\1} Programmer m] ? $m : ""} +} rogr + test regexp-23.1 {regexp -all and -line} { set string "" -- cgit v0.12 From 83bd34e627b2f9c0c0b5fe3917e82f3428dc9565 Mon Sep 17 00:00:00 2001 From: dgp Date: Sat, 27 Jul 2013 20:29:42 +0000 Subject: Simplify AuxData access with a macro. --- generic/tclAssembly.c | 2 +- generic/tclCompile.c | 1 + generic/tclCompile.h | 9 +++++++++ tests/subst.test | 4 ++++ 4 files changed, 15 insertions(+), 1 deletion(-) diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 6bf2fa8..100e9ef 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -3047,7 +3047,7 @@ ResolveJumpTableTargets( auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1); DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n", bbPtr, bbPtr->jumpOffset, auxDataIndex); - realJumpTablePtr = envPtr->auxDataArrayPtr[auxDataIndex].clientData; + realJumpTablePtr = TclFetchAuxData(envPtr, auxDataIndex); realJumpHashPtr = &realJumpTablePtr->hashTable; /* diff --git a/generic/tclCompile.c b/generic/tclCompile.c index e4da2ba..772ce22 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -2055,6 +2055,7 @@ TclCompileScript( #ifdef TCL_COMPILE_DEBUG /* * If tracing, print a line for each top level command compiled. + * TODO: Suppress when numWords == 0 ? */ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 56315db..beb28fd 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -1113,6 +1113,15 @@ MODULE_SCOPE Tcl_Obj *TclNewInstNameObj(unsigned char inst); *---------------------------------------------------------------- */ +/* + * Simplified form to access AuxData. + * + * ClientData TclFetchAuxData(CompileEng *envPtr, int index); + */ + +#define TclFetchAuxData(envPtr, index) \ + (envPtr)->auxDataArrayPtr[(index)].clientData + #define LITERAL_ON_HEAP 0x01 #define LITERAL_CMD_NAME 0x02 diff --git a/tests/subst.test b/tests/subst.test index 4be4798..7466895 100644 --- a/tests/subst.test +++ b/tests/subst.test @@ -293,6 +293,10 @@ test subst-13.1 {Bug 3081065} -setup { } -cleanup { removeFile subst13.tcl } +test subst-13.2 {Test for segfault} -body { + subst {[} +} -returnCodes error -result * -match glob + # cleanup ::tcltest::cleanupTests -- cgit v0.12 From 35f064fd91f1a987c493f4740df59d3a0f162a42 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 29 Jul 2013 09:29:16 +0000 Subject: Make sure that "string is space \u202f" will continue to return "1", even if in future Unicode this character (NARROW_NO_BREAK_SPACE) will cease to be a space. See: [http://www.unicode.org/review/pri249/] --- generic/tclUtf.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclUtf.c b/generic/tclUtf.c index a038f8a..e5497a4 100644 --- a/generic/tclUtf.c +++ b/generic/tclUtf.c @@ -1555,7 +1555,7 @@ Tcl_UniCharIsSpace( if (((Tcl_UniChar) ch) < ((Tcl_UniChar) 0x80)) { return TclIsSpaceProc((char) ch); - } else if ((Tcl_UniChar) ch == 0x180e) { + } else if ((Tcl_UniChar) ch == 0x180e || (Tcl_UniChar) ch == 0x202f) { return 1; } else { return ((SPACE_BITS >> GetCategory(ch)) & 1); -- cgit v0.12 From 2145004977c06c1989ad5ad0ee2d800da3353001 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 1 Aug 2013 19:18:02 +0000 Subject: [1905562] [8d2c0da36d] Raise the recursion limits on regexps to allow existing regexps "in the wild" to continue working with Tcl 8.6. Latest example comes from DejaGnu. --- generic/regc_nfa.c | 2 +- tests/reg.test | 3 +++ 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/generic/regc_nfa.c b/generic/regc_nfa.c index fc0c823..42489dd 100644 --- a/generic/regc_nfa.c +++ b/generic/regc_nfa.c @@ -824,7 +824,7 @@ duptraverse( * make all normal tests (not reg-33.14) pass. */ #ifndef DUPTRAVERSE_MAX_DEPTH -#define DUPTRAVERSE_MAX_DEPTH 700 +#define DUPTRAVERSE_MAX_DEPTH 15000 #endif if (depth++ > DUPTRAVERSE_MAX_DEPTH) { diff --git a/tests/reg.test b/tests/reg.test index 559f549..e6ce42c 100644 --- a/tests/reg.test +++ b/tests/reg.test @@ -1155,6 +1155,9 @@ test reg-33.15 {Bug 3603557 - an "in the wild" RE} { (.*) # ConditionalFields }] 0 } 68 +test reg-33.16 {Bug [8d2c0da36d]- another "in the wild" RE} { + lindex [regexp -about "^MRK:client1: =1339 14HKelly Talisman 10011000 (\[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]*) \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 8 0 8 0 0 0 77 77 1 1 2 0 11 { 1 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 13HC6 My Creator 2 3 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 31HC7 Slightly offensive name, huh 3 8 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 23HE-mail:kelly@hotbox.com 4 9 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 17Hcompface must die 5 10 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 3HAir 6 12 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 14HPGP public key 7 13 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 16Hkelly@hotbox.com 8 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 12H2 text/plain 9 30 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 0 13H2 x-kom/basic 10 33 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H0 11 14 8 \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* \[0-9\]* 00000000 1 1H3 }\r?"] 0 +} 1 # cleanup ::tcltest::cleanupTests -- cgit v0.12