Tcl Source Code

Artifact 233821a3fa3174d0dda5c1c2e80a213de698cbb310a22e7c72a4f6ef99991a7f:

Attachment "tcl-thread-init-race.tcl" to ticket [c35e347c6f] added by gustafn3 2026-10-07 09:22:20.

---

# Tcl-only interpreter-initialization stress test; no NaviServer required.
# Run with the SAME Tcl 9.1 installation and locale as the failing server:
#   /path/to/tclsh9.1 tcl-thread-init-race.tcl parallel 8 500
#   /path/to/tclsh9.1 tcl-thread-init-race.tcl serialized 8 500
#
# Persistent creator threads rendezvous before each round, then each creates
# and joins one fresh child. The child runs Tcl_Init before its empty script.
# Serializing thread::create serializes child initialization too, because
# thread::create waits for initialization to complete before returning.
# A completed stress run does not prove absence of a race.

package require Thread
# Loading Thread itself verifies that Tcl has thread support. Tcl 9 need not
# expose the older tcl_platform(threaded) array element.
if {[llength $argv] < 1 || [llength $argv] > 3
    || [lindex $argv 0] ni {parallel serialized}} {
    puts stderr "usage: tclsh [info script] parallel|serialized ?creators? ?rounds?"
    exit 2
}
lassign $argv mode creators rounds
if {$creators eq ""} {set creators 8}
if {$rounds eq ""} {set rounds 500}
foreach {name value limit} [list creators $creators 64 rounds $rounds 100000] {
    if {![string is integer -strict $value] || $value < 1 || $value > $limit} {
        error "$name must be an integer in 1..$limit"
    }
}

puts "Tcl [info patchlevel]; Thread [package present Thread]"
puts "OS: $tcl_platform(os) $tcl_platform(osVersion); $tcl_platform(machine)"
puts "mode=$mode creators=$creators rounds=$rounds"
foreach name {LANG LC_ALL LC_CTYPE} {
    if {[info exists env($name)]} {puts "$name=$env($name)"}
}
flush stdout

set state init_race_[pid]_[clock clicks]
tsv::array set $state {arrived 0 generation 0 aborted 0}
set gate [thread::mutex create]
set condition [thread::cond create]
set initlock [thread::mutex create]

set workerCode {
    proc rendezvous {state gate condition creators} {
        thread::mutex lock $gate
        try {
            if {[tsv::get $state aborted]} {error "another creator failed"}
            set generation [tsv::get $state generation]
            if {[tsv::incr $state arrived] == $creators} {
                tsv::set $state arrived 0
                tsv::incr $state generation
                thread::cond notify $condition
            } else {
                while {[tsv::get $state generation] == $generation
                       && ![tsv::get $state aborted]} {
                    thread::cond wait $condition $gate
                }
            }
            if {[tsv::get $state aborted]} {error "another creator failed"}
        } finally {
            thread::mutex unlock $gate
        }
    }

    proc stress {mode rounds creators state gate condition initlock} {
        set completed 0
        set code [catch {
            for {set i 0} {$i < $rounds} {incr i} {
                rendezvous $state $gate $condition $creators
                if {$mode eq "serialized"} {thread::mutex lock $initlock}
                try {
                    set child [thread::create -joinable {}]
                } finally {
                    if {$mode eq "serialized"} {thread::mutex unlock $initlock}
                }
                if {[thread::join $child] != 0} {error "child exited with an error"}
                incr completed
            }
            set completed
        } result options]
        if {$code != 0} {
            # Wake creators waiting for a peer that cannot finish its round.
            thread::mutex lock $gate
            tsv::set $state aborted 1
            thread::cond notify $condition
            thread::mutex unlock $gate
            return [list $code $result [dict get $options -errorinfo]]
        }
        return [list 0 $completed]
    }
}

# Establish creator interpreters sequentially BEFORE starting the measured work.
set tids {}
for {set i 0} {$i < $creators} {incr i} {
    set tid [thread::create -joinable -preserved]
    thread::send $tid [list eval $workerCode]
    lappend tids $tid
}

array set results {}
set completedCreators 0
trace add variable results write {apply {{args} {incr ::completedCreators}}}
set task [list stress $mode $rounds $creators $state $gate $condition $initlock]
set i 0
foreach tid $tids {
    thread::send -async $tid $task ::results($i)
    incr i
}
while {$completedCreators < $creators} {vwait completedCreators}

set failures 0
set total 0
for {set i 0} {$i < $creators} {incr i} {
    lassign $results($i) code result detail
    if {$code != 0} {
        incr failures
        puts stderr "creator $i: $result\n$detail"
    } else {
        incr total $result
    }
}
foreach tid $tids {
    thread::release $tid
    if {[thread::join $tid] != 0} {incr failures}
}
thread::cond destroy $condition
thread::mutex destroy $gate
thread::mutex destroy $initlock
tsv::unset $state
puts "completed=$total failed_creators=$failures (no crash observed)"
exit [expr {$failures != 0}]