thread-ring benchmark

See http://shootout.alioth.debian.org/gp4/benchmark.php?test=threadring&lang=all

See Computer Language Benchmarks Game for pointers to other Tcl entries.

2008-06-20 The guys running the benchmark also got the "can't create a new thread" error that I spoke about below.

http://shootout.alioth.debian.org/gp4/benchmark.php?test=threadring&lang=tcl&id=0

If anyone knows anything about this limit please comment here. I got around it by checking out a later version of Tcl.. is there a hard-coded limit somewhere to the number of threads?

jmn I tried the following, but it errors out with "can't create a new thread" - even though my system appears to have plenty of free memory.

Any ideas as to what limit I'm hitting?

escargo 4 Jun 2008 - Well, how about telling us what version of Tcl and system you are using, plus a description of its hardware resources?

jmn Tcl 8.5.2b1 - Vista x64 - core2 2.4Ghz 4G ram

It seems to produce the error for ring_size >= 206

 - also, due to the above error, I haven't verified that the code below produces the right result.

If anyone else runs it sucessfully, please make a note here as to whether it produces the expected result for N = 1000, of 498; thanks.

SL I can create up to ~800 threads. I guess to run this script in the same shell multiple times you have to release some threads.

Nresultsecssystem
10004982.46Tcl 8.5.2 - XP x86 core2 2.0GHz
10,000,000361336.51Tcl 8.5.2 - XP x86 core2 2.0GHz

jmn Thanks for that. A little disappointing given your machine seems similar but a little more powerful than the actual machines used for the benchmark - but still seems not too bad.

Ahh well, if we can't beat them on performance - we can still be right up there for gzip bytes & linecount.. see v2 for a more compact version.

jmn 2008-06-12 I had another stab at it.. this time using a thread shared variable to hold the token, and a condition variable per thread to wait upon.

This is much faster than versions 1 & 2

It has a rather ugly hack though.. 'after 5' where I burn a few milliseconds to make sure the 1st thread is ready to be notified.

using: Tcl 8.6a0 - Vista x64 core2 2.4GHZ

VerNresultsecssystem
110004981.42
110,000,000361325.28
310004981.30
310,000,000361103.95

jmn 2008-06-14 Despite the hack I've submitted V3 to the shootout.

Since submitting, I've tested on FreeBSD and found the program works, but core dumps on exit.

I don't know if Tcl should be able to handle the thread tidy-up itself on exit, or if it's my fault for not shutting every thread down cleanly - but I'm assuming if it dumps core on the shootout system (Linux).. it's not going to make it into the benchmark listing.

tb 2009-08-07 I had to reduce ring_size to 363 to make it work on my Celer0n-M@2GHz with a tclkit of version 8.6b1. At the end it printed 77. Well, I suggested something like 42 though :)

V1

 set ring_size 503
 set N 1000
 package require Thread
 proc done {} {
         set ::done 1
 }
 set script {
         proc accept {t} {
                 if {$t == 0} {
                         puts stdout "%i%"
                         thread::send -async %m% done
                         return
                 }
                 thread::send -async %n% [list accept [expr {$t - 1}] ]
         }
         %do%
 }
 set t1 [set tnext [thread::create {thread::wait}]]
 for {set i $ring_size} {$i >1} {incr i -1} {
          set tnext [thread::create [string map [list %m% [thread::id] %i% $i %n% $tnext %do% "thread::wait"] $script]]
 }
 #close the ring
 set script [string map [list %m% [thread::id] %i% 1 %n% $tnext %do% [list accept $N]] $script]
 thread::send -async $t1 $script
 vwait ::done

v2 (slightly slower)

 package require Thread
 set ring_size 503
 set N 1000
 set script { 
        interp alias {} accept0 {} thread::send -async %m% "set ::done %i%"
         interp alias {} accept1 {} apply {t {thread::send -async %n% "accept[expr {$t>1?1:0}] [expr {$t-1}]"}}
         %do%
 }
 set t1 [set tnext [thread::create {thread::wait}]]
 for {set i $ring_size} {$i >1} {incr i -1} {
         set tnext [thread::create [string map "%m% [thread::id] %i% $i %n% $tnext %do% thread::wait" $script]]
 }
 thread::send -async $t1 [string map "%m% [thread::id] %i% 1 %n% $tnext %do% {accept1 $N}" $script]
 vwait ::done
 puts stdout $::done

v3 

 set ring_size 503
 set N 10000000
 package require Thread
 set script {
         proc run {} {
                 set t -2
                 thread::mutex lock %m%
                 while {$t != -1} {
                         thread::cond wait %c% %m%
                         set t [tsv::incr TOK t -1]
                         thread::cond notify %cnext%
                 }
                 thread::mutex unlock %m%
                 puts stdout "%i%"
                 thread::send -async %main% {set ::done 1}
                 thread::cond destroy %c%
                 return
         }
         %do%
 }
 set t1 [set tnext [thread::create {thread::wait}]]
 set c1 [set c [thread::cond create]]
 set m [thread::mutex create]
 for {set i $ring_size} {$i >1} {incr i -1} {
         set cnext $c
         set c [thread::cond create]
         set tnext [thread::create [string map [list %main% [thread::id] %i% $i %m% $m %c% $c %cnext% $cnext %n% $tnext %do% run] $script]]
 }
 #close the ring
 set script [string map [list %main% [thread::id] %i% 1 %m% $m %c% $c1 %cnext% $c %n% $tnext %do% "thread::send -async [thread::id] {set ::start 1};run"] $script]
 thread::send -async $t1 $script
 vwait ::start
 after 5
 tsv::set TOK t $N
 thread::cond notify $c1
 vwait ::done
Category Performance
Updated 2009-08-07 09:26:41