Import BSDDB 4.7.25 (as of svn r89086)
This commit is contained in:
Zachary Ware
384
test/parallel.tcl
Normal file
384
test/parallel.tcl
Normal file
@@ -0,0 +1,384 @@
|
||||
# Code to load up the tests in to the Queue database
|
||||
# $Id: parallel.tcl,v 12.6 2007/06/05 20:00:46 carol Exp $
|
||||
proc load_queue { file {dbdir RUNQUEUE} nitems } {
|
||||
global serial_tests
|
||||
global num_serial
|
||||
global num_parallel
|
||||
|
||||
puts -nonewline "Loading run queue with $nitems items..."
|
||||
flush stdout
|
||||
|
||||
set env [berkdb_env -create -lock -home $dbdir]
|
||||
error_check_good dbenv [is_valid_env $env] TRUE
|
||||
|
||||
# Open two databases, one for tests that may be run
|
||||
# in parallel, the other for tests we want to run
|
||||
# while only a single process is testing.
|
||||
set db [eval {berkdb_open -env $env -create \
|
||||
-mode 0644 -len 200 -queue queue.db} ]
|
||||
error_check_good dbopen [is_valid_db $db] TRUE
|
||||
set serialdb [eval {berkdb_open -env $env -create \
|
||||
-mode 0644 -len 200 -queue serialqueue.db} ]
|
||||
error_check_good dbopen [is_valid_db $serialdb] TRUE
|
||||
|
||||
set fid [open $file]
|
||||
|
||||
set count 0
|
||||
|
||||
while { [gets $fid str] != -1 } {
|
||||
set testarr($count) $str
|
||||
incr count
|
||||
}
|
||||
|
||||
# Randomize array of tests.
|
||||
set rseed [pid]
|
||||
berkdb srand $rseed
|
||||
puts -nonewline "randomizing..."
|
||||
flush stdout
|
||||
for { set i 0 } { $i < $count } { incr i } {
|
||||
set tmp $testarr($i)
|
||||
|
||||
# RPC test is very long so force it to run first
|
||||
# in full runs. If we find 'r rpc' as we walk the
|
||||
# array, arrange to put it in slot 0 ...
|
||||
if { [is_substr $tmp "r rpc"] == 1 && \
|
||||
[string match $nitems ALL] } {
|
||||
set j 0
|
||||
} else {
|
||||
set j [berkdb random_int $i [expr $count - 1]]
|
||||
}
|
||||
# ... and if 'r rpc' is selected to be swapped with the
|
||||
# current item in the array, skip the swap. If we
|
||||
# did the swap and moved to the next item, "r rpc" would
|
||||
# never get moved to slot 0.
|
||||
if { [is_substr $testarr($j) "r rpc"] && \
|
||||
[string match $nitems ALL] } {
|
||||
continue
|
||||
}
|
||||
|
||||
set testarr($i) $testarr($j)
|
||||
set testarr($j) $tmp
|
||||
}
|
||||
|
||||
if { [string compare ALL $nitems] != 0 } {
|
||||
set maxload $nitems
|
||||
} else {
|
||||
set maxload $count
|
||||
}
|
||||
|
||||
puts "loading..."
|
||||
flush stdout
|
||||
set num_serial 0
|
||||
set num_parallel 0
|
||||
for { set i 0 } { $i < $maxload } { incr i } {
|
||||
set str $testarr($i)
|
||||
# Push serial tests into serial testing db, others
|
||||
# into parallel db.
|
||||
if { [is_serial $str] } {
|
||||
set ret [eval {$serialdb put -append $str}]
|
||||
error_check_good put:serialdb [expr $ret > 0] 1
|
||||
incr num_serial
|
||||
} else {
|
||||
set ret [eval {$db put -append $str}]
|
||||
error_check_good put:paralleldb [expr $ret > 0] 1
|
||||
incr num_parallel
|
||||
}
|
||||
}
|
||||
|
||||
error_check_good maxload $maxload [expr $num_serial + $num_parallel]
|
||||
puts "Loaded $maxload records: $num_serial in serial,\
|
||||
$num_parallel in parallel."
|
||||
close $fid
|
||||
$db close
|
||||
$serialdb close
|
||||
$env close
|
||||
}
|
||||
|
||||
proc init_runqueue { {dbdir RUNQUEUE} nitems list} {
|
||||
|
||||
if { [file exists $dbdir] != 1 } {
|
||||
file mkdir $dbdir
|
||||
}
|
||||
puts "Creating test list..."
|
||||
$list ALL -n
|
||||
load_queue ALL.OUT $dbdir $nitems
|
||||
file delete TEST.LIST
|
||||
file rename ALL.OUT TEST.LIST
|
||||
}
|
||||
|
||||
proc run_parallel { nprocs {list run_all} {nitems ALL} } {
|
||||
global num_serial
|
||||
global num_parallel
|
||||
|
||||
# Forcibly remove stuff from prior runs, if it's still there.
|
||||
fileremove -f ./RUNQUEUE
|
||||
set dirs [glob -nocomplain ./PARALLEL_TESTDIR.*]
|
||||
set files [glob -nocomplain ALL.OUT.*]
|
||||
foreach file $files {
|
||||
fileremove -f $file
|
||||
}
|
||||
foreach dir $dirs {
|
||||
fileremove -f $dir
|
||||
}
|
||||
|
||||
set basename ./PARALLEL_TESTDIR
|
||||
set queuedir ./RUNQUEUE
|
||||
source ./include.tcl
|
||||
|
||||
mkparalleldirs $nprocs $basename $queuedir
|
||||
|
||||
init_runqueue $queuedir $nitems $list
|
||||
|
||||
set basedir [pwd]
|
||||
set queuedir ../../[string range $basedir \
|
||||
[string last "/" $basedir] end]/$queuedir
|
||||
|
||||
# Run serial tests in parallel testdir 0.
|
||||
run_queue 0 $basename.0 $queuedir serial $num_serial
|
||||
|
||||
set pidlist {}
|
||||
# Run parallel tests in testdirs 1 through n.
|
||||
for { set i 1 } { $i <= $nprocs } { incr i } {
|
||||
set ret [catch {
|
||||
set p [exec $tclsh_path << \
|
||||
"source $test_path/test.tcl; run_queue $i \
|
||||
$basename.$i $queuedir parallel $num_parallel" &]
|
||||
lappend pidlist $p
|
||||
set f [open $testdir/begin.$p w]
|
||||
close $f
|
||||
} res]
|
||||
}
|
||||
watch_procs $pidlist 300 1000000
|
||||
|
||||
set failed 0
|
||||
for { set i 0 } { $i <= $nprocs } { incr i } {
|
||||
if { [file exists ALL.OUT.$i] == 1 } {
|
||||
puts -nonewline "Checking output from ALL.OUT.$i ... "
|
||||
if { [check_output ALL.OUT.$i] == 1 } {
|
||||
set failed 1
|
||||
}
|
||||
puts " done."
|
||||
}
|
||||
}
|
||||
if { $failed == 0 } {
|
||||
puts "Regression tests succeeded."
|
||||
} else {
|
||||
puts "Regression tests failed."
|
||||
puts "Review UNEXPECTED OUTPUT lines above for errors."
|
||||
puts "Complete logs found in ALL.OUT.x files"
|
||||
}
|
||||
}
|
||||
|
||||
proc run_queue { i rundir queuedir {qtype parallel} {nitems 0} } {
|
||||
set builddir [pwd]
|
||||
file delete $builddir/ALL.OUT.$i
|
||||
cd $rundir
|
||||
|
||||
puts "Starting $qtype run_queue process $i (pid [pid])."
|
||||
|
||||
source ./include.tcl
|
||||
global env
|
||||
|
||||
set dbenv [berkdb_env -create -lock -home $queuedir]
|
||||
error_check_good dbenv [is_valid_env $dbenv] TRUE
|
||||
|
||||
if { $qtype == "parallel" } {
|
||||
set db [eval {berkdb_open -env $dbenv \
|
||||
-mode 0644 -queue queue.db} ]
|
||||
error_check_good dbopen [is_valid_db $db] TRUE
|
||||
} elseif { $qtype == "serial" } {
|
||||
set db [eval {berkdb_open -env $dbenv \
|
||||
-mode 0644 -queue serialqueue.db} ]
|
||||
error_check_good serialdbopen [is_valid_db $db] TRUE
|
||||
} else {
|
||||
puts "FAIL: queue type $qtype not recognized"
|
||||
}
|
||||
|
||||
set dbc [eval $db cursor]
|
||||
error_check_good cursor [is_valid_cursor $dbc $db] TRUE
|
||||
|
||||
set count 0
|
||||
set waitcnt 0
|
||||
set starttime [timestamp -r]
|
||||
|
||||
while { $waitcnt < 5 } {
|
||||
set line [$db get -consume]
|
||||
if { [ llength $line ] > 0 } {
|
||||
set cmd [lindex [lindex $line 0] 1]
|
||||
set num [lindex [lindex $line 0] 0]
|
||||
set o [open $builddir/ALL.OUT.$i a]
|
||||
puts $o "\nExecuting record $num ([timestamp -w]):\n"
|
||||
set tdir "TESTDIR.$i"
|
||||
regsub -all {TESTDIR} $cmd $tdir cmd
|
||||
puts $o $cmd
|
||||
close $o
|
||||
if { [expr {$num % 10} == 0] && $nitems != 0 } {
|
||||
puts -nonewline \
|
||||
"Starting test $num of $nitems $qtype items. "
|
||||
set now [timestamp -r]
|
||||
set elapsed_secs [expr $now - $starttime]
|
||||
set secs_per_test [expr $elapsed_secs / $num]
|
||||
set esttotal [expr $nitems * $secs_per_test]
|
||||
set remaining [expr $esttotal - $elapsed_secs]
|
||||
if { $remaining < 3600 } {
|
||||
puts "\tRough guess: less than 1\
|
||||
hour left."
|
||||
} else {
|
||||
puts "\tRough guess: \
|
||||
[expr $remaining / 3600] hour(s) left."
|
||||
}
|
||||
}
|
||||
# puts "Process $i, record $num:\n$cmd"
|
||||
set env(PURIFYOPTIONS) \
|
||||
"-log-file=./test$num.%p -follow-child-processes -messages=first"
|
||||
set env(PURECOVOPTIONS) \
|
||||
"-counts-file=./cov.pcv -log-file=./cov.log -follow-child-processes"
|
||||
if [catch {exec $tclsh_path \
|
||||
<< "source $test_path/test.tcl; $cmd" \
|
||||
>>& $builddir/ALL.OUT.$i } res] {
|
||||
set o [open $builddir/ALL.OUT.$i a]
|
||||
puts $o "FAIL: '$cmd': $res"
|
||||
close $o
|
||||
}
|
||||
env_cleanup $testdir
|
||||
set o [open $builddir/ALL.OUT.$i a]
|
||||
puts $o "\nEnding record $num ([timestamp])\n"
|
||||
close $o
|
||||
incr count
|
||||
} else {
|
||||
incr waitcnt
|
||||
tclsleep 1
|
||||
}
|
||||
}
|
||||
|
||||
set now [timestamp -r]
|
||||
set elapsed [expr $now - $starttime]
|
||||
puts "Process $i: $count commands executed in [format %02u:%02u \
|
||||
[expr $elapsed / 3600] [expr ($elapsed % 3600) / 60]]"
|
||||
|
||||
error_check_good close_parallel_cursor_$i [$dbc close] 0
|
||||
error_check_good close_parallel_db_$i [$db close] 0
|
||||
error_check_good close_parallel_env_$i [$dbenv close] 0
|
||||
|
||||
#
|
||||
# We need to put the pid file in the builddir's idea
|
||||
# of testdir, not this child process' local testdir.
|
||||
# Therefore source builddir's include.tcl to get its
|
||||
# testdir.
|
||||
# !!! This resets testdir, so don't do anything else
|
||||
# local to the child after this.
|
||||
source $builddir/include.tcl
|
||||
|
||||
set f [open $builddir/$testdir/end.[pid] w]
|
||||
close $f
|
||||
cd $builddir
|
||||
}
|
||||
|
||||
proc mkparalleldirs { nprocs basename queuedir } {
|
||||
source ./include.tcl
|
||||
set dir [pwd]
|
||||
|
||||
if { $is_windows_test != 1 } {
|
||||
set EXE ""
|
||||
} else {
|
||||
set EXE ".exe"
|
||||
}
|
||||
for { set i 0 } { $i <= $nprocs } { incr i } {
|
||||
set destdir $basename.$i
|
||||
catch {file mkdir $destdir}
|
||||
puts "Created $destdir"
|
||||
if { $is_windows_test == 1 } {
|
||||
catch {file mkdir $destdir/Debug}
|
||||
catch {eval file copy \
|
||||
[eval glob {$dir/Debug/*.dll}] $destdir/Debug}
|
||||
}
|
||||
catch {eval file copy \
|
||||
[eval glob {$dir/{.libs,include.tcl}}] $destdir}
|
||||
# catch {eval file copy $dir/$queuedir $destdir}
|
||||
catch {eval file copy \
|
||||
[eval glob {$dir/db_{checkpoint,deadlock}$EXE} \
|
||||
{$dir/db_{dump,load,printlog,recover,stat,upgrade}$EXE} \
|
||||
{$dir/db_{archive,verify,hotbackup}$EXE}] \
|
||||
$destdir}
|
||||
|
||||
# Create modified copies of include.tcl in parallel
|
||||
# directories so paths still work.
|
||||
|
||||
set infile [open ./include.tcl r]
|
||||
set d [read $infile]
|
||||
close $infile
|
||||
|
||||
regsub {test_path } $d {test_path ../} d
|
||||
regsub {src_root } $d {src_root ../} d
|
||||
set tdir "TESTDIR.$i"
|
||||
regsub -all {TESTDIR} $d $tdir d
|
||||
regsub {KILL \.} $d {KILL ..} d
|
||||
set outfile [open $destdir/include.tcl w]
|
||||
puts $outfile $d
|
||||
close $outfile
|
||||
|
||||
global svc_list
|
||||
foreach svc_exe $svc_list {
|
||||
if { [file exists $dir/$svc_exe] } {
|
||||
catch {eval file copy $dir/$svc_exe $destdir}
|
||||
}
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
proc run_ptest { nprocs test args } {
|
||||
global parms
|
||||
global valid_methods
|
||||
set basename ./PARALLEL_TESTDIR
|
||||
set queuedir NULL
|
||||
source ./include.tcl
|
||||
|
||||
mkparalleldirs $nprocs $basename $queuedir
|
||||
|
||||
if { [info exists parms($test)] } {
|
||||
foreach method $valid_methods {
|
||||
if { [eval exec_ptest $nprocs $basename \
|
||||
$test $method $args] != 0 } {
|
||||
break
|
||||
}
|
||||
}
|
||||
} else {
|
||||
eval exec_ptest $nprocs $basename $test $args
|
||||
}
|
||||
}
|
||||
|
||||
proc exec_ptest { nprocs basename test args } {
|
||||
source ./include.tcl
|
||||
|
||||
set basedir [pwd]
|
||||
set pidlist {}
|
||||
puts "Running $nprocs parallel runs of $test"
|
||||
for { set i 1 } { $i <= $nprocs } { incr i } {
|
||||
set outf ALL.OUT.$i
|
||||
fileremove -f $outf
|
||||
set ret [catch {
|
||||
set p [exec $tclsh_path << \
|
||||
"cd $basename.$i;\
|
||||
source ../$test_path/test.tcl;\
|
||||
$test $args" >& $outf &]
|
||||
lappend pidlist $p
|
||||
set f [open $testdir/begin.$p w]
|
||||
close $f
|
||||
} res]
|
||||
}
|
||||
watch_procs $pidlist 30 36000
|
||||
set failed 0
|
||||
for { set i 1 } { $i <= $nprocs } { incr i } {
|
||||
if { [check_output ALL.OUT.$i] == 1 } {
|
||||
set failed 1
|
||||
puts "Test $test failed in process $i."
|
||||
}
|
||||
}
|
||||
if { $failed == 0 } {
|
||||
puts "Test $test succeeded all processes"
|
||||
return 0
|
||||
} else {
|
||||
puts "Test failed: stopping"
|
||||
return 1
|
||||
}
|
||||
}
|
||||
Reference in New Issue
Block a user