Posted to tcl by bairui at Thu Apr 27 02:01:43 GMT 2017view raw
- package require Thread
- set unfinished_work {1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19}
- set finished_work {}
- set workers {}
- set retirees {}
- set n_workers 7
- set is_done false
- proc get_work {} {
- puts "Main distributing work from {$::unfinished_work}"
- set ::unfinished_work [lassign $::unfinished_work work]
- return $work
- }
- proc give_result {result} {
- puts "Main receiving finished work: $result"
- lappend ::finished_work $result
- }
- proc remove_worker {wid tid} {
- lappend ::retirees [list $wid $tid]
- puts "Main removing worker $wid. Remaining number of workers: [expr $::n_workers - [llength $::retirees]]"
- if {[llength $::retirees] == $::n_workers} {
- puts "Main retiring -- all workers done"
- set ::is_done true
- }
- }
- proc start_worker {main wid} {
- set id [thread::create {
- proc start {main wid} {
- set result 0 ;# simulate work-result with incrementing local integer
- while 1 {
- puts "Worker $wid asking for work"
- set work [thread::send $main get_work]
- if {$work ne {}} {
- puts "Worker $wid doing work $work"
- after 1 ;# simulate workload (using value of 1 to speed up multiple iteration tests)
- thread::send $main [list give_result [list $wid $work [incr result]]]
- } else {
- puts "Worker $wid has no more work"
- if {[thread::exists $main]} {
- thread::send $main [list remove_worker $wid [thread::id]]
- break
- }
- }
- }
- }
- thread::wait
- }]
- thread::send -async $id [list start $main $wid]
- lappend ::workers $id ;# not directly used in this example but probably useful in serious thread code
- }
- for {set wid 0} {$wid < $n_workers} {incr wid} {
- start_worker [thread::id] $wid
- }
- vwait is_done
- puts "Main results: $finished_work"
- foreach w $retirees {
- lassign $w wid tid
- puts "Main releasing worker $wid"
- thread::release $tid
- after 1 ;# seems to be necessary to prevent main exiting before worker threads have all finished calling remove_worker
- }