Tcl package Thread source code

Check-in [f2411eb665]
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 sebres-fix-persist-storage branches
Downloads: Tarball | ZIP archive | SQL archive
Timelines: family | ancestors | descendants | both | trunk
Files: files | file ages | folders
SHA3-256: f2411eb6650af0fa4da6dbc65accdb8398041c656f4c6b117a16a3fff61b1c99
User & Date: sebres 2017-11-23 16:00:24
Context
2017-12-01
15:21
update to latest TEA. Add "wideInt" as additional 'safe' type for threadSvCmd.c check-in: 813d7e13e9 user: jan.nijtmans tags: trunk
2017-11-23
16:00
merge sebres-fix-persist-storage branches check-in: f2411eb665 user: sebres tags: trunk
2017-11-08
09:17
Update Thread version number to 2.8.2 check-in: 4ee2a339ed user: jan.nijtmans tags: trunk
2017-07-19
18:36
[win] allow lmdb (persistent storage) handler, if compiling for windows: ADDLINKOPTS and ADDOPTDEFINES can be specified to provide extra link- and compiler-options, for example: nmake -nologo -f makefile.vc TCLDIR=%TCLDIR% ... ADDOPTDEFINES="-I%LMDBDIR%" ADDLINKOPTS="%LMDBDIR%\Release\lmdb.lib" Closed-Leaf check-in: 31d323157d user: sebres tags: sebres-fix-persist-storage-win
18:26
leave entries in persistent bound storage on exit handler (avoid flushing data by delete array, causes if tcl-application properly exits with call of all exit-handlers); additionally fixes memory leak on arrayPtr->bindAddr by unbind; Closed-Leaf check-in: c00a271dae user: sebres tags: sebres-fix-persist-storage
Changes
Hide Diffs Unified Diffs Ignore Whitespace Patch

Changes to generic/threadSvCmd.c.

112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
...
832
833
834
835
836
837
838
839






















840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
....
1377
1378
1379
1380
1381
1382
1383
1384
1385
1386
1387
1388
1389
1390
1391
1392
1393
1394
1395
1396




1397
1398
1399
1400
1401
1402
1403
....
1442
1443
1444
1445
1446
1447
1448
1449
1450
1451
1452
1453
1454
1455
1456
....
2348
2349
2350
2351
2352
2353
2354



2355
2356
2357
2358
2359
2360
2361
2362
static Array* CreateArray(Bucket*, const char*);
static Array* LockArray(Tcl_Interp*, const char*, int);

static int ReleaseContainer(Tcl_Interp*, Container*, int);
static int DeleteContainer(Container*);
static int FlushArray(Array*);
static int DeleteArray(Array*);

static void SvAllocateContainers(Bucket*);
static void SvRegisterStdCommands(void);

#ifdef SV_FINALIZE
static void SvFinalizeContainers(Bucket*);
static void SvFinalize(ClientData);
................................................................................
 * Side effects:
 *      Memory gets reclaimed.
 *
 *-----------------------------------------------------------------------------
 */

static int
DeleteArray(Array *arrayPtr)






















{
    if (FlushArray(arrayPtr) == -1) {
        return TCL_ERROR;
    }
    if (arrayPtr->psPtr) {
        PsStore *psPtr = arrayPtr->psPtr;
        if (psPtr->psClose(psPtr->psHandle) == -1) {
            return TCL_ERROR;
        }
        ckfree((char*)arrayPtr->psPtr), arrayPtr->psPtr = NULL;
    }
    if (arrayPtr->bindAddr) {
        ckfree(arrayPtr->bindAddr);
    }
    if (arrayPtr->entryPtr) {
        Tcl_DeleteHashEntry(arrayPtr->entryPtr);
    }

    Tcl_DeleteHashTable(&arrayPtr->vars);
    ckfree((char*)arrayPtr);
................................................................................
                hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &new);
                Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj));
                psPtr->psFree(psPtr->psHandle, val);
            } while (!psPtr->psNext(psPtr->psHandle, &key, &val, &len));
        }

    } else if (index == AUNBIND) {
        if (arrayPtr && arrayPtr->psPtr) {
            PsStore *psPtr = arrayPtr->psPtr;
            if (psPtr->psClose(psPtr->psHandle) == -1) {
                const char *err = psPtr->psError(psPtr->psHandle);
                Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
                ret = TCL_ERROR;
                goto cmdExit;
            }
            ckfree((char*)arrayPtr->psPtr), arrayPtr->psPtr = NULL;
        } else {
            Tcl_AppendResult(interp, "shared variable is not bound", NULL);
            ret = TCL_ERROR;
            goto cmdExit;




        }
    }

 cmdExit:
    if (arrayPtr) {
        UnlockArray(arrayPtr);
    }
................................................................................
    arrayPtr  = LockArray(interp, arrayName, 0);

    if (arrayPtr == NULL) {
        return TCL_ERROR;
    }
    if (objc == 2) {
        UnlockArray(arrayPtr);
        if (DeleteArray(arrayPtr) != TCL_OK) {
            return TCL_ERROR;
        }
    } else {
        for (ii = 2; ii < objc; ii++) {
            const char *key = Tcl_GetString(objv[ii]);
            Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key);
            if (hPtr) {
................................................................................
        if (buckets != NULL) {
            for (i = 0; i < NUMBUCKETS; ++i) {
                Bucket *bucketPtr = &buckets[i];
                hashPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search);
                while (hashPtr != NULL) {
                    Array *arrayPtr = (Array*)Tcl_GetHashValue(hashPtr);
                    UnlockArray(arrayPtr);



                    DeleteArray(arrayPtr);
                    hashPtr = Tcl_NextHashEntry(&search);
                }
                if (bucketPtr->lock) {
                    Sp_RecursiveMutexFinalize(&bucketPtr->lock);
                }
                SvFinalizeContainers(bucketPtr);
                Tcl_DeleteHashTable(&bucketPtr->handles);






|







 







|
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>
>





|
<

|
<
<
<
<







 







|
<
<
<
<
<
<
<
<
<



>
>
>
>







 







|







 







>
>
>
|







112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
...
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867

868
869




870
871
872
873
874
875
876
....
1394
1395
1396
1397
1398
1399
1400
1401









1402
1403
1404
1405
1406
1407
1408
1409
1410
1411
1412
1413
1414
1415
....
1454
1455
1456
1457
1458
1459
1460
1461
1462
1463
1464
1465
1466
1467
1468
....
2360
2361
2362
2363
2364
2365
2366
2367
2368
2369
2370
2371
2372
2373
2374
2375
2376
2377
static Array* CreateArray(Bucket*, const char*);
static Array* LockArray(Tcl_Interp*, const char*, int);

static int ReleaseContainer(Tcl_Interp*, Container*, int);
static int DeleteContainer(Container*);
static int FlushArray(Array*);
static int DeleteArray(Tcl_Interp *, Array*);

static void SvAllocateContainers(Bucket*);
static void SvRegisterStdCommands(void);

#ifdef SV_FINALIZE
static void SvFinalizeContainers(Bucket*);
static void SvFinalize(ClientData);
................................................................................
 * Side effects:
 *      Memory gets reclaimed.
 *
 *-----------------------------------------------------------------------------
 */

static int
UnbindArray(Tcl_Interp *interp, Array *arrayPtr)
{
    PsStore *psPtr = arrayPtr->psPtr;
    if (arrayPtr->bindAddr) {
        ckfree(arrayPtr->bindAddr);
        arrayPtr->bindAddr = NULL;
    }
    if (psPtr) {
        if (psPtr->psClose(psPtr->psHandle) == -1) {
            if (interp) {
                const char *err = psPtr->psError(psPtr->psHandle);
                Tcl_SetObjResult(interp, Tcl_NewStringObj(err, -1));
            }
            return TCL_ERROR;
        }
        ckfree((char*)arrayPtr->psPtr), arrayPtr->psPtr = NULL;
        arrayPtr->psPtr = NULL;
    }
    return TCL_OK;
}

static int
DeleteArray(Tcl_Interp *interp, Array *arrayPtr)
{
    if (FlushArray(arrayPtr) == -1) {
        return TCL_ERROR;
    }
    if (arrayPtr->psPtr) {
        if (UnbindArray(interp, arrayPtr) != TCL_OK) {

            return TCL_ERROR;
        };




    }
    if (arrayPtr->entryPtr) {
        Tcl_DeleteHashEntry(arrayPtr->entryPtr);
    }

    Tcl_DeleteHashTable(&arrayPtr->vars);
    ckfree((char*)arrayPtr);
................................................................................
                hPtr = Tcl_CreateHashEntry(&arrayPtr->vars, key, &new);
                Tcl_SetHashValue(hPtr, CreateContainer(arrayPtr, hPtr, tclObj));
                psPtr->psFree(psPtr->psHandle, val);
            } while (!psPtr->psNext(psPtr->psHandle, &key, &val, &len));
        }

    } else if (index == AUNBIND) {
        if (!arrayPtr || !arrayPtr->psPtr) {









            Tcl_AppendResult(interp, "shared variable is not bound", NULL);
            ret = TCL_ERROR;
            goto cmdExit;
        }
        if (UnbindArray(interp, arrayPtr) != TCL_OK) {
            ret = TCL_ERROR;
            goto cmdExit;
        }
    }

 cmdExit:
    if (arrayPtr) {
        UnlockArray(arrayPtr);
    }
................................................................................
    arrayPtr  = LockArray(interp, arrayName, 0);

    if (arrayPtr == NULL) {
        return TCL_ERROR;
    }
    if (objc == 2) {
        UnlockArray(arrayPtr);
        if (DeleteArray(interp, arrayPtr) != TCL_OK) {
            return TCL_ERROR;
        }
    } else {
        for (ii = 2; ii < objc; ii++) {
            const char *key = Tcl_GetString(objv[ii]);
            Tcl_HashEntry *hPtr = Tcl_FindHashEntry(&arrayPtr->vars, key);
            if (hPtr) {
................................................................................
        if (buckets != NULL) {
            for (i = 0; i < NUMBUCKETS; ++i) {
                Bucket *bucketPtr = &buckets[i];
                hashPtr = Tcl_FirstHashEntry(&bucketPtr->arrays, &search);
                while (hashPtr != NULL) {
                    Array *arrayPtr = (Array*)Tcl_GetHashValue(hashPtr);
                    UnlockArray(arrayPtr);
                    /* unbind array before delete (avoid flush of persistent storage) */
                    UnbindArray(NULL, arrayPtr);
                    /* flush, delete etc. */
                    DeleteArray(NULL, arrayPtr);
                    hashPtr = Tcl_NextHashEntry(&search);
                }
                if (bucketPtr->lock) {
                    Sp_RecursiveMutexFinalize(&bucketPtr->lock);
                }
                SvFinalizeContainers(bucketPtr);
                Tcl_DeleteHashTable(&bucketPtr->handles);

Changes to win/makefile.vc.

166
167
168
169
170
171
172

173
174
175
176
177
178
179
...
418
419
420
421
422
423
424


425
426
427
428
429
430
431
DLLOBJS = \
	$(TMP_DIR)\threadNs.obj \
	$(TMP_DIR)\threadCmd.obj \
	$(TMP_DIR)\threadSvCmd.obj \
	$(TMP_DIR)\threadSpCmd.obj \
	$(TMP_DIR)\threadPoolCmd.obj \
	$(TMP_DIR)\psGdbm.obj \

	$(TMP_DIR)\threadSvListCmd.obj \
	$(TMP_DIR)\threadSvKeylistCmd.obj \
	$(TMP_DIR)\tclXkeylist.obj \
	$(TMP_DIR)\threadWin.obj \
!if !$(STATIC_BUILD)
	$(TMP_DIR)\thread.res
!endif
................................................................................
#-------------------------------------------------------------------------
# Explicit dependency rules
#
#-------------------------------------------------------------------------

#{$(WINDIR)}.c{$(TMP_DIR)}.obj ::
$(GENERICDIR)\psGdbm.c: $(GENERICDIR)\psGdbm.h


$(GENERICDIR)\threadSpCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadSvCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadPoolCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadSvListCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadSvKeylistCmd.c : $(GENERICDIR)\tclThreadInt.h

.PHONY: $(OUT_DIR)\pkgIndex.tcl






>







 







>
>







166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
...
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
DLLOBJS = \
	$(TMP_DIR)\threadNs.obj \
	$(TMP_DIR)\threadCmd.obj \
	$(TMP_DIR)\threadSvCmd.obj \
	$(TMP_DIR)\threadSpCmd.obj \
	$(TMP_DIR)\threadPoolCmd.obj \
	$(TMP_DIR)\psGdbm.obj \
	$(TMP_DIR)\psLmdb.obj \
	$(TMP_DIR)\threadSvListCmd.obj \
	$(TMP_DIR)\threadSvKeylistCmd.obj \
	$(TMP_DIR)\tclXkeylist.obj \
	$(TMP_DIR)\threadWin.obj \
!if !$(STATIC_BUILD)
	$(TMP_DIR)\thread.res
!endif
................................................................................
#-------------------------------------------------------------------------
# Explicit dependency rules
#
#-------------------------------------------------------------------------

#{$(WINDIR)}.c{$(TMP_DIR)}.obj ::
$(GENERICDIR)\psGdbm.c: $(GENERICDIR)\psGdbm.h
$(GENERICDIR)\psLmdb.c: $(GENERICDIR)\psLmdb.h
$(GENERICDIR)\threadCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadSpCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadSvCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadPoolCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadSvListCmd.c : $(GENERICDIR)\tclThreadInt.h
$(GENERICDIR)\threadSvKeylistCmd.c : $(GENERICDIR)\tclThreadInt.h

.PHONY: $(OUT_DIR)\pkgIndex.tcl

Changes to win/rules.vc.

395
396
397
398
399
400
401



402
403
404
405
406
407
408
409
410
411
412
413
!endif
!if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64]
!message *** Doing 64bit portability warnings
WARNINGS		    = $(WARNINGS) -Wp64
!endif
!endif




#----------------------------------------------------------
# Set our defines now armed with our options.
#----------------------------------------------------------

OPTDEFINES	= -DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) -DSTDC_HEADERS

!if $(TCL_MEM_DEBUG)
OPTDEFINES	= $(OPTDEFINES) -DTCL_MEM_DEBUG
!endif
!if $(TCL_COMPILE_DEBUG)
OPTDEFINES	= $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
!endif






>
>
>




|







395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
!endif
!if [nmakehlp -f $(CHECKS) "64bit"] && [nmakehlp -c -Wp64]
!message *** Doing 64bit portability warnings
WARNINGS		    = $(WARNINGS) -Wp64
!endif
!endif


LINKERFLAGS = $(LINKERFLAGS) $(ADDLINKOPTS)

#----------------------------------------------------------
# Set our defines now armed with our options.
#----------------------------------------------------------

OPTDEFINES	= -DTCL_CFGVAL_ENCODING=$(CFG_ENCODING) -DSTDC_HEADERS $(ADDOPTDEFINES)

!if $(TCL_MEM_DEBUG)
OPTDEFINES	= $(OPTDEFINES) -DTCL_MEM_DEBUG
!endif
!if $(TCL_COMPILE_DEBUG)
OPTDEFINES	= $(OPTDEFINES) -DTCL_COMPILE_DEBUG -DTCL_COMPILE_STATS
!endif