Posted to tcl by apn at Thu Apr 27 02:24:43 GMT 2017view pretty
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 } while {1} { if {[llength [thread::names]] == 1} { break; # Only I am left } after 1 ;# seems to be necessary to prevent main exiting before worker threads have all finished calling remove_worker }