Artifact
233821a3fa3174d0dda5c1c2e80a213de698cbb310a22e7c72a4f6ef99991a7f:
Attachment "tcl-thread-init-race.tcl" to
ticket [c35e347c6f]
added by
gustafn3
2026-10-07 09:22:20.
0000: 23 20 54 63 6c 2d 6f 6e 6c 79 20 69 6e 74 65 72 # Tcl-only inter
0010: 70 72 65 74 65 72 2d 69 6e 69 74 69 61 6c 69 7a preter-initializ
0020: 61 74 69 6f 6e 20 73 74 72 65 73 73 20 74 65 73 ation stress tes
0030: 74 3b 20 6e 6f 20 4e 61 76 69 53 65 72 76 65 72 t; no NaviServer
0040: 20 72 65 71 75 69 72 65 64 2e 0a 23 20 52 75 6e required..# Run
0050: 20 77 69 74 68 20 74 68 65 20 53 41 4d 45 20 54 with the SAME T
0060: 63 6c 20 39 2e 31 20 69 6e 73 74 61 6c 6c 61 74 cl 9.1 installat
0070: 69 6f 6e 20 61 6e 64 20 6c 6f 63 61 6c 65 20 61 ion and locale a
0080: 73 20 74 68 65 20 66 61 69 6c 69 6e 67 20 73 65 s the failing se
0090: 72 76 65 72 3a 0a 23 20 20 20 2f 70 61 74 68 2f rver:.# /path/
00a0: 74 6f 2f 74 63 6c 73 68 39 2e 31 20 74 63 6c 2d to/tclsh9.1 tcl-
00b0: 74 68 72 65 61 64 2d 69 6e 69 74 2d 72 61 63 65 thread-init-race
00c0: 2e 74 63 6c 20 70 61 72 61 6c 6c 65 6c 20 38 20 .tcl parallel 8
00d0: 35 30 30 0a 23 20 20 20 2f 70 61 74 68 2f 74 6f 500.# /path/to
00e0: 2f 74 63 6c 73 68 39 2e 31 20 74 63 6c 2d 74 68 /tclsh9.1 tcl-th
00f0: 72 65 61 64 2d 69 6e 69 74 2d 72 61 63 65 2e 74 read-init-race.t
0100: 63 6c 20 73 65 72 69 61 6c 69 7a 65 64 20 38 20 cl serialized 8
0110: 35 30 30 0a 23 0a 23 20 50 65 72 73 69 73 74 65 500.#.# Persiste
0120: 6e 74 20 63 72 65 61 74 6f 72 20 74 68 72 65 61 nt creator threa
0130: 64 73 20 72 65 6e 64 65 7a 76 6f 75 73 20 62 65 ds rendezvous be
0140: 66 6f 72 65 20 65 61 63 68 20 72 6f 75 6e 64 2c fore each round,
0150: 20 74 68 65 6e 20 65 61 63 68 20 63 72 65 61 74 then each creat
0160: 65 73 0a 23 20 61 6e 64 20 6a 6f 69 6e 73 20 6f es.# and joins o
0170: 6e 65 20 66 72 65 73 68 20 63 68 69 6c 64 2e 20 ne fresh child.
0180: 54 68 65 20 63 68 69 6c 64 20 72 75 6e 73 20 54 The child runs T
0190: 63 6c 5f 49 6e 69 74 20 62 65 66 6f 72 65 20 69 cl_Init before i
01a0: 74 73 20 65 6d 70 74 79 20 73 63 72 69 70 74 2e ts empty script.
01b0: 0a 23 20 53 65 72 69 61 6c 69 7a 69 6e 67 20 74 .# Serializing t
01c0: 68 72 65 61 64 3a 3a 63 72 65 61 74 65 20 73 65 hread::create se
01d0: 72 69 61 6c 69 7a 65 73 20 63 68 69 6c 64 20 69 rializes child i
01e0: 6e 69 74 69 61 6c 69 7a 61 74 69 6f 6e 20 74 6f nitialization to
01f0: 6f 2c 20 62 65 63 61 75 73 65 0a 23 20 74 68 72 o, because.# thr
0200: 65 61 64 3a 3a 63 72 65 61 74 65 20 77 61 69 74 ead::create wait
0210: 73 20 66 6f 72 20 69 6e 69 74 69 61 6c 69 7a 61 s for initializa
0220: 74 69 6f 6e 20 74 6f 20 63 6f 6d 70 6c 65 74 65 tion to complete
0230: 20 62 65 66 6f 72 65 20 72 65 74 75 72 6e 69 6e before returnin
0240: 67 2e 0a 23 20 41 20 63 6f 6d 70 6c 65 74 65 64 g..# A completed
0250: 20 73 74 72 65 73 73 20 72 75 6e 20 64 6f 65 73 stress run does
0260: 20 6e 6f 74 20 70 72 6f 76 65 20 61 62 73 65 6e not prove absen
0270: 63 65 20 6f 66 20 61 20 72 61 63 65 2e 0a 0a 70 ce of a race...p
0280: 61 63 6b 61 67 65 20 72 65 71 75 69 72 65 20 54 ackage require T
0290: 68 72 65 61 64 0a 23 20 4c 6f 61 64 69 6e 67 20 hread.# Loading
02a0: 54 68 72 65 61 64 20 69 74 73 65 6c 66 20 76 65 Thread itself ve
02b0: 72 69 66 69 65 73 20 74 68 61 74 20 54 63 6c 20 rifies that Tcl
02c0: 68 61 73 20 74 68 72 65 61 64 20 73 75 70 70 6f has thread suppo
02d0: 72 74 2e 20 54 63 6c 20 39 20 6e 65 65 64 20 6e rt. Tcl 9 need n
02e0: 6f 74 0a 23 20 65 78 70 6f 73 65 20 74 68 65 20 ot.# expose the
02f0: 6f 6c 64 65 72 20 74 63 6c 5f 70 6c 61 74 66 6f older tcl_platfo
0300: 72 6d 28 74 68 72 65 61 64 65 64 29 20 61 72 72 rm(threaded) arr
0310: 61 79 20 65 6c 65 6d 65 6e 74 2e 0a 69 66 20 7b ay element..if {
0320: 5b 6c 6c 65 6e 67 74 68 20 24 61 72 67 76 5d 20 [llength $argv]
0330: 3c 20 31 20 7c 7c 20 5b 6c 6c 65 6e 67 74 68 20 < 1 || [llength
0340: 24 61 72 67 76 5d 20 3e 20 33 0a 20 20 20 20 7c $argv] > 3. |
0350: 7c 20 5b 6c 69 6e 64 65 78 20 24 61 72 67 76 20 | [lindex $argv
0360: 30 5d 20 6e 69 20 7b 70 61 72 61 6c 6c 65 6c 20 0] ni {parallel
0370: 73 65 72 69 61 6c 69 7a 65 64 7d 7d 20 7b 0a 20 serialized}} {.
0380: 20 20 20 70 75 74 73 20 73 74 64 65 72 72 20 22 puts stderr "
0390: 75 73 61 67 65 3a 20 74 63 6c 73 68 20 5b 69 6e usage: tclsh [in
03a0: 66 6f 20 73 63 72 69 70 74 5d 20 70 61 72 61 6c fo script] paral
03b0: 6c 65 6c 7c 73 65 72 69 61 6c 69 7a 65 64 20 3f lel|serialized ?
03c0: 63 72 65 61 74 6f 72 73 3f 20 3f 72 6f 75 6e 64 creators? ?round
03d0: 73 3f 22 0a 20 20 20 20 65 78 69 74 20 32 0a 7d s?". exit 2.}
03e0: 0a 6c 61 73 73 69 67 6e 20 24 61 72 67 76 20 6d .lassign $argv m
03f0: 6f 64 65 20 63 72 65 61 74 6f 72 73 20 72 6f 75 ode creators rou
0400: 6e 64 73 0a 69 66 20 7b 24 63 72 65 61 74 6f 72 nds.if {$creator
0410: 73 20 65 71 20 22 22 7d 20 7b 73 65 74 20 63 72 s eq ""} {set cr
0420: 65 61 74 6f 72 73 20 38 7d 0a 69 66 20 7b 24 72 eators 8}.if {$r
0430: 6f 75 6e 64 73 20 65 71 20 22 22 7d 20 7b 73 65 ounds eq ""} {se
0440: 74 20 72 6f 75 6e 64 73 20 35 30 30 7d 0a 66 6f t rounds 500}.fo
0450: 72 65 61 63 68 20 7b 6e 61 6d 65 20 76 61 6c 75 reach {name valu
0460: 65 20 6c 69 6d 69 74 7d 20 5b 6c 69 73 74 20 63 e limit} [list c
0470: 72 65 61 74 6f 72 73 20 24 63 72 65 61 74 6f 72 reators $creator
0480: 73 20 36 34 20 72 6f 75 6e 64 73 20 24 72 6f 75 s 64 rounds $rou
0490: 6e 64 73 20 31 30 30 30 30 30 5d 20 7b 0a 20 20 nds 100000] {.
04a0: 20 20 69 66 20 7b 21 5b 73 74 72 69 6e 67 20 69 if {![string i
04b0: 73 20 69 6e 74 65 67 65 72 20 2d 73 74 72 69 63 s integer -stric
04c0: 74 20 24 76 61 6c 75 65 5d 20 7c 7c 20 24 76 61 t $value] || $va
04d0: 6c 75 65 20 3c 20 31 20 7c 7c 20 24 76 61 6c 75 lue < 1 || $valu
04e0: 65 20 3e 20 24 6c 69 6d 69 74 7d 20 7b 0a 20 20 e > $limit} {.
04f0: 20 20 20 20 20 20 65 72 72 6f 72 20 22 24 6e 61 error "$na
0500: 6d 65 20 6d 75 73 74 20 62 65 20 61 6e 20 69 6e me must be an in
0510: 74 65 67 65 72 20 69 6e 20 31 2e 2e 24 6c 69 6d teger in 1..$lim
0520: 69 74 22 0a 20 20 20 20 7d 0a 7d 0a 0a 70 75 74 it". }.}..put
0530: 73 20 22 54 63 6c 20 5b 69 6e 66 6f 20 70 61 74 s "Tcl [info pat
0540: 63 68 6c 65 76 65 6c 5d 3b 20 54 68 72 65 61 64 chlevel]; Thread
0550: 20 5b 70 61 63 6b 61 67 65 20 70 72 65 73 65 6e [package presen
0560: 74 20 54 68 72 65 61 64 5d 22 0a 70 75 74 73 20 t Thread]".puts
0570: 22 4f 53 3a 20 24 74 63 6c 5f 70 6c 61 74 66 6f "OS: $tcl_platfo
0580: 72 6d 28 6f 73 29 20 24 74 63 6c 5f 70 6c 61 74 rm(os) $tcl_plat
0590: 66 6f 72 6d 28 6f 73 56 65 72 73 69 6f 6e 29 3b form(osVersion);
05a0: 20 24 74 63 6c 5f 70 6c 61 74 66 6f 72 6d 28 6d $tcl_platform(m
05b0: 61 63 68 69 6e 65 29 22 0a 70 75 74 73 20 22 6d achine)".puts "m
05c0: 6f 64 65 3d 24 6d 6f 64 65 20 63 72 65 61 74 6f ode=$mode creato
05d0: 72 73 3d 24 63 72 65 61 74 6f 72 73 20 72 6f 75 rs=$creators rou
05e0: 6e 64 73 3d 24 72 6f 75 6e 64 73 22 0a 66 6f 72 nds=$rounds".for
05f0: 65 61 63 68 20 6e 61 6d 65 20 7b 4c 41 4e 47 20 each name {LANG
0600: 4c 43 5f 41 4c 4c 20 4c 43 5f 43 54 59 50 45 7d LC_ALL LC_CTYPE}
0610: 20 7b 0a 20 20 20 20 69 66 20 7b 5b 69 6e 66 6f {. if {[info
0620: 20 65 78 69 73 74 73 20 65 6e 76 28 24 6e 61 6d exists env($nam
0630: 65 29 5d 7d 20 7b 70 75 74 73 20 22 24 6e 61 6d e)]} {puts "$nam
0640: 65 3d 24 65 6e 76 28 24 6e 61 6d 65 29 22 7d 0a e=$env($name)"}.
0650: 7d 0a 66 6c 75 73 68 20 73 74 64 6f 75 74 0a 0a }.flush stdout..
0660: 73 65 74 20 73 74 61 74 65 20 69 6e 69 74 5f 72 set state init_r
0670: 61 63 65 5f 5b 70 69 64 5d 5f 5b 63 6c 6f 63 6b ace_[pid]_[clock
0680: 20 63 6c 69 63 6b 73 5d 0a 74 73 76 3a 3a 61 72 clicks].tsv::ar
0690: 72 61 79 20 73 65 74 20 24 73 74 61 74 65 20 7b ray set $state {
06a0: 61 72 72 69 76 65 64 20 30 20 67 65 6e 65 72 61 arrived 0 genera
06b0: 74 69 6f 6e 20 30 20 61 62 6f 72 74 65 64 20 30 tion 0 aborted 0
06c0: 7d 0a 73 65 74 20 67 61 74 65 20 5b 74 68 72 65 }.set gate [thre
06d0: 61 64 3a 3a 6d 75 74 65 78 20 63 72 65 61 74 65 ad::mutex create
06e0: 5d 0a 73 65 74 20 63 6f 6e 64 69 74 69 6f 6e 20 ].set condition
06f0: 5b 74 68 72 65 61 64 3a 3a 63 6f 6e 64 20 63 72 [thread::cond cr
0700: 65 61 74 65 5d 0a 73 65 74 20 69 6e 69 74 6c 6f eate].set initlo
0710: 63 6b 20 5b 74 68 72 65 61 64 3a 3a 6d 75 74 65 ck [thread::mute
0720: 78 20 63 72 65 61 74 65 5d 0a 0a 73 65 74 20 77 x create]..set w
0730: 6f 72 6b 65 72 43 6f 64 65 20 7b 0a 20 20 20 20 orkerCode {.
0740: 70 72 6f 63 20 72 65 6e 64 65 7a 76 6f 75 73 20 proc rendezvous
0750: 7b 73 74 61 74 65 20 67 61 74 65 20 63 6f 6e 64 {state gate cond
0760: 69 74 69 6f 6e 20 63 72 65 61 74 6f 72 73 7d 20 ition creators}
0770: 7b 0a 20 20 20 20 20 20 20 20 74 68 72 65 61 64 {. thread
0780: 3a 3a 6d 75 74 65 78 20 6c 6f 63 6b 20 24 67 61 ::mutex lock $ga
0790: 74 65 0a 20 20 20 20 20 20 20 20 74 72 79 20 7b te. try {
07a0: 0a 20 20 20 20 20 20 20 20 20 20 20 20 69 66 20 . if
07b0: 7b 5b 74 73 76 3a 3a 67 65 74 20 24 73 74 61 74 {[tsv::get $stat
07c0: 65 20 61 62 6f 72 74 65 64 5d 7d 20 7b 65 72 72 e aborted]} {err
07d0: 6f 72 20 22 61 6e 6f 74 68 65 72 20 63 72 65 61 or "another crea
07e0: 74 6f 72 20 66 61 69 6c 65 64 22 7d 0a 20 20 20 tor failed"}.
07f0: 20 20 20 20 20 20 20 20 20 73 65 74 20 67 65 6e set gen
0800: 65 72 61 74 69 6f 6e 20 5b 74 73 76 3a 3a 67 65 eration [tsv::ge
0810: 74 20 24 73 74 61 74 65 20 67 65 6e 65 72 61 74 t $state generat
0820: 69 6f 6e 5d 0a 20 20 20 20 20 20 20 20 20 20 20 ion].
0830: 20 69 66 20 7b 5b 74 73 76 3a 3a 69 6e 63 72 20 if {[tsv::incr
0840: 24 73 74 61 74 65 20 61 72 72 69 76 65 64 5d 20 $state arrived]
0850: 3d 3d 20 24 63 72 65 61 74 6f 72 73 7d 20 7b 0a == $creators} {.
0860: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0870: 74 73 76 3a 3a 73 65 74 20 24 73 74 61 74 65 20 tsv::set $state
0880: 61 72 72 69 76 65 64 20 30 0a 20 20 20 20 20 20 arrived 0.
0890: 20 20 20 20 20 20 20 20 20 20 74 73 76 3a 3a 69 tsv::i
08a0: 6e 63 72 20 24 73 74 61 74 65 20 67 65 6e 65 72 ncr $state gener
08b0: 61 74 69 6f 6e 0a 20 20 20 20 20 20 20 20 20 20 ation.
08c0: 20 20 20 20 20 20 74 68 72 65 61 64 3a 3a 63 6f thread::co
08d0: 6e 64 20 6e 6f 74 69 66 79 20 24 63 6f 6e 64 69 nd notify $condi
08e0: 74 69 6f 6e 0a 20 20 20 20 20 20 20 20 20 20 20 tion.
08f0: 20 7d 20 65 6c 73 65 20 7b 0a 20 20 20 20 20 20 } else {.
0900: 20 20 20 20 20 20 20 20 20 20 77 68 69 6c 65 20 while
0910: 7b 5b 74 73 76 3a 3a 67 65 74 20 24 73 74 61 74 {[tsv::get $stat
0920: 65 20 67 65 6e 65 72 61 74 69 6f 6e 5d 20 3d 3d e generation] ==
0930: 20 24 67 65 6e 65 72 61 74 69 6f 6e 0a 20 20 20 $generation.
0940: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0950: 20 20 20 20 26 26 20 21 5b 74 73 76 3a 3a 67 65 && ![tsv::ge
0960: 74 20 24 73 74 61 74 65 20 61 62 6f 72 74 65 64 t $state aborted
0970: 5d 7d 20 7b 0a 20 20 20 20 20 20 20 20 20 20 20 ]} {.
0980: 20 20 20 20 20 20 20 20 20 74 68 72 65 61 64 3a thread:
0990: 3a 63 6f 6e 64 20 77 61 69 74 20 24 63 6f 6e 64 :cond wait $cond
09a0: 69 74 69 6f 6e 20 24 67 61 74 65 0a 20 20 20 20 ition $gate.
09b0: 20 20 20 20 20 20 20 20 20 20 20 20 7d 0a 20 20 }.
09c0: 20 20 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 }.
09d0: 20 20 20 20 20 20 20 20 69 66 20 7b 5b 74 73 76 if {[tsv
09e0: 3a 3a 67 65 74 20 24 73 74 61 74 65 20 61 62 6f ::get $state abo
09f0: 72 74 65 64 5d 7d 20 7b 65 72 72 6f 72 20 22 61 rted]} {error "a
0a00: 6e 6f 74 68 65 72 20 63 72 65 61 74 6f 72 20 66 nother creator f
0a10: 61 69 6c 65 64 22 7d 0a 20 20 20 20 20 20 20 20 ailed"}.
0a20: 7d 20 66 69 6e 61 6c 6c 79 20 7b 0a 20 20 20 20 } finally {.
0a30: 20 20 20 20 20 20 20 20 74 68 72 65 61 64 3a 3a thread::
0a40: 6d 75 74 65 78 20 75 6e 6c 6f 63 6b 20 24 67 61 mutex unlock $ga
0a50: 74 65 0a 20 20 20 20 20 20 20 20 7d 0a 20 20 20 te. }.
0a60: 20 7d 0a 0a 20 20 20 20 70 72 6f 63 20 73 74 72 }.. proc str
0a70: 65 73 73 20 7b 6d 6f 64 65 20 72 6f 75 6e 64 73 ess {mode rounds
0a80: 20 63 72 65 61 74 6f 72 73 20 73 74 61 74 65 20 creators state
0a90: 67 61 74 65 20 63 6f 6e 64 69 74 69 6f 6e 20 69 gate condition i
0aa0: 6e 69 74 6c 6f 63 6b 7d 20 7b 0a 20 20 20 20 20 nitlock} {.
0ab0: 20 20 20 73 65 74 20 63 6f 6d 70 6c 65 74 65 64 set completed
0ac0: 20 30 0a 20 20 20 20 20 20 20 20 73 65 74 20 63 0. set c
0ad0: 6f 64 65 20 5b 63 61 74 63 68 20 7b 0a 20 20 20 ode [catch {.
0ae0: 20 20 20 20 20 20 20 20 20 66 6f 72 20 7b 73 65 for {se
0af0: 74 20 69 20 30 7d 20 7b 24 69 20 3c 20 24 72 6f t i 0} {$i < $ro
0b00: 75 6e 64 73 7d 20 7b 69 6e 63 72 20 69 7d 20 7b unds} {incr i} {
0b10: 0a 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 .
0b20: 20 72 65 6e 64 65 7a 76 6f 75 73 20 24 73 74 61 rendezvous $sta
0b30: 74 65 20 24 67 61 74 65 20 24 63 6f 6e 64 69 74 te $gate $condit
0b40: 69 6f 6e 20 24 63 72 65 61 74 6f 72 73 0a 20 20 ion $creators.
0b50: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 69 66 if
0b60: 20 7b 24 6d 6f 64 65 20 65 71 20 22 73 65 72 69 {$mode eq "seri
0b70: 61 6c 69 7a 65 64 22 7d 20 7b 74 68 72 65 61 64 alized"} {thread
0b80: 3a 3a 6d 75 74 65 78 20 6c 6f 63 6b 20 24 69 6e ::mutex lock $in
0b90: 69 74 6c 6f 63 6b 7d 0a 20 20 20 20 20 20 20 20 itlock}.
0ba0: 20 20 20 20 20 20 20 20 74 72 79 20 7b 0a 20 20 try {.
0bb0: 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20 20
0bc0: 20 20 73 65 74 20 63 68 69 6c 64 20 5b 74 68 72 set child [thr
0bd0: 65 61 64 3a 3a 63 72 65 61 74 65 20 2d 6a 6f 69 ead::create -joi
0be0: 6e 61 62 6c 65 20 7b 7d 5d 0a 20 20 20 20 20 20 nable {}].
0bf0: 20 20 20 20 20 20 20 20 20 20 7d 20 66 69 6e 61 } fina
0c00: 6c 6c 79 20 7b 0a 20 20 20 20 20 20 20 20 20 20 lly {.
0c10: 20 20 20 20 20 20 20 20 20 20 69 66 20 7b 24 6d if {$m
0c20: 6f 64 65 20 65 71 20 22 73 65 72 69 61 6c 69 7a ode eq "serializ
0c30: 65 64 22 7d 20 7b 74 68 72 65 61 64 3a 3a 6d 75 ed"} {thread::mu
0c40: 74 65 78 20 75 6e 6c 6f 63 6b 20 24 69 6e 69 74 tex unlock $init
0c50: 6c 6f 63 6b 7d 0a 20 20 20 20 20 20 20 20 20 20 lock}.
0c60: 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 20 20 }.
0c70: 20 20 20 20 20 20 20 20 69 66 20 7b 5b 74 68 72 if {[thr
0c80: 65 61 64 3a 3a 6a 6f 69 6e 20 24 63 68 69 6c 64 ead::join $child
0c90: 5d 20 21 3d 20 30 7d 20 7b 65 72 72 6f 72 20 22 ] != 0} {error "
0ca0: 63 68 69 6c 64 20 65 78 69 74 65 64 20 77 69 74 child exited wit
0cb0: 68 20 61 6e 20 65 72 72 6f 72 22 7d 0a 20 20 20 h an error"}.
0cc0: 20 20 20 20 20 20 20 20 20 20 20 20 20 69 6e 63 inc
0cd0: 72 20 63 6f 6d 70 6c 65 74 65 64 0a 20 20 20 20 r completed.
0ce0: 20 20 20 20 20 20 20 20 7d 0a 20 20 20 20 20 20 }.
0cf0: 20 20 20 20 20 20 73 65 74 20 63 6f 6d 70 6c 65 set comple
0d00: 74 65 64 0a 20 20 20 20 20 20 20 20 7d 20 72 65 ted. } re
0d10: 73 75 6c 74 20 6f 70 74 69 6f 6e 73 5d 0a 20 20 sult options].
0d20: 20 20 20 20 20 20 69 66 20 7b 24 63 6f 64 65 20 if {$code
0d30: 21 3d 20 30 7d 20 7b 0a 20 20 20 20 20 20 20 20 != 0} {.
0d40: 20 20 20 20 23 20 57 61 6b 65 20 63 72 65 61 74 # Wake creat
0d50: 6f 72 73 20 77 61 69 74 69 6e 67 20 66 6f 72 20 ors waiting for
0d60: 61 20 70 65 65 72 20 74 68 61 74 20 63 61 6e 6e a peer that cann
0d70: 6f 74 20 66 69 6e 69 73 68 20 69 74 73 20 72 6f ot finish its ro
0d80: 75 6e 64 2e 0a 20 20 20 20 20 20 20 20 20 20 20 und..
0d90: 20 74 68 72 65 61 64 3a 3a 6d 75 74 65 78 20 6c thread::mutex l
0da0: 6f 63 6b 20 24 67 61 74 65 0a 20 20 20 20 20 20 ock $gate.
0db0: 20 20 20 20 20 20 74 73 76 3a 3a 73 65 74 20 24 tsv::set $
0dc0: 73 74 61 74 65 20 61 62 6f 72 74 65 64 20 31 0a state aborted 1.
0dd0: 20 20 20 20 20 20 20 20 20 20 20 20 74 68 72 65 thre
0de0: 61 64 3a 3a 63 6f 6e 64 20 6e 6f 74 69 66 79 20 ad::cond notify
0df0: 24 63 6f 6e 64 69 74 69 6f 6e 0a 20 20 20 20 20 $condition.
0e00: 20 20 20 20 20 20 20 74 68 72 65 61 64 3a 3a 6d thread::m
0e10: 75 74 65 78 20 75 6e 6c 6f 63 6b 20 24 67 61 74 utex unlock $gat
0e20: 65 0a 20 20 20 20 20 20 20 20 20 20 20 20 72 65 e. re
0e30: 74 75 72 6e 20 5b 6c 69 73 74 20 24 63 6f 64 65 turn [list $code
0e40: 20 24 72 65 73 75 6c 74 20 5b 64 69 63 74 20 67 $result [dict g
0e50: 65 74 20 24 6f 70 74 69 6f 6e 73 20 2d 65 72 72 et $options -err
0e60: 6f 72 69 6e 66 6f 5d 5d 0a 20 20 20 20 20 20 20 orinfo]].
0e70: 20 7d 0a 20 20 20 20 20 20 20 20 72 65 74 75 72 }. retur
0e80: 6e 20 5b 6c 69 73 74 20 30 20 24 63 6f 6d 70 6c n [list 0 $compl
0e90: 65 74 65 64 5d 0a 20 20 20 20 7d 0a 7d 0a 0a 23 eted]. }.}..#
0ea0: 20 45 73 74 61 62 6c 69 73 68 20 63 72 65 61 74 Establish creat
0eb0: 6f 72 20 69 6e 74 65 72 70 72 65 74 65 72 73 20 or interpreters
0ec0: 73 65 71 75 65 6e 74 69 61 6c 6c 79 20 42 45 46 sequentially BEF
0ed0: 4f 52 45 20 73 74 61 72 74 69 6e 67 20 74 68 65 ORE starting the
0ee0: 20 6d 65 61 73 75 72 65 64 20 77 6f 72 6b 2e 0a measured work..
0ef0: 73 65 74 20 74 69 64 73 20 7b 7d 0a 66 6f 72 20 set tids {}.for
0f00: 7b 73 65 74 20 69 20 30 7d 20 7b 24 69 20 3c 20 {set i 0} {$i <
0f10: 24 63 72 65 61 74 6f 72 73 7d 20 7b 69 6e 63 72 $creators} {incr
0f20: 20 69 7d 20 7b 0a 20 20 20 20 73 65 74 20 74 69 i} {. set ti
0f30: 64 20 5b 74 68 72 65 61 64 3a 3a 63 72 65 61 74 d [thread::creat
0f40: 65 20 2d 6a 6f 69 6e 61 62 6c 65 20 2d 70 72 65 e -joinable -pre
0f50: 73 65 72 76 65 64 5d 0a 20 20 20 20 74 68 72 65 served]. thre
0f60: 61 64 3a 3a 73 65 6e 64 20 24 74 69 64 20 5b 6c ad::send $tid [l
0f70: 69 73 74 20 65 76 61 6c 20 24 77 6f 72 6b 65 72 ist eval $worker
0f80: 43 6f 64 65 5d 0a 20 20 20 20 6c 61 70 70 65 6e Code]. lappen
0f90: 64 20 74 69 64 73 20 24 74 69 64 0a 7d 0a 0a 61 d tids $tid.}..a
0fa0: 72 72 61 79 20 73 65 74 20 72 65 73 75 6c 74 73 rray set results
0fb0: 20 7b 7d 0a 73 65 74 20 63 6f 6d 70 6c 65 74 65 {}.set complete
0fc0: 64 43 72 65 61 74 6f 72 73 20 30 0a 74 72 61 63 dCreators 0.trac
0fd0: 65 20 61 64 64 20 76 61 72 69 61 62 6c 65 20 72 e add variable r
0fe0: 65 73 75 6c 74 73 20 77 72 69 74 65 20 7b 61 70 esults write {ap
0ff0: 70 6c 79 20 7b 7b 61 72 67 73 7d 20 7b 69 6e 63 ply {{args} {inc
1000: 72 20 3a 3a 63 6f 6d 70 6c 65 74 65 64 43 72 65 r ::completedCre
1010: 61 74 6f 72 73 7d 7d 7d 0a 73 65 74 20 74 61 73 ators}}}.set tas
1020: 6b 20 5b 6c 69 73 74 20 73 74 72 65 73 73 20 24 k [list stress $
1030: 6d 6f 64 65 20 24 72 6f 75 6e 64 73 20 24 63 72 mode $rounds $cr
1040: 65 61 74 6f 72 73 20 24 73 74 61 74 65 20 24 67 eators $state $g
1050: 61 74 65 20 24 63 6f 6e 64 69 74 69 6f 6e 20 24 ate $condition $
1060: 69 6e 69 74 6c 6f 63 6b 5d 0a 73 65 74 20 69 20 initlock].set i
1070: 30 0a 66 6f 72 65 61 63 68 20 74 69 64 20 24 74 0.foreach tid $t
1080: 69 64 73 20 7b 0a 20 20 20 20 74 68 72 65 61 64 ids {. thread
1090: 3a 3a 73 65 6e 64 20 2d 61 73 79 6e 63 20 24 74 ::send -async $t
10a0: 69 64 20 24 74 61 73 6b 20 3a 3a 72 65 73 75 6c id $task ::resul
10b0: 74 73 28 24 69 29 0a 20 20 20 20 69 6e 63 72 20 ts($i). incr
10c0: 69 0a 7d 0a 77 68 69 6c 65 20 7b 24 63 6f 6d 70 i.}.while {$comp
10d0: 6c 65 74 65 64 43 72 65 61 74 6f 72 73 20 3c 20 letedCreators <
10e0: 24 63 72 65 61 74 6f 72 73 7d 20 7b 76 77 61 69 $creators} {vwai
10f0: 74 20 63 6f 6d 70 6c 65 74 65 64 43 72 65 61 74 t completedCreat
1100: 6f 72 73 7d 0a 0a 73 65 74 20 66 61 69 6c 75 72 ors}..set failur
1110: 65 73 20 30 0a 73 65 74 20 74 6f 74 61 6c 20 30 es 0.set total 0
1120: 0a 66 6f 72 20 7b 73 65 74 20 69 20 30 7d 20 7b .for {set i 0} {
1130: 24 69 20 3c 20 24 63 72 65 61 74 6f 72 73 7d 20 $i < $creators}
1140: 7b 69 6e 63 72 20 69 7d 20 7b 0a 20 20 20 20 6c {incr i} {. l
1150: 61 73 73 69 67 6e 20 24 72 65 73 75 6c 74 73 28 assign $results(
1160: 24 69 29 20 63 6f 64 65 20 72 65 73 75 6c 74 20 $i) code result
1170: 64 65 74 61 69 6c 0a 20 20 20 20 69 66 20 7b 24 detail. if {$
1180: 63 6f 64 65 20 21 3d 20 30 7d 20 7b 0a 20 20 20 code != 0} {.
1190: 20 20 20 20 20 69 6e 63 72 20 66 61 69 6c 75 72 incr failur
11a0: 65 73 0a 20 20 20 20 20 20 20 20 70 75 74 73 20 es. puts
11b0: 73 74 64 65 72 72 20 22 63 72 65 61 74 6f 72 20 stderr "creator
11c0: 24 69 3a 20 24 72 65 73 75 6c 74 5c 6e 24 64 65 $i: $result\n$de
11d0: 74 61 69 6c 22 0a 20 20 20 20 7d 20 65 6c 73 65 tail". } else
11e0: 20 7b 0a 20 20 20 20 20 20 20 20 69 6e 63 72 20 {. incr
11f0: 74 6f 74 61 6c 20 24 72 65 73 75 6c 74 0a 20 20 total $result.
1200: 20 20 7d 0a 7d 0a 66 6f 72 65 61 63 68 20 74 69 }.}.foreach ti
1210: 64 20 24 74 69 64 73 20 7b 0a 20 20 20 20 74 68 d $tids {. th
1220: 72 65 61 64 3a 3a 72 65 6c 65 61 73 65 20 24 74 read::release $t
1230: 69 64 0a 20 20 20 20 69 66 20 7b 5b 74 68 72 65 id. if {[thre
1240: 61 64 3a 3a 6a 6f 69 6e 20 24 74 69 64 5d 20 21 ad::join $tid] !
1250: 3d 20 30 7d 20 7b 69 6e 63 72 20 66 61 69 6c 75 = 0} {incr failu
1260: 72 65 73 7d 0a 7d 0a 74 68 72 65 61 64 3a 3a 63 res}.}.thread::c
1270: 6f 6e 64 20 64 65 73 74 72 6f 79 20 24 63 6f 6e ond destroy $con
1280: 64 69 74 69 6f 6e 0a 74 68 72 65 61 64 3a 3a 6d dition.thread::m
1290: 75 74 65 78 20 64 65 73 74 72 6f 79 20 24 67 61 utex destroy $ga
12a0: 74 65 0a 74 68 72 65 61 64 3a 3a 6d 75 74 65 78 te.thread::mutex
12b0: 20 64 65 73 74 72 6f 79 20 24 69 6e 69 74 6c 6f destroy $initlo
12c0: 63 6b 0a 74 73 76 3a 3a 75 6e 73 65 74 20 24 73 ck.tsv::unset $s
12d0: 74 61 74 65 0a 70 75 74 73 20 22 63 6f 6d 70 6c tate.puts "compl
12e0: 65 74 65 64 3d 24 74 6f 74 61 6c 20 66 61 69 6c eted=$total fail
12f0: 65 64 5f 63 72 65 61 74 6f 72 73 3d 24 66 61 69 ed_creators=$fai
1300: 6c 75 72 65 73 20 28 6e 6f 20 63 72 61 73 68 20 lures (no crash
1310: 6f 62 73 65 72 76 65 64 29 22 0a 65 78 69 74 20 observed)".exit
1320: 5b 65 78 70 72 20 7b 24 66 61 69 6c 75 72 65 73 [expr {$failures
1330: 20 21 3d 20 30 7d 5d 0a != 0}].
