Tcl version of Martin Richards' benchmark program [L1 ].
set Count 10000
set Qpktcountval 23246
set Holdcountval 9297
# 100x
#set Count 1000000
#set Qpkcountval 2326410
#set Holdcountval 930563
set BUFSIZE 3
set I_IDLE 1
set I_WORK 2
set I_HANDLERA 3
set I_HANDLERB 4
set I_DEVA 5
set I_DEVB 6
set PKTBIT 1
set WAITBIT 2
set HOLDBIT 4
set NOTHOLDBIT 0xFFFB
set S_RUN 0
set S_RUNPKT 1
set S_WAIT 2
set S_WAITPKT 3
set S_HOLD 4
set S_HOLDPKT 5
set S_HOLDWAIT 6
set S_HOLDWAITPKT 7
set K_DEV 1000
set K_WORK 1001
set taskmax 10
set tasktab [list 0 0 0 0 0 0 0 0 0 0]
set tasklist 0
set tcb 0
set taskid 0
set qpktcount 0
set holdcount 0
set tracing 0
set layout 0
set buf0 [list]
for {set i 0} {$i <= $BUFSIZE} {incr i} {
lappend buf0 0
}
namespace eval task {
variable counter 0
variable tasks [dict create]
}
proc task::new {id pri wkq state func v1 v2} {
global tasktab tasklist
variable counter
variable tasks
incr counter
lset tasktab $id $counter
dict set tasks $counter link $tasklist
dict set tasks $counter id $id
dict set tasks $counter pri $pri
dict set tasks $counter wkq $wkq
dict set tasks $counter state $state
dict set tasks $counter fn $func
switch $func {
idlefn {
dict set tasks $counter hh $v1
dict set tasks $counter cnt $v2
}
workfn {
dict set tasks $counter sender $v1
dict set tasks $counter data $v2
}
handlerfn {
dict set tasks $counter wpktag $v1
dict set tasks $counter dpktag $v2
}
devfn {
dict set tasks $counter workdone $v1
}
default {
error "Invalid func name '$func'"
}
}
set tasklist $counter
return $counter
}
proc task::dump {tag} {
variable tasks
return [dict get $tasks $tag]
}
proc task::setkv {tag key value} {
variable tasks
dict set tasks $tag $key $value
}
proc task::getk {tag key} {
variable tasks
return [dict get $tasks $tag $key]
}
namespace eval packet {
variable counter 0
variable packets [dict create]
}
proc packet::new {link id kind} {
variable counter
variable packets
global buf0
incr counter
dict set packets $counter link $link
dict set packets $counter id $id
dict set packets $counter kind $kind
dict set packets $counter a1 0
dict set packets $counter a2 $buf0
return $counter
}
proc packet::dump {tag} {
variable packets
return [dict get $packets $tag]
}
proc packet::getk {tag key} {
variable packets
return [dict get $packets $tag $key]
}
proc packet::setkv {tag key value} {
variable packets
dict set packets $tag $key $value
}
proc packet::append {pt1 pt2} {
packet::setkv $pt1 link 0
if {!$pt2} {
return $pt1
}
set currpt $pt2
set next [packet::getk $pt2 link]
while {$next} {
set currpt $next
set next [packet::getk $currpt link]
}
packet::setkv $currpt link $pt1
return $pt2
}
proc createtask {id pri wkq state func v1 {v2 {}}} {
task::new $id $pri $wkq $state $func $v1 $v2
}
proc pkt {link id kind} {
return [packet::new $link $id $kind]
}
proc findtcb {id} {
global tasktab taskmax
if {$id > 0 && $id < $taskmax} {
return [lindex $tasktab $id]
}
error "Bad task id '$id'"
}
proc qpkt {ptag} {
global qpktcount taskid tcb
global PKTBIT
set t [findtcb [packet::getk $ptag id]]
if {!$t} {
return $t
}
incr qpktcount
packet::setkv $ptag link 0
packet::setkv $ptag id $taskid
if {![task::getk $t wkq]} {
task::setkv $t wkq $ptag
task::setkv $t state [expr {[task::getk $t state] | $PKTBIT}]
if {[task::getk $t pri] > [task::getk $tcb pri]} {
return $t
}
} else {
packet::append $ptag [task::getk $t wkq]
}
return $tcb
}
proc handlerfn {ptag} {
global tcb
global K_WORK BUFSIZE
set wpktag [task::getk $tcb wpktag]
set dpktag [task::getk $tcb dpktag]
if {$ptag} {
set pkt_kind [packet::getk $ptag kind]
if {$pkt_kind == $K_WORK} {
set wpktag [packet::append $ptag $wpktag]
task::setkv $tcb wpktag $wpktag
} else {
set dpktag [packet::append $ptag $dpktag]
task::setkv $tcb dpktag $dpktag
}
}
if {$wpktag} {
set count [packet::getk $wpktag a1]
if {$count > $BUFSIZE} {
task::setkv $tcb wpktag [packet::getk $wpktag link]
return [qpkt $wpktag]
}
if {$dpktag} {
task::setkv $tcb dpktag [packet::getk $dpktag link]
packet::setkv $dpktag a1 [lindex [
packet::getk $wpktag a2] $count]
packet::setkv $wpktag a1 [expr {$count + 1}]
return [qpkt $dpktag]
}
}
return [wait]
}
proc wait {} {
global tcb
global WAITBIT
task::setkv $tcb state [expr {[task::getk $tcb state] | $WAITBIT}]
return $tcb
}
proc release {id} {
global tcb
global NOTHOLDBIT
set t [findtcb $id]
if {!$t} {
return $t
}
task::setkv $t state [expr {[task::getk $t state] & $NOTHOLDBIT}]
if {[task::getk $t pri] > [task::getk $tcb pri]} {
return $t
}
return $tcb
}
proc holdself {} {
global holdcount tcb
global HOLDBIT
incr holdcount
task::setkv $tcb state [expr {[task::getk $tcb state] | $HOLDBIT}]
return [task::getk $tcb link]
}
proc idlefn {ptag} {
global tcb
global I_DEVA I_DEVB
task::setkv $tcb cnt [expr {[task::getk $tcb cnt] -1}]
if {![task::getk $tcb cnt]} {
return [holdself]
}
set hh [task::getk $tcb hh]
if {($hh & 1) == 0} {
task::setkv $tcb hh [expr {$hh >> 1}]
return [release $I_DEVA]
} else {
task::setkv $tcb hh [expr {($hh >> 1) ^ 0xD008}]
return [release $I_DEVB]
}
}
proc devfn {ptag} {
global tcb tracing
if {!$ptag} {
set wdone [task::getk $tcb workdone]
if {!$wdone} {
return [wait]
}
set ptag $wdone
task::setkv $tcb workdone 0
return [qpkt $ptag]
} else {
task::setkv $tcb workdone $ptag
if {$tracing} {
trace_ [format %c [packet::getk $ptag a1]]
}
return [holdself]
}
}
proc workfn {ptag} {
global tcb
global I_HANDLERA I_HANDLERB BUFSIZE
if {!$ptag} {
return [wait]
}
if {[task::getk $tcb sender] == $I_HANDLERA} {
task::setkv $tcb sender $I_HANDLERB
} else {
task::setkv $tcb sender $I_HANDLERA
}
packet::setkv $ptag id [task::getk $tcb sender]
packet::setkv $ptag a1 0
set a2 [packet::getk $ptag a2]
set count [task::getk $tcb data]
for {set i 0} {$i <= $BUFSIZE} {incr i} {
incr count
if {$count > 26} {
set count 1
}
# A = 65 in ascii
lset a2 $i [expr {65 + $count - 1}]
}
task::setkv $tcb data $count
packet::setkv $ptag a2 $a2
return [qpkt $ptag]
}
proc schedule {} {
global tcb taskid tracing
global S_WAITPKT S_RUN S_RUNPKT
global S_WAIT S_HOLD S_HOLDPKT S_HOLDWAIT S_HOLDWAITPKT
while {$tcb} {
set state [task::getk $tcb state]
set pkt_tag 0
if {$state == $S_WAITPKT || $state == $S_RUN ||
$state == $S_RUNPKT} {
if {$state == $S_WAITPKT} {
set pkt_tag [task::getk $tcb wkq]
set pkt_link [packet::getk $pkt_tag link]
task::setkv $tcb wkq $pkt_link
if {!$pkt_link} {
task::setkv $tcb state $S_RUN
} else {
task::setkv $tcb state $S_RUNPKT
}
}
set taskid [task::getk $tcb id]
if {$tracing} { trace_ $taskid }
set func [task::getk $tcb fn]
set tcb [$func $pkt_tag]
continue
}
if {$state == $S_WAIT || $state == $S_HOLD ||
$state == $S_HOLDPKT || $state == $S_HOLDWAIT ||
$state == $S_HOLDWAITPKT} {
set tcb [task::getk $tcb link]
continue
}
return
}
}
proc trace_ {char} {
global layout
incr layout -1
if {$layout <= 0} {
puts {}
set layout 50
}
puts -nonewline $char
}
proc main {} {
global I_DEVA I_DEVB I_IDLE I_WORK K_DEV S_RUN S_WAIT S_WAITPKT K_WORK
global I_HANDLERA I_HANDLERB
global Count Qpktcountval Holdcountval
global tasktab tcb tasklist qpktcount holdcount layout
puts "Bench mark starting"
createtask $I_IDLE 0 0 $S_RUN idlefn 1 $Count
set wkq [pkt 0 0 $K_WORK]
set wkq [pkt $wkq 0 $K_WORK]
createtask $I_WORK 1000 $wkq $S_WAITPKT workfn $I_HANDLERA 0
set wkq [pkt 0 $I_DEVA $K_DEV]
set wkq [pkt $wkq $I_DEVA $K_DEV]
set wkq [pkt $wkq $I_DEVA $K_DEV]
createtask $I_HANDLERA 2000 $wkq $S_WAITPKT handlerfn 0 0
set wkq [pkt 0 $I_DEVB $K_DEV]
set wkq [pkt $wkq $I_DEVB $K_DEV]
set wkq [pkt $wkq $I_DEVB $K_DEV]
createtask $I_HANDLERB 3000 $wkq $S_WAITPKT handlerfn 0 0
createtask $I_DEVA 4000 0 $S_WAIT devfn 0
createtask $I_DEVB 5000 0 $S_WAIT devfn 0
set tcb $tasklist
set qpktcount 0
set holdcount 0
set layout 0
puts "Starting"
schedule
puts "\nfinished"
puts "qpkt count = $qpktcount, holdcount = $holdcount"
puts -nonewline "These results are "
if {$qpktcount == $Qpktcountval && $holdcount == $Holdcountval} {
puts "correct"
} else {
puts "incorrect"
}
puts "end of run"
}
puts [time main 1]