Tcl package Thread source code

Check-in [3d2f5a0b19]
Login
Bounty program for improvements to Tcl and certain Tcl packages.
Tcl 2019 Conference, Houston/TX, US, Nov 4-8
Send your abstracts to [email protected]
or submit via the online form by Sep 9.

Many hyperlinks are disabled.
Use anonymous login to enable hyperlinks.

Overview
Comment:merge compileTipCheck to trunk
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA1: 3d2f5a0b191cdb56a3fd742464e668c58d9f2c00
User & Date: jan.nijtmans 2012-11-13 23:23:58
Context
2012-11-13
23:36
comment fix check-in: 4b24fe1d2c user: jan.nijtmans tags: trunk
23:23
merge compileTipCheck to trunk check-in: 3d2f5a0b19 user: jan.nijtmans tags: trunk
23:15
simplify some things, and make it work against Tcl 8.4/8.5 again Closed-Leaf check-in: e187578bb3 user: jan.nijtmans tags: compileTipCheck
11:00
AOL/Naviserver fix check-in: 7975acc2c4 user: jan.nijtmans tags: trunk
Changes
Hide Diffs Side-by-Side Diffs Ignore Whitespace Patch

Changes to configure.

 11345  11345   #--------------------------------------------------------------------
 11346  11346   
 11347  11347   
 11348  11348   cat >>confdefs.h <<\_ACEOF
 11349  11349   #define USE_TCL_STUBS 1
 11350  11350   _ACEOF
 11351  11351   
        11352  +
        11353  +#--------------------------------------------------------------------
        11354  +# Enable compile-time support for TIP #143 and TIP #285.  When using
        11355  +# a pre-Tcl 8.5 or 8.6 core, respectively, the actual functionality
        11356  +# will not be available at runtime.
        11357  +#--------------------------------------------------------------------
        11358  +
        11359  +
        11360  +cat >>confdefs.h <<\_ACEOF
        11361  +#define TCL_TIP143 1
        11362  +_ACEOF
        11363  +
        11364  +
        11365  +cat >>confdefs.h <<\_ACEOF
        11366  +#define TCL_TIP285 1
        11367  +_ACEOF
        11368  +
 11352  11369   
 11353  11370   #--------------------------------------------------------------------
 11354  11371   # This macro generates a line to use when building a library.  It
 11355  11372   # depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS,
 11356  11373   # and TEA_LOAD_TCLCONFIG macros above.
 11357  11374   #--------------------------------------------------------------------
 11358  11375   

Changes to configure.in.

   179    179   # Everyone should be linking against the Tcl stub library.  If you
   180    180   # can't for some reason, remove this definition.  If you aren't using
   181    181   # stubs, you also need to modify the SHLIB_LD_LIBS setting below to
   182    182   # link against the non-stubbed Tcl library.  Add Tk too if necessary.
   183    183   #--------------------------------------------------------------------
   184    184   
   185    185   AC_DEFINE(USE_TCL_STUBS, 1, [Use Tcl stubs])
          186  +
          187  +#--------------------------------------------------------------------
          188  +# Enable compile-time support for TIP #143 and TIP #285.  When using
          189  +# a pre-Tcl 8.5 or 8.6 core, respectively, the actual functionality
          190  +# will not be available at runtime.
          191  +#--------------------------------------------------------------------
          192  +
          193  +AC_DEFINE(TCL_TIP143, 1, [Enable TIP #143 support])
          194  +AC_DEFINE(TCL_TIP285, 1, [Enable TIP #285 support])
   186    195   
   187    196   #--------------------------------------------------------------------
   188    197   # This macro generates a line to use when building a library.  It
   189    198   # depends on values set by the TEA_ENABLE_SHARED, TEA_ENABLE_SYMBOLS,
   190    199   # and TEA_LOAD_TCLCONFIG macros above.
   191    200   #--------------------------------------------------------------------
   192    201   

Changes to generic/threadCmd.c.

    18     18    * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
    19     19    * ----------------------------------------------------------------------------
    20     20    */
    21     21   
    22     22   #include "tclThreadInt.h"
    23     23   
    24     24   /*
    25         - * Check if this is Tcl 8.5 or higher. In that case, we will have the TIP
           25  + * Check if this is Tcl 8.5 or higher.  In that case, we will have the TIP
    26     26    * #143 APIs (i.e. interpreter resource limiting) available.
    27     27    */
           28  +
           29  +#ifndef TCL_TIP143
           30  +# if (TCL_MAJOR_VERSION > 8) || \
           31  +     ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 5))
           32  +#  define TCL_TIP143
           33  +# endif
           34  +#endif
           35  +
           36  +/*
           37  + * If TIP #143 support is enabled and we are compiling against a pre-Tcl 8.5
           38  + * core, hard-wire the necessary APIs using the "well-known" offsets into the 
           39  + * stubs table.
           40  + */
    28     41   
    29     42   #define haveInterpLimit (tclVersion>84)
    30         -#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 5)
    31         -# define Tcl_LimitExceeded ((int (*)(Tcl_Interp *)) \
    32         -    ((&(tclStubsPtr->tcl_PkgProvideEx))[524]))
           43  +#if defined(TCL_TIP143) && (TCL_MAJOR_VERSION == 8) && \
           44  +    (TCL_MINOR_VERSION < 5)
           45  +# if defined(USE_TCL_STUBS)
           46  +#  define Tcl_LimitExceeded ((int (*)(Tcl_Interp *)) \
           47  +     ((&(tclStubsPtr->tcl_PkgProvideEx))[524]))
           48  +# else
           49  +#  error "Supporting TIP #143 requires USE_TCL_STUBS before Tcl 8.5"
           50  +# endif
    33     51   #endif
    34     52   
    35     53   /*
    36     54    * Check if this is Tcl 8.6 or higher.  In that case, we will have the TIP
    37     55    * #285 APIs (i.e. asynchronous script cancellation) available.
    38     56    */
    39     57   
    40     58   #define haveInterpCancel (tclVersion>85)
    41         -#if (TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION < 6)
    42         -# define TCL_CANCEL_UNWIND 0x100000
    43         -# define Tcl_CancelEval ((int (*)(Tcl_Interp *, Tcl_Obj *, ClientData, int)) \
    44         -    ((&(tclStubsPtr->tcl_PkgProvideEx))[580]))
    45         -# define Tcl_Canceled ((int (*)(Tcl_Interp *, int)) \
    46         -    ((&(tclStubsPtr->tcl_PkgProvideEx))[581]))
           59  +#ifndef TCL_TIP285
           60  +# if (TCL_MAJOR_VERSION > 8) || \
           61  +     ((TCL_MAJOR_VERSION == 8) && (TCL_MINOR_VERSION >= 6))
           62  +#  define TCL_TIP285
           63  +# endif
           64  +#endif
           65  +
           66  +/*
           67  + * If TIP #285 support is enabled and we are compiling against a pre-Tcl 8.6
           68  + * core, hard-wire the necessary APIs using the "well-known" offsets into the 
           69  + * stubs table.
           70  + */
           71  +
           72  +#if defined(TCL_TIP285) && (TCL_MAJOR_VERSION == 8) && \
           73  +    (TCL_MINOR_VERSION < 6)
           74  +# if defined(USE_TCL_STUBS)
           75  +#  define TCL_CANCEL_UNWIND	0x100000
           76  +#  define Tcl_CancelEval ((int (*)(Tcl_Interp *, Tcl_Obj *, ClientData, int)) \
           77  +     ((&(tclStubsPtr->tcl_PkgProvideEx))[580]))
           78  +#  define Tcl_Canceled ((int (*)(Tcl_Interp *, int)) \
           79  +     ((&(tclStubsPtr->tcl_PkgProvideEx))[581]))
           80  +# else
           81  +#  error "Supporting TIP #285 requires USE_TCL_STUBS before Tcl 8.6"
           82  +# endif
    47     83   #endif
    48     84   
    49     85   /*
    50     86    * Access to the list of threads and to the thread send results
    51     87    * (defined below) is guarded by this mutex.
    52     88    */
    53     89   
................................................................................
   103    139   
   104    140   /*
   105    141    * Used to represent the empty result.
   106    142    */
   107    143   
   108    144   static char *threadEmptyResult = (char *)"";
   109    145   
          146  +#if defined(TCL_TIP143) || defined(TCL_TIP285)
   110    147   static int tclVersion = 0;
          148  +#endif
   111    149   
   112    150   /*
   113    151    * An instance of the following structure contains all information that is
   114    152    * passed into a new thread when the thread is created using either the
   115    153    * "thread create" Tcl command or the ThreadCreate() C function.
   116    154    */
   117    155   
................................................................................
   350    388   static void
   351    389   ErrorNoSuchThread(Tcl_Interp *interp,
   352    390                                  Tcl_ThreadId thrId);
   353    391   static void
   354    392   ThreadCutChannel(Tcl_Interp *interp,
   355    393                                  Tcl_Channel channel);
   356    394   
          395  +#ifdef TCL_TIP285
   357    396   static int
   358    397   ThreadCancel(Tcl_Interp *interp,
   359    398                                  Tcl_ThreadId thrId,
   360    399                                  const char *result,
   361    400                                  int flags);
          401  +#endif
   362    402   
   363    403   /*
   364    404    * Functions implementing Tcl commands
   365    405    */
   366    406   
   367    407   static Tcl_ObjCmdProc ThreadCreateObjCmd;
   368    408   static Tcl_ObjCmdProc ThreadReserveObjCmd;
................................................................................
   377    417   static Tcl_ObjCmdProc ThreadExistsObjCmd;
   378    418   static Tcl_ObjCmdProc ThreadConfigureObjCmd;
   379    419   static Tcl_ObjCmdProc ThreadErrorProcObjCmd;
   380    420   static Tcl_ObjCmdProc ThreadJoinObjCmd;
   381    421   static Tcl_ObjCmdProc ThreadTransferObjCmd;
   382    422   static Tcl_ObjCmdProc ThreadDetachObjCmd;
   383    423   static Tcl_ObjCmdProc ThreadAttachObjCmd;
          424  +
          425  +#ifdef TCL_TIP285
   384    426   static Tcl_ObjCmdProc ThreadCancelObjCmd;
          427  +#endif
   385    428   
   386    429   static int
   387    430   ThreadInit(interp)
   388    431       Tcl_Interp *interp; /* The current Tcl interpreter */
   389    432   {
   390    433       if (Tcl_InitStubs(interp, "8.4", 0) == NULL) {
   391    434           return TCL_ERROR;
   392    435       }
   393    436   
          437  +#if defined(TCL_TIP143) || defined(TCL_TIP285)
   394    438       if (!tclVersion) {
   395    439   
   396         -        /*
   397         -         * Get the current core version to decide wether to use
   398         -         * some lately introduced core features or to back-off.
   399         -         */
          440  +	/*
          441  +	 * Get the current core version to decide whether to use
          442  +	 * some lately introduced core features or to back-off.
          443  +	 */
   400    444   
   401         -        int major, minor;
   402         -        
   403         -        Tcl_GetVersion(&major, &minor, NULL, NULL);
   404         -        tclVersion = 10 * major + minor;
          445  +	int major, minor;
          446  +
          447  +	Tcl_GetVersion(&major, &minor, NULL, NULL);
          448  +	tclVersion = 10 * major + minor;
   405    449       }
          450  +#endif
   406    451   
   407    452       TCL_CMD(interp, THREAD_CMD_PREFIX"create",    ThreadCreateObjCmd);
   408    453       TCL_CMD(interp, THREAD_CMD_PREFIX"send",      ThreadSendObjCmd);
   409    454       TCL_CMD(interp, THREAD_CMD_PREFIX"broadcast", ThreadBroadcastObjCmd);
   410    455       TCL_CMD(interp, THREAD_CMD_PREFIX"exit",      ThreadExitObjCmd);
   411    456       TCL_CMD(interp, THREAD_CMD_PREFIX"unwind",    ThreadUnwindObjCmd);
   412    457       TCL_CMD(interp, THREAD_CMD_PREFIX"id",        ThreadIdObjCmd);
................................................................................
   417    462       TCL_CMD(interp, THREAD_CMD_PREFIX"errorproc", ThreadErrorProcObjCmd);
   418    463       TCL_CMD(interp, THREAD_CMD_PREFIX"preserve",  ThreadReserveObjCmd);
   419    464       TCL_CMD(interp, THREAD_CMD_PREFIX"release",   ThreadReleaseObjCmd);
   420    465       TCL_CMD(interp, THREAD_CMD_PREFIX"join",      ThreadJoinObjCmd);
   421    466       TCL_CMD(interp, THREAD_CMD_PREFIX"transfer",  ThreadTransferObjCmd);
   422    467       TCL_CMD(interp, THREAD_CMD_PREFIX"detach",    ThreadDetachObjCmd);
   423    468       TCL_CMD(interp, THREAD_CMD_PREFIX"attach",    ThreadAttachObjCmd);
          469  +#ifdef TCL_TIP285
   424    470       TCL_CMD(interp, THREAD_CMD_PREFIX"cancel",    ThreadCancelObjCmd);
          471  +#endif
   425    472   
   426    473       /*
   427    474        * Add shared variable commands
   428    475        */
   429    476   
   430    477       Sv_Init(interp);
   431    478   
................................................................................
  1442   1489               return TCL_ERROR;
  1443   1490           }
  1444   1491       }
  1445   1492   
  1446   1493       return TCL_OK;
  1447   1494   }
  1448   1495   
         1496  +#ifdef TCL_TIP285
  1449   1497   /*
  1450   1498    *----------------------------------------------------------------------
  1451   1499    *
  1452   1500    * ThreadCancelObjCmd --
  1453   1501    *
  1454   1502    *  This procedure is invoked to process the "thread::cancel" Tcl
  1455   1503    *  command. See the user documentation for details on what it does.
................................................................................
  1497   1545           result = Tcl_GetString(objv[ii]);
  1498   1546       } else {
  1499   1547           result = NULL;
  1500   1548       }
  1501   1549   
  1502   1550       return ThreadCancel(interp, thrId, result, flags);
  1503   1551   }
         1552  +#endif
  1504   1553   
  1505   1554   /*
  1506   1555    *----------------------------------------------------------------------
  1507   1556    *
  1508   1557    * ThreadSendEval --
  1509   1558    *
  1510   1559    *  Evaluates Tcl script passed from source to target thread.
................................................................................
  2112   2161               return tsdPtr;
  2113   2162           }
  2114   2163       }
  2115   2164   
  2116   2165       return NULL;
  2117   2166   }
  2118   2167   
         2168  +#ifdef TCL_TIP285
  2119   2169   /*
  2120   2170    *----------------------------------------------------------------------
  2121   2171    *
  2122   2172    * ThreadCancel --
  2123   2173    *
  2124   2174    *    Cancels a script in another thread.
  2125   2175    *
................................................................................
  2137   2187       Tcl_Interp  *interp;        /* The current interpreter. */
  2138   2188       Tcl_ThreadId thrId;         /* Thread ID of other interpreter. */
  2139   2189       const char *result;         /* The error message or NULL for default. */
  2140   2190       int flags;                  /* Flags for Tcl_CancelEval. */
  2141   2191   {
  2142   2192       int code;
  2143   2193       Tcl_Obj *resultObj = NULL;
  2144         -
  2145   2194       ThreadSpecificData *tsdPtr; /* ... of the target thread */
  2146   2195   
  2147   2196       Tcl_MutexLock(&threadMutex);
  2148   2197   
  2149   2198       tsdPtr = ThreadExistsInner(thrId);
  2150   2199       if (tsdPtr == (ThreadSpecificData*)NULL) {
  2151   2200           Tcl_MutexUnlock(&threadMutex);
................................................................................
  2162   2211       if (result != NULL) {
  2163   2212           resultObj = Tcl_NewStringObj(result, -1);
  2164   2213       }
  2165   2214   
  2166   2215       code = Tcl_CancelEval(tsdPtr->interp, resultObj, NULL, flags);
  2167   2216   
  2168   2217       Tcl_MutexUnlock(&threadMutex);
  2169         -
  2170   2218       return code;
  2171   2219   }
         2220  +#endif
  2172   2221   
  2173   2222   /*
  2174   2223    *----------------------------------------------------------------------
  2175   2224    *
  2176   2225    * ThreadJoin --
  2177   2226    *
  2178   2227    *  Wait for the exit of a different thread.
................................................................................
  2778   2827            * a script in progress to be canceled or exceed its limit;
  2779   2828            * therefore, check for these conditions if we are able to
  2780   2829            * (i.e. we are running in a high enough version of Tcl).
  2781   2830            */
  2782   2831   
  2783   2832           Tcl_DoOneEvent(TCL_ALL_EVENTS);
  2784   2833   
         2834  +#ifdef TCL_TIP285
  2785   2835           if (haveInterpCancel) {
  2786   2836   
  2787   2837               /*
  2788   2838                * If the script has been unwound, bail out immediately. This does
  2789   2839                * not follow the recommended guidelines for how extensions should
  2790   2840                * handle the script cancellation functionality because this is
  2791   2841                * not a "normal" extension. Most extensions do not have a command
................................................................................
  2796   2846   
  2797   2847               if (Tcl_Canceled(tsdPtr->interp,
  2798   2848                       TCL_LEAVE_ERR_MSG | TCL_CANCEL_UNWIND) == TCL_ERROR) {
  2799   2849                   code = TCL_ERROR;
  2800   2850                   break;
  2801   2851               }
  2802   2852           }
         2853  +#endif
         2854  +#ifdef TCL_TIP143
  2803   2855           if (haveInterpLimit) {
  2804   2856               if (Tcl_LimitExceeded(tsdPtr->interp)) {
  2805   2857                   code = TCL_ERROR;
  2806   2858                   break;
  2807   2859               }
  2808   2860           }
         2861  +#endif
  2809   2862   
  2810   2863           /*
  2811   2864            * Test stop condition under mutex since
  2812   2865            * some other thread may flip our flags.
  2813   2866            */
  2814   2867   
  2815   2868           Tcl_MutexLock(&threadMutex);
  2816   2869           canrun = (tsdPtr->flags & THREAD_FLAGS_STOPPED) == 0;
  2817   2870           Tcl_MutexUnlock(&threadMutex);
  2818   2871       }
  2819   2872   
         2873  +#if defined(TCL_TIP143) || defined(TCL_TIP285)
  2820   2874       /*
  2821   2875        * If the event processing loop above was terminated due to a
  2822   2876        * script in progress being canceled or exceeding its limits,
  2823         -     * transfer the error to the current interpreter.
         2877  +     * call the registered error processing script now, if there
         2878  +     * is one.
  2824   2879        */
  2825   2880   
  2826   2881       if (code != TCL_OK) {
  2827   2882           char buf[THREAD_HNDLMAXLEN];
  2828   2883           const char *errorInfo;
  2829   2884   
  2830   2885           errorInfo = Tcl_GetVar(tsdPtr->interp, "errorInfo", TCL_GLOBAL_ONLY);
................................................................................
  2832   2887           	errorInfo = Tcl_GetStringResult(tsdPtr->interp);
  2833   2888           }
  2834   2889   
  2835   2890           ThreadGetHandle(Tcl_GetCurrentThread(), buf);
  2836   2891           Tcl_AppendResult(interp, "Error from thread ", buf, "\n",
  2837   2892                   errorInfo, NULL);
  2838   2893       }
         2894  +#endif
  2839   2895   
  2840   2896       /*
  2841   2897        * Remove from the list of active threads, so nobody can post
  2842   2898        * work to this thread, since it is just about to terminate.
  2843   2899        */
  2844   2900   
  2845   2901       ListRemove(tsdPtr);

Changes to win/makefile.vc.

   243    243   crt = -MTd
   244    244   !else
   245    245   crt = -MT
   246    246   !endif
   247    247   !endif
   248    248   
   249    249   cflags = $(cflags) -DMODULE_SCOPE=extern
          250  +cflags = $(cflags) -DTCL_TIP143 -DTCL_TIP285
   250    251   
   251    252   !if !$(STATIC_BUILD)
   252    253   cflags = $(cflags) -DUSE_TCL_STUBS
   253    254   !if defined(TKSTUBLIB)
   254    255   cflags = $(cflags) -DUSE_TK_STUBS
   255    256   !endif
   256    257   !endif