Skip to content

Commit

Permalink
fixes segfault [d4ba38d00d06ebba]: only main interpreter used as defa…
Browse files Browse the repository at this point in the history
…ult thread interpreter (stored in its TSD)
  • Loading branch information
sebres committed Nov 13, 2024
2 parents ff263b4 + b85082a commit 46e5478
Show file tree
Hide file tree
Showing 2 changed files with 41 additions and 1 deletion.
11 changes: 10 additions & 1 deletion generic/threadCmd.c
Original file line number Diff line number Diff line change
Expand Up @@ -583,8 +583,17 @@ Init(
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);

if (tsdPtr->interp == NULL) {
Tcl_Interp *tmpInterp, *mainInterp = interp;
memset(tsdPtr, 0, sizeof(ThreadSpecificData));
tsdPtr->interp = interp;
/*
* Retrieve main interpreter of the thread, only
* main interpreter used as default thread-interpreter,
* so no childs here, see bug [d4ba38d00d06ebba]
*/
while (mainInterp && (tmpInterp = Tcl_GetMaster(mainInterp))) {
mainInterp = tmpInterp;
}
tsdPtr->interp = mainInterp;
ListUpdate(tsdPtr);
Tcl_CreateThreadExitHandler(ThreadExitProc,
threadEmptyResult);
Expand Down
31 changes: 31 additions & 0 deletions tests/thread.test
Original file line number Diff line number Diff line change
Expand Up @@ -33,6 +33,37 @@ proc ThreadReap {} {
llength [thread::names]
}

test thread-1.11 {no segfault on 2nd interpreter, bug [d4ba38d00d06ebba]} -body {
# This behavior needs to be covered in a separate shell, because it doesn't expect
# any other thread invocation before 2nd interpreter gets the thread::id (TSD),
# but test-suite calls thread::id command (tcltest, all.tcl and thread.test):
set fd [open [list |[info nameofexecutable] << [string map [list {$$load} [tcltest::loadScript]] {
$$load; package require thread
interp create ci
set l {}
ci eval {$$load; package require thread; thread::id}
thread::send -async [thread::id] {lappend l ev-1}; update
interp delete ci
thread::send -async [thread::id] {lappend l ev-2}; update; # no SF here
puts $l
}] 2>@stderr] r]
gets $fd
} -cleanup {
catch { close $fd }
} -result {ev-1 ev-2}

test thread-1.12 {no events in 2nd interpreter, bug [d4ba38d00d06ebba]} -setup {
interp create ci
} -body {
set l {}
thread::send -async [thread::id] {lappend l ev-1}; update
ci eval {package require tcltest; tcltest::loadTestedCommands; package require thread}
thread::send -async [thread::id] {lappend l ev-2}; update
set l
} -cleanup {
interp delete ci
} -result {ev-1 ev-2}

test thread-2.0 {no global thread command} {
info commands thread
} {}
Expand Down

0 comments on commit 46e5478

Please sign in to comment.