1# bench.tcl -- 2# 3# Management of benchmarks. 4# 5# Copyright (c) 2005-2008 by Andreas Kupries <andreas_kupries@users.sourceforge.net> 6# library derived from runbench.tcl application (C) Jeff Hobbs. 7# 8# See the file "license.terms" for information on usage and redistribution 9# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 10# 11# RCS: @(#) $Id: bench.tcl,v 1.14 2008/10/08 03:30:48 andreas_kupries Exp $ 12 13# ### ### ### ######### ######### ######### ########################### 14## Requisites - Packages and namespace for the commands and data. 15 16package require Tcl 8.2 17package require logger 18package require csv 19package require struct::matrix 20package require report 21 22namespace eval ::bench {} 23namespace eval ::bench::out {} 24 25# @mdgen OWNER: libbench.tcl 26 27# ### ### ### ######### ######### ######### ########################### 28## Public API - Benchmark execution 29 30# ::bench::run -- 31# 32# Run a series of benchmarks. 33# 34# Arguments: 35# ... 36# 37# Results: 38# Dictionary. 39 40proc ::bench::run {args} { 41 log::debug [linsert $args 0 ::bench::run] 42 43 # -errors 0|1 default 1, propagate errors in benchmarks 44 # -threads <num> default 0, no threads, #threads to use 45 # -match <pattern> only run tests matching this pattern 46 # -rmatch <pattern> only run tests matching this pattern 47 # -iters <num> default 1000, max#iterations for any benchmark 48 # -pkgdir <dir> Defaults to nothing, regular bench invokation. 49 50 # interps - dict (path -> version) 51 # files - list (of files) 52 53 # Process arguments ...................................... 54 # Defaults first, then overides by the user 55 56 set errors 1 ; # Propagate errors 57 set threads 0 ; # Do not use threads 58 set match {} ; # Do not exclude benchmarks based on glob pattern 59 set rmatch {} ; # Do not exclude benchmarks based on regex pattern 60 set iters 1000 ; # Limit #iterations for any benchmark 61 set pkgdirs {} ; # List of dirs to put in front of auto_path in the 62 # bench interpreters. Default: nothing. 63 64 while {[string match "-*" [set opt [lindex $args 0]]]} { 65 set val [lindex $args 1] 66 switch -exact -- $opt { 67 -errors { 68 if {![string is boolean -strict $val]} { 69 return -code error "Expected boolean, got \"$val\"" 70 } 71 set errors $val 72 } 73 -threads { 74 if {![string is int -strict $val] || ($val < 0)} { 75 return -code error "Expected int >= 0, got \"$val\"" 76 } 77 set threads [lindex $args 1] 78 } 79 -match { 80 set match [lindex $args 1] 81 } 82 -rmatch { 83 set rmatch [lindex $args 1] 84 } 85 -iters { 86 if {![string is int -strict $val] || ($val <= 0)} { 87 return -code error "Expected int > 0, got \"$val\"" 88 } 89 set iters [lindex $args 1] 90 } 91 -pkgdir { 92 CheckPkgDirArg $val 93 lappend pkgdirs $val 94 } 95 default { 96 return -code error "Unknown option \"$opt\", should -errors, -threads, -match, -rmatch, or -iters" 97 } 98 } 99 set args [lrange $args 2 end] 100 } 101 if {[llength $args] != 2} { 102 return -code error "wrong\#args, should be: ?options? interp files" 103 } 104 foreach {interps files} $args break 105 106 # Run the benchmarks ..................................... 107 108 array set DATA {} 109 110 if {![llength $pkgdirs]} { 111 # No user specified package directories => Simple run. 112 foreach {ip ver} $interps { 113 Invoke $ip $ver {} ;# DATA etc passed via upvar. 114 } 115 } else { 116 # User specified package directories. 117 foreach {ip ver} $interps { 118 foreach pkgdir $pkgdirs { 119 Invoke $ip $ver $pkgdir ;# DATA etc passed via upvar. 120 } 121 } 122 } 123 124 # Benchmark data ... Structure, dict (key -> value) 125 # 126 # Key || Value 127 # ============ ++ ========================================= 128 # interp IP -> Version. Shell IP was used to run benchmarks. IP is 129 # the path to the shell. 130 # 131 # desc DESC -> "". DESC is description of an executed benchmark. 132 # 133 # usec DESC IP -> Result. Result of benchmark DESC when run by the 134 # shell IP. Usually time in microseconds, but can be 135 # a special code as well (ERR, BAD_RES). 136 # ============ ++ ========================================= 137 138 return [array get DATA] 139} 140 141# ::bench::locate -- 142# 143# Locate interpreters on the pathlist, based on a pattern. 144# 145# Arguments: 146# ... 147# 148# Results: 149# List of paths. 150 151proc ::bench::locate {pattern paths} { 152 # Cache of executables already found. 153 array set var {} 154 set res {} 155 156 foreach path $paths { 157 foreach ip [glob -nocomplain [file join $path $pattern]] { 158 if {[package vsatisfies [package provide Tcl] 8.4]} { 159 set ip [file normalize $ip] 160 } 161 162 # Follow soft-links to the actual executable. 163 while {[string equal link [file type $ip]]} { 164 set link [file readlink $ip] 165 if {[string match relative [file pathtype $link]]} { 166 set ip [file join [file dirname $ip] $link] 167 } else { 168 set ip $link 169 } 170 } 171 172 if { 173 [file executable $ip] && ![info exists var($ip)] 174 } { 175 if {[catch {exec $ip << "exit"} dummy]} { 176 log::debug "$ip: $dummy" 177 continue 178 } 179 set var($ip) . 180 lappend res $ip 181 } 182 } 183 } 184 185 return $res 186} 187 188# ::bench::versions -- 189# 190# Take list of interpreters, find their versions. 191# Removes all interps for which it cannot do so. 192# 193# Arguments: 194# List of interpreters (paths) 195# 196# Results: 197# dictionary: interpreter -> version. 198 199proc ::bench::versions {interps} { 200 set res {} 201 foreach ip $interps { 202 if {[catch { 203 exec $ip << {puts [info patchlevel] ; exit} 204 } patchlevel]} { 205 log::debug "$ip: $patchlevel" 206 continue 207 } 208 209 lappend res [list $patchlevel $ip] 210 } 211 212 # -uniq 8.4-ism, replaced with use of array. 213 array set tmp {} 214 set resx {} 215 foreach item [lsort -dictionary -decreasing -index 0 $res] { 216 foreach {p ip} $item break 217 if {[info exists tmp($p)]} continue 218 set tmp($p) . 219 lappend resx $ip $p 220 } 221 222 return $resx 223} 224 225# ::bench::merge -- 226# 227# Take the data of several benchmark runs and merge them into 228# one data set. 229# 230# Arguments: 231# One or more data sets to merge 232# 233# Results: 234# The merged data set. 235 236proc ::bench::merge {args} { 237 if {[llength $args] == 1} { 238 return [lindex $args 0] 239 } 240 241 array set DATA {} 242 foreach data $args { 243 array set DATA $data 244 } 245 return [array get DATA] 246} 247 248# ::bench::norm -- 249# 250# Normalize the time data in the dataset, using one of the 251# columns as reference. 252# 253# Arguments: 254# Data to normalize 255# Index of reference column 256# 257# Results: 258# The normalized data set. 259 260proc ::bench::norm {data col} { 261 262 if {![string is integer -strict $col]} { 263 return -code error "Ref.column: Expected integer, but got \"$col\"" 264 } 265 if {$col < 1} { 266 return -code error "Ref.column out of bounds" 267 } 268 269 array set DATA $data 270 set ipkeys [array names DATA interp*] 271 272 if {$col > [llength $ipkeys]} { 273 return -code error "Ref.column out of bounds" 274 } 275 incr col -1 276 set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] 277 278 foreach key [array names DATA] { 279 if {[string match "desc*" $key]} continue 280 if {[string match "interp*" $key]} continue 281 282 foreach {_ desc ip} $key break 283 if {[string equal $ip $refip]} continue 284 285 set v $DATA($key) 286 if {![string is double -strict $v]} continue 287 288 if {![info exists DATA([list usec $desc $refip])]} { 289 # We cannot normalize, we do not keep the time value. 290 # The row will be shown, empty. 291 set DATA($key) "" 292 continue 293 } 294 set vref $DATA([list usec $desc $refip]) 295 296 if {![string is double -strict $vref]} continue 297 298 set DATA($key) [expr {$v/double($vref)}] 299 } 300 301 foreach key [array names DATA [list * $refip]] { 302 if {![string is double -strict $DATA($key)]} continue 303 set DATA($key) 1 304 } 305 306 return [array get DATA] 307} 308 309# ::bench::edit -- 310# 311# Change the 'path' of an interp to a user-defined value. 312# 313# Arguments: 314# Data to edit 315# Index of column to change 316# The value replacing the current path 317# 318# Results: 319# The changed data set. 320 321proc ::bench::edit {data col new} { 322 323 if {![string is integer -strict $col]} { 324 return -code error "Ref.column: Expected integer, but got \"$col\"" 325 } 326 if {$col < 1} { 327 return -code error "Ref.column out of bounds" 328 } 329 330 array set DATA $data 331 set ipkeys [array names DATA interp*] 332 333 if {$col > [llength $ipkeys]} { 334 return -code error "Ref.column out of bounds" 335 } 336 incr col -1 337 set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] 338 339 if {[string equal $new $refip]} { 340 # No change, quick return 341 return $data 342 } 343 344 set refkey [list interp $refip] 345 set DATA([list interp $new]) $DATA($refkey) 346 unset DATA($refkey) 347 348 foreach key [array names DATA [list * $refip]] { 349 if {![string equal [lindex $key 0] "usec"]} continue 350 foreach {__ desc ip} $key break 351 set DATA([list usec $desc $new]) $DATA($key) 352 unset DATA($key) 353 } 354 355 return [array get DATA] 356} 357 358# ::bench::del -- 359# 360# Remove the data for an interp. 361# 362# Arguments: 363# Data to edit 364# Index of column to remove 365# 366# Results: 367# The changed data set. 368 369proc ::bench::del {data col} { 370 371 if {![string is integer -strict $col]} { 372 return -code error "Ref.column: Expected integer, but got \"$col\"" 373 } 374 if {$col < 1} { 375 return -code error "Ref.column out of bounds" 376 } 377 378 array set DATA $data 379 set ipkeys [array names DATA interp*] 380 381 if {$col > [llength $ipkeys]} { 382 return -code error "Ref.column out of bounds" 383 } 384 incr col -1 385 set refip [lindex [lindex [lsort -dict $ipkeys] $col] 1] 386 387 unset DATA([list interp $refip]) 388 389 # Do not use 'array unset'. Keep 8.2 clean. 390 foreach key [array names DATA [list * $refip]] { 391 if {![string equal [lindex $key 0] "usec"]} continue 392 unset DATA($key) 393 } 394 395 return [array get DATA] 396} 397 398# ### ### ### ######### ######### ######### ########################### 399## Public API - Result formatting. 400 401# ::bench::out::raw -- 402# 403# Format the result of a benchmark run. 404# Style: Raw data. 405# 406# Arguments: 407# DATA dict 408# 409# Results: 410# String containing the formatted DATA. 411 412proc ::bench::out::raw {data} { 413 return $data 414} 415 416# ### ### ### ######### ######### ######### ########################### 417## Internal commands 418 419proc ::bench::CheckPkgDirArg {path {expected {}}} { 420 # Allow empty string, special. 421 if {![string length $path]} return 422 423 if {![file isdirectory $path]} { 424 return -code error \ 425 "The path \"$path\" is not a directory." 426 } 427 if {![file readable $path]} { 428 return -code error \ 429 "The path \"$path\" is not readable." 430 } 431} 432 433proc ::bench::Invoke {ip ver pkgdir} { 434 variable self 435 # Import remainder of the current configuration/settings. 436 437 upvar 1 DATA DATA match match rmatch rmatch \ 438 iters iters errors errors threads threads \ 439 files files 440 441 if {[string length $pkgdir]} { 442 log::info "Benchmark $ver ($pkgdir) $ip" 443 set idstr "$ip ($pkgdir)" 444 } else { 445 log::info "Benchmark $ver $ip" 446 set idstr $ip 447 } 448 449 set DATA([list interp $idstr]) $ver 450 451 set cmd [list $ip [file join $self libbench.tcl] \ 452 -match $match \ 453 -rmatch $rmatch \ 454 -iters $iters \ 455 -interp $ip \ 456 -errors $errors \ 457 -threads $threads \ 458 -pkgdir $pkgdir \ 459 ] 460 461 # Determine elapsed time per file, logged. 462 set start [clock seconds] 463 464 array set tmp {} 465 466 if {$threads} { 467 foreach f $files { lappend cmd $f } 468 if {[catch { 469 close [Process [open |$cmd r+]] 470 } output]} { 471 if {$errors} { 472 error $::errorInfo 473 } 474 } 475 } else { 476 foreach file $files { 477 log::info [file tail $file] 478 if {[catch { 479 close [Process [open |[linsert $cmd end $file] r+]] 480 } output]} { 481 if {$errors} { 482 error $::errorInfo 483 } else { 484 continue 485 } 486 } 487 } 488 } 489 490 foreach desc [array names tmp] { 491 set DATA([list desc $desc]) {} 492 set DATA([list usec $desc $idstr]) $tmp($desc) 493 } 494 495 unset tmp 496 set elapsed [expr {[clock seconds] - $start}] 497 498 set hour [expr {$elapsed / 3600}] 499 set min [expr {$elapsed / 60}] 500 set sec [expr {$elapsed % 60}] 501 log::info " [format %.2d:%.2d:%.2d $hour $min $sec] elapsed" 502 return 503} 504 505 506proc ::bench::Process {pipe} { 507 while {1} { 508 if {[eof $pipe]} break 509 if {[gets $pipe line] < 0} break 510 # AK: FUTURE: Log all lines?! 511 #puts |$line| 512 set line [string trim $line] 513 if {[string equal $line ""]} continue 514 515 Result 516 Feedback 517 # Unknown lines are printed. Future: Callback?! 518 log::info $line 519 } 520 return $pipe 521} 522 523proc ::bench::Result {} { 524 upvar 1 line line 525 if {[lindex $line 0] ne "RESULT"} return 526 upvar 2 tmp tmp 527 foreach {_ desc result} $line break 528 set tmp($desc) $result 529 return -code continue 530} 531 532proc ::bench::Feedback {} { 533 upvar 1 line line 534 if {[lindex $line 0] ne "LOG"} return 535 # AK: Future - Run through callback?! 536 log::info [lindex $line 1] 537 return -code continue 538} 539 540# ### ### ### ######### ######### ######### ########################### 541## Initialize internal data structures. 542 543namespace eval ::bench { 544 variable self [file join [pwd] [file dirname [info script]]] 545 546 logger::init bench 547 logger::import -force -all -namespace log bench 548} 549 550# ### ### ### ######### ######### ######### ########################### 551## Ready to run 552 553package provide bench 0.4 554