mirror of
https://github.com/wfjm/w11.git
synced 2026-01-20 02:14:25 +00:00
b8dfa6d41e
- rtl/sys_gen/*/*.vhd: drop superfluous genlib call - rtl/sys_gen/*/*.vmfset: accomodate recent code changes - tools/bin/tbrun: show correct 'found count' in summary message - tools/dox/*.Doxyfile: push version to 0.753 - tools/src/librtools/Rtime.ipp: change list-init make some gcc happy
860 lines
24 KiB
Perl
Executable File
860 lines
24 KiB
Perl
Executable File
#!/usr/bin/perl -w
|
|
# $Id: tbrun 1097 2018-12-29 11:20:14Z mueller $
|
|
#
|
|
# Copyright 2016-2018 by Walter F.J. Mueller <W.F.J.Mueller@gsi.de>
|
|
#
|
|
# This program is free software; you may redistribute and/or modify it under
|
|
# the terms of the GNU General Public License as published by the Free
|
|
# Software Foundation, either version 3, or (at your option) any later version.
|
|
#
|
|
# This program is distributed in the hope that it will be useful, but
|
|
# WITHOUT ANY WARRANTY, without even the implied warranty of MERCHANTABILITY
|
|
# or FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License
|
|
# for complete details.
|
|
#
|
|
# Revision History:
|
|
# Date Rev Version Comment
|
|
# 2018-12-29 1097 1.1.2 show correct 'found count' in summary message
|
|
# 2018-11-16 1069 1.1.1 add --all
|
|
# 2018-11-09 1066 1.1 add and use bailout; update exit code usage
|
|
# 2017-04-15 875 1.0.1 add --help option
|
|
# 2016-09-17 808 1.0 Initial version
|
|
# 2016-08-09 796 0.1 First draft
|
|
#
|
|
|
|
use 5.14.0; # require Perl 5.14 or higher
|
|
use strict; # require strict checking
|
|
|
|
use Getopt::Long;
|
|
use FileHandle;
|
|
use YAML::XS;
|
|
use Cwd;
|
|
use IO::Select;
|
|
use Time::HiRes qw(gettimeofday);
|
|
|
|
my %opts = ();
|
|
|
|
GetOptions(\%opts, "tag=s@", "exclude=s@", "mode=s", "all",
|
|
"jobs=i", "tee=s", "tmax=i", "dry", "trace",
|
|
"nomake", "norun",
|
|
"rlmon", "rbmon", "bwait=i", "swait=i",
|
|
"help"
|
|
)
|
|
or bailout("bad command options");
|
|
|
|
my @tlist;
|
|
my @olist;
|
|
my @wlist;
|
|
|
|
|
|
my %keys_include = ( include => { mode => 'm', ref => ''},
|
|
tag => { mode => 'o', ref => 'ARRAY'}
|
|
);
|
|
my %keys_default = ( default => { mode => 'm', ref => 'HASH'}
|
|
);
|
|
my %keys_defhash = ( tag => { mode => 'o', ref => 'ARRAY'},
|
|
mode => { mode => 'o', ref => ''}
|
|
);
|
|
my %keys_itest = ( test => { mode => 'm', ref => ''},
|
|
tag => { mode => 'o', ref => 'ARRAY'},
|
|
mode => { mode => 'o', ref => ''}
|
|
);
|
|
|
|
my $nseen = 0;
|
|
my $ntest = 0;
|
|
my $ndone = 0;
|
|
my $nfail = 0;
|
|
my $inicwd = getcwd();
|
|
my %gblvars;
|
|
|
|
$gblvars{ise_modes} = '[bsft]sim,ISim_[bsft]sim';
|
|
$gblvars{ise_modes_noisim} = '[bsft]sim'; # when ISim not possible
|
|
$gblvars{ise_modes_nossim} = 'bsim,ISim_bsim'; # when ssim not available
|
|
#
|
|
$gblvars{viv_modes} = '[bsor]sim,XSim_[bsorept]sim';
|
|
$gblvars{viv_modes_nossim} = 'bsim,XSim_bsim'; # when ssim not available
|
|
|
|
if ($opts{help}) {
|
|
print_usage();
|
|
exit 0;
|
|
}
|
|
|
|
autoflush STDOUT 1 if -p STDOUT || -t STDOUT;
|
|
my $ticker_on = -t STDOUT;
|
|
|
|
my $fh_tee;
|
|
if (defined $opts{tee} && $opts{tee} ne '') {
|
|
$fh_tee = new FileHandle;
|
|
$fh_tee->open($opts{tee},'>')
|
|
or bailout("failed to open for write '$opts{tee}': $!");
|
|
}
|
|
|
|
if ($opts{all}) {
|
|
bailout("-all not compatible with --tag options") if defined $opts{tag};
|
|
$opts{tag} = ['.*']
|
|
}
|
|
|
|
$opts{tag} = ['default'] unless defined $opts{tag};
|
|
$opts{mode} = 'bsim' unless defined $opts{mode};
|
|
|
|
my %modecache;
|
|
my @modelist;
|
|
foreach (split /,/,$opts{mode}) {
|
|
$_ .= '_bsim' if m/^[IX]Sim$/;
|
|
push @modelist, $_;
|
|
}
|
|
|
|
push @ARGV, 'tbrun.yml' unless scalar( @ARGV);
|
|
|
|
my @tagincl = setup_tagfilter($opts{tag});
|
|
my @tagexcl = setup_tagfilter($opts{exclude});
|
|
|
|
foreach my $fnam (@ARGV) {
|
|
include_file($fnam);
|
|
}
|
|
|
|
$ntest = scalar(@tlist);
|
|
unless ($ntest) {
|
|
tpre(sprintf "tbrun-E: %d tests found, none selected\n", $nseen);
|
|
exit 1;
|
|
}
|
|
|
|
if (defined $opts{jobs}) {
|
|
run_tests_multi();
|
|
} else {
|
|
run_tests_single();
|
|
}
|
|
|
|
if (defined $opts{dry}) {
|
|
tpr(sprintf "#tbrun-I: %d tests found, %d selected\n", $nseen,$ntest);
|
|
} else {
|
|
|
|
if ($nfail) {
|
|
tpr(sprintf "tbrun-I: %d tests failed of %d tests executed\n",$nfail,$ndone);
|
|
} else {
|
|
tpr(sprintf "tbrun-I: all tests passed, %d tests selected from %d found\n",
|
|
$ndone,$nseen);
|
|
}
|
|
}
|
|
|
|
exit ($nfail ? 2 : 0);
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub setup_tagfilter {
|
|
my ($targlist) = @_;
|
|
return () unless defined $targlist;
|
|
my @tagfiltlist;
|
|
foreach my $targ (@$targlist) {
|
|
my @tagfilt = map { "^($_)\$" } split /,/, $targ;
|
|
push @tagfiltlist, \@tagfilt;
|
|
}
|
|
return @tagfiltlist;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub check_tagfilter {
|
|
my ($tfiltlist,$tlist) = @_;
|
|
foreach my $tfilt (@$tfiltlist) { # loop over filters
|
|
my $fok = 1;
|
|
foreach my $tfele (@$tfilt) { # loop over filter elements
|
|
my $match = 0;
|
|
foreach my $tag (@$tlist) { # loop over tags
|
|
$match = $tag =~ m/$tfele/; # tag matchs filter element
|
|
last if $match;
|
|
}
|
|
$fok = 0 unless $match; # filter missed if one element missed
|
|
}
|
|
return 1 if $fok; # return ok of one filter matched
|
|
}
|
|
return 0; # here if no filter matched
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub check_modefilter {
|
|
my ($mode,$mlist) = @_;
|
|
unless (exists $modecache{$mlist}) {
|
|
my %mh;
|
|
foreach my $mi (split /,/,$mlist) {
|
|
if ($mi =~ m/^(.*)\[([a-z]+)\](.*)$/) {
|
|
foreach (split //,$2) {
|
|
$mh{$1.$_.$3} = 1;
|
|
}
|
|
} else {
|
|
$mh{$mi} = 1;
|
|
}
|
|
}
|
|
$modecache{$mlist} = \%mh;
|
|
}
|
|
|
|
my $rmh = $modecache{$mlist};
|
|
return exists $$rmh{$mode};
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub include_file {
|
|
my ($fnam) = @_;
|
|
my $fdat = read_file($fnam);
|
|
exit 1 unless defined $fdat;
|
|
my $ylst = load_yaml($fdat, $fnam);
|
|
exit 1 unless defined $ylst;
|
|
|
|
my $oldcwd = getcwd();
|
|
|
|
if ($fnam =~ m|^(.*)/(.*)$|) {
|
|
chdir $1 or bailout("chdir to '$1' failed with '$!'");
|
|
}
|
|
|
|
my %defhash;
|
|
foreach my $yele (@$ylst) {
|
|
if (exists $yele->{include}) {
|
|
handle_include($yele);
|
|
} elsif (exists $yele->{default}) {
|
|
handle_default($yele, \%defhash);
|
|
} elsif (exists $yele->{test}) {
|
|
handle_itest($yele, \%defhash);
|
|
} else {
|
|
tpr(sprintf "tbrun-E: unknown list element in '%s'\n found keys: %s\n",
|
|
$fnam, join(',',sort keys %$yele));
|
|
exit 1;
|
|
}
|
|
}
|
|
|
|
chdir $oldcwd or bailout("chdir to '$oldcwd' failed with '$!'");
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub read_file {
|
|
my ($fnam) = @_;
|
|
my $fh = new FileHandle;
|
|
if (not open $fh, '<', $fnam) {
|
|
my $err = $!;
|
|
tpre(sprintf "tbrun-E: failed to open '%s'\n cwd: %s\n error: %s\n",
|
|
$fnam, getcwd(), $err);
|
|
return undef;
|
|
}
|
|
# nice trick to slurp the whole file into a variable
|
|
my $fdat = do {
|
|
local $/ = undef;
|
|
<$fh>;
|
|
};
|
|
close $fh;
|
|
return $fdat;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub load_yaml {
|
|
my ($fdat,$fnam) = @_;
|
|
my $ylst;
|
|
eval { $ylst = YAML::XS::Load($fdat); };
|
|
if ($@ ne '') {
|
|
my $err = $@;
|
|
tpre(sprintf "tbrun-E: failed to yaml load '%s'\n cwd: %s\n error: %s\n",
|
|
$fnam, getcwd(), $err);
|
|
return undef;
|
|
}
|
|
if (ref $ylst ne 'ARRAY') {
|
|
tpre(sprintf "tbrun-E: top level yaml is not a list but '%s'\n", ref $ylst);
|
|
return undef;
|
|
}
|
|
foreach my $yele (@$ylst) {
|
|
if (ref $yele ne 'HASH') {
|
|
tpre(sprintf "tbrun-E: second level yaml is not a hash '%s'\n", ref $yele);
|
|
return undef;
|
|
}
|
|
}
|
|
return $ylst;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub check_keys {
|
|
my ($yele, $href) = @_;
|
|
foreach my $keyele ( keys %$yele ) {
|
|
if (not exists $href->{$keyele}) {
|
|
tpre(sprintf "tbrun-E: unexpected key '%s'\n", $keyele);
|
|
return 0;
|
|
}
|
|
my $ref = ref $yele->{$keyele};
|
|
if ($ref ne $href->{$keyele}->{ref}) {
|
|
tpre(sprintf "tbrun-E: key '%s' is type'%s', expected '%s'\n",
|
|
$keyele, $ref, $href->{$keyele}->{ref});
|
|
return 0;
|
|
}
|
|
}
|
|
foreach my $keyref ( keys %$href ) {
|
|
next if $href->{$keyref}->{mode} eq 'o';
|
|
if (not exists $yele->{$keyref}) {
|
|
tpre(sprintf "tbrun-E: key '%s' missing\n", $keyref);
|
|
return 0;
|
|
}
|
|
}
|
|
return 1;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub lookup_var {
|
|
my ($vnam,$hrefs) = @_;
|
|
return $gblvars{$vnam} if exists $gblvars{$vnam};
|
|
if ($vnam =~ m/[A-Z][A-Z0-9_]*/) {
|
|
return $ENV{$vnam} if exists $ENV{$vnam};
|
|
}
|
|
tpre(sprintf "tbrun-E: can't replace '$vnam'\n");
|
|
exit 1;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub expand_vars {
|
|
my ($txt,$hrefs) = @_;
|
|
my $res = '';
|
|
while ($txt ne '') {
|
|
if ($txt =~ m/\$\{([a-zA-Z][a-zA-Z0-9_]*)\}/) {
|
|
my $vnam = $1;
|
|
my $vrep = lookup_var($vnam, $hrefs);
|
|
$res .= $`;
|
|
$res .= $vrep;
|
|
$txt = $';
|
|
} else {
|
|
$res .= $txt;
|
|
last;
|
|
}
|
|
}
|
|
return $res;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub merge_lines {
|
|
my ($txt) = @_;
|
|
$txt =~ s|\s*\\\n\s*| |mg;
|
|
chomp $txt;
|
|
return $txt;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub merge_expand {
|
|
my ($txt,$hrefs) = @_;
|
|
return expand_vars(merge_lines($txt), $hrefs);
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub key_or_def {
|
|
my ($tag,$yele,$defhash) = @_;
|
|
return $yele->{$tag} if exists $yele->{$tag};
|
|
return $defhash->{$tag} if exists $defhash->{$tag};
|
|
return undef;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub handle_include {
|
|
my ($yele) = @_;
|
|
check_keys($yele, \%keys_include) or exit 1;
|
|
|
|
my $fnam = merge_expand($yele->{include}, undef);
|
|
include_file($fnam);
|
|
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub handle_default {
|
|
my ($yele, $defhash) = @_;
|
|
check_keys($yele, \%keys_default) or exit 1;
|
|
check_keys($yele->{default}, \%keys_defhash) or exit 1;
|
|
foreach my $key (keys %{$yele->{default}}) {
|
|
$$defhash{$key} = $$yele{default}{$key};
|
|
}
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub handle_itest {
|
|
my ($yele, $defhash) = @_;
|
|
check_keys($yele, \%keys_itest) or exit 1;
|
|
|
|
$nseen += 1;
|
|
|
|
my $tlist = key_or_def('tag', $yele, $defhash);
|
|
if (defined $tlist) {
|
|
return unless check_tagfilter(\@tagincl, $tlist);
|
|
return if check_tagfilter(\@tagexcl, $tlist);
|
|
}
|
|
|
|
my $mlist = merge_expand(key_or_def('mode', $yele, $defhash), undef);
|
|
|
|
foreach my $mode (@modelist) {
|
|
next unless check_modefilter($mode, $mlist);
|
|
|
|
my $ms = '_' . $mode;
|
|
$ms =~ s/_bsim$//;
|
|
$gblvars{ms} = $ms;
|
|
|
|
my $test = merge_expand($yele->{test}, undef);
|
|
|
|
# forward options for tbrun_tbw or tbrun_tbwrri commands
|
|
if ($test =~ m/^\s*(tbrun_tbw|tbrun_tbwrri)\s+(.*)$/) {
|
|
my $cmd = $1;
|
|
my $rest = $2;
|
|
$test = $cmd;
|
|
$test .= ' --nomake' if $opts{nomake};
|
|
$test .= ' --norun' if $opts{norun};
|
|
if ($cmd eq 'tbrun_tbwrri') {
|
|
$test .= ' --rlmon' if $opts{rlmon};
|
|
$test .= ' --rbmon' if $opts{rbmon};
|
|
$test .= ' --bwait '.$opts{bwait} if $opts{bwait};
|
|
$test .= ' --swait '.$opts{swait} if $opts{swait};
|
|
}
|
|
$test .= ' ' . $rest;
|
|
}
|
|
|
|
my $tid = scalar(@tlist);
|
|
my $tmsg = sprintf "t%03d - tags: ", $tid;
|
|
$tmsg .= join ',',@$tlist if defined $tlist;
|
|
|
|
my %titem;
|
|
$titem{id} = $tid;
|
|
$titem{cd} = getcwd();
|
|
$titem{test} = $test;
|
|
$titem{tag} = $tlist;
|
|
$titem{tmsg} = $tmsg;
|
|
|
|
push @{$titem{locks}}, $titem{cd};
|
|
|
|
push @tlist, \%titem;
|
|
|
|
delete $gblvars{ms};
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub tpr {
|
|
my ($txt) = @_;
|
|
print $txt;
|
|
print $fh_tee $txt if defined $fh_tee;
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub tpre {
|
|
my ($txt) = @_;
|
|
print STDERR $txt;
|
|
print $fh_tee $txt if defined $fh_tee;
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub max {
|
|
my ($a,$b) = @_;
|
|
return ($a > $b) ? $a : $b;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub open_job_fh {
|
|
my ($cmd) = @_;
|
|
my $fh = new FileHandle;
|
|
|
|
# add STDERR->STDOUT redirect (create sub shell of needed)
|
|
$cmd = '(' . $cmd . ')' if $cmd =~ m/\n/g;
|
|
$cmd .= ' 2>&1';
|
|
|
|
# open returns pid of created process in case an in or out pipe is created
|
|
my $pid = open $fh, '-|', $cmd;
|
|
# print "+++1 $pid\n";
|
|
|
|
if (not $pid) {
|
|
my $err = $!;
|
|
my $msg = sprintf "tbrun-E: failed to start '%s'\n cwd: %s\n error: %s\n",
|
|
$cmd, getcwd(), $err;
|
|
return (undef, undef, $msg);
|
|
}
|
|
return ($fh, $pid, undef);
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub run_tests_single {
|
|
my $drycd = '';
|
|
foreach my $titem (@tlist) {
|
|
my $cdir = $titem->{cd};
|
|
my $test = $titem->{test};
|
|
|
|
chdir $inicwd or bailout("chdir to '$inicwd' failed with '$!'");
|
|
|
|
if ($opts{dry}) {
|
|
if ($cdir ne $drycd) {
|
|
tpr("#------------------------------------------------------------\n");
|
|
tpr("cd $cdir\n");
|
|
$drycd = $cdir;
|
|
}
|
|
tpr("#----------------------------------------\n");
|
|
tpr("# $titem->{tmsg}\n");
|
|
tpr("$test\n");
|
|
|
|
} else {
|
|
tpr("#----------------------------------------\n");
|
|
tpr("# $titem->{tmsg}\n");
|
|
$ndone += 1;
|
|
my $cmd = '';
|
|
$cmd .= "cd $cdir";
|
|
$cmd .= "\n";
|
|
$cmd .= "$test";
|
|
|
|
my ($fh,$pid,$msg) = open_job_fh($cmd);
|
|
if (not defined $fh) {
|
|
tpre($msg);
|
|
} else {
|
|
while (<$fh>) {
|
|
print $_;
|
|
}
|
|
if (not close $fh) {
|
|
my $err = $?;
|
|
tpr(sprintf "tbrun-I: test FAILed with exit status %d,%d\n",
|
|
($err>>8), ($err&0xff));
|
|
$nfail += 1;
|
|
}
|
|
}
|
|
}
|
|
}
|
|
|
|
if ($opts{dry}) {
|
|
tpr("#------------------------------------------------------------\n");
|
|
tpr(sprintf "cd %s\n", $inicwd);
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub print_ticker {
|
|
return unless $ticker_on;
|
|
|
|
my ($rwlist) = @_;
|
|
my $msg = '';
|
|
state $lastlength = 0;
|
|
|
|
if (defined $rwlist) {
|
|
my $time_now = gettimeofday();
|
|
$msg = '#-I: ' . join '; ', map {
|
|
sprintf('t%03d: %dl %3.1fs',
|
|
$_->{id}, $_->{nlines}, $time_now-$_->{tstart})
|
|
} @$rwlist;
|
|
$msg = substr($msg,0,75) . ' ...' if length($msg) >79;
|
|
unless (defined $opts{trace}) {
|
|
my $suff = sprintf '(%dt,%dw,%do)',
|
|
scalar(@tlist), scalar(@wlist), scalar(@olist);
|
|
if (length($suff) + length($msg) + 1 <= 79) {
|
|
$msg .= ' ' . $suff;
|
|
} else {
|
|
$msg = substr($msg,0,79-6-length($suff)) . ' ... ' . $suff;
|
|
}
|
|
}
|
|
}
|
|
my $newlength = length($msg);
|
|
$msg .= ' ' x ($lastlength - $newlength) if $lastlength > $newlength;
|
|
print $msg . "\r";
|
|
$lastlength = $newlength;
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub print_jobs {
|
|
while (defined $olist[0]->{exitcode}) {
|
|
print_ticker();
|
|
my $titem = shift @olist;
|
|
tpr("#----------------------------------------\n");
|
|
tpr("# $titem->{tmsg}\n");
|
|
tpr($titem->{out});
|
|
}
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub print_trace {
|
|
my ($titem) = @_;
|
|
my $pref = '';
|
|
my $suff = sprintf '(%dt,%dw,%do)',
|
|
scalar(@tlist), scalar(@wlist), scalar(@olist);
|
|
if (defined $titem->{exitcode}) {
|
|
$pref = ($titem->{exitcode}==0) ? 'pass ' : 'FAIL ';
|
|
} else {
|
|
$pref = 'start';
|
|
}
|
|
my $txt = '#-I: ' . $pref . ' ' . $titem->{tmsg};
|
|
$txt .= ' ' . $suff;
|
|
$txt .= "\n";
|
|
print_ticker();
|
|
tpr($txt);
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub start_jobs {
|
|
|
|
# initialize lock hash
|
|
my %locks;
|
|
foreach my $titem (@wlist) {
|
|
foreach my $lock (@{$titem->{locks}}) {
|
|
$locks{$lock} = 1;
|
|
}
|
|
}
|
|
|
|
# look for suitable tasks
|
|
for (my $i=0; $i < scalar(@tlist) && scalar(@wlist) < $opts{jobs}; ) {
|
|
my $titem = $tlist[$i];
|
|
my $nlock = 0;
|
|
foreach my $lock (@{$titem->{locks}}) {
|
|
if ($locks{$lock}) {
|
|
$nlock += 1;
|
|
last;
|
|
}
|
|
}
|
|
|
|
# suitable task found
|
|
if ($nlock == 0) {
|
|
my $cdir = $titem->{cd};
|
|
my $test = $titem->{test};
|
|
$ndone += 1;
|
|
|
|
my $cmd = '';
|
|
if ($opts{dry}) {
|
|
$cmd .= "cd $cdir";
|
|
$cmd .= "\n";
|
|
$cmd .= "perl -e 'select(undef, undef, undef, 0.2+1.6*rand( 1.))'";
|
|
$cmd .= "\n";
|
|
$cmd .= "echo \"cd $cdir\"";
|
|
$cmd .= "\n";
|
|
$cmd .= "echo \"$test\"";
|
|
} else {
|
|
$cmd .= "cd $cdir";
|
|
$cmd .= "\n";
|
|
$cmd .= "$test";
|
|
}
|
|
|
|
# start job
|
|
my ($fh,$pid,$msg) = open_job_fh($cmd);
|
|
if (not defined $fh) {
|
|
$titem->{out} = $msg;
|
|
$titem->{exitcode} = 1;
|
|
print_trace($titem) if $opts{trace};
|
|
print_jobs();
|
|
} else {
|
|
$titem->{fh} = $fh;
|
|
$titem->{fd} = fileno($fh);
|
|
$titem->{pid} = $pid;
|
|
$titem->{out} = '';
|
|
$titem->{tstart} = gettimeofday();
|
|
$titem->{nlines} = 0;
|
|
push @wlist, $titem;
|
|
foreach my $lock (@{$titem->{locks}}) {
|
|
$locks{$lock} = 1;
|
|
}
|
|
print_trace($titem) if $opts{trace};
|
|
}
|
|
splice @tlist, $i, 1; # remove from tlist
|
|
next; # and re-test i'th list element
|
|
} # if ($nlock == 0)
|
|
|
|
$i += 1; # inspect nexyt list element
|
|
} # for (my $i=0; ...
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub kill_job {
|
|
my ($titem, $trun) = @_;
|
|
my $pid = $titem->{pid};
|
|
my $pgid = getpgrp(0);
|
|
my %phash;
|
|
|
|
$titem->{killed} = $trun;
|
|
|
|
# get process tree data (for whole user, no pgid filtering possible
|
|
my $rank = 0;
|
|
open PS,"ps -H -o pid,ppid,pgid,comm --user $ENV{USER}|";
|
|
while (<PS>) {
|
|
chomp;
|
|
next unless m/^\s*(\d+)\s+(\d+)\s+(\d+)\s(.*)$/;
|
|
my $cpid = $1;
|
|
my $cppid = $2;
|
|
my $cpgid = $3;
|
|
my $cargs = $4;
|
|
next unless $cpgid == $pgid; # only current process group
|
|
next if $cargs =~ m/^\s*ps\s*$/; # skip the 'ps' process itself
|
|
$phash{$cpid}->{ppid} = $cppid;
|
|
$phash{$cpid}->{pgid} = $cpgid;
|
|
$phash{$cpid}->{args} = $cargs;
|
|
$phash{$cpid}->{rank} = $rank++;
|
|
push @{$phash{$cppid}->{childs}}, $cpid;
|
|
}
|
|
close PS;
|
|
|
|
# sanity check 1: own tbrun process should be included
|
|
unless (exists $phash{$$}) {
|
|
print_ticker();
|
|
printf "-E: tmax kill logic error: tbrun master pid not in phash\n";
|
|
return;
|
|
}
|
|
# sanity check 2: job to be killed should be child of master tbrun
|
|
unless ($phash{$pid}->{ppid} == $$) {
|
|
print_ticker();
|
|
printf "-E: tmax kill logic error: job not child of tbrun\n";
|
|
return;
|
|
}
|
|
|
|
# determine number of leading blanks in master tbrun line
|
|
my $nstrip = 0;
|
|
$nstrip = length($1) if ($phash{$$}->{args} =~ m/^(\s*)/);
|
|
|
|
# recursively mark all childs of job master
|
|
my @pids = ($pid);
|
|
while (scalar(@pids)) {
|
|
my $cpid = shift @pids;
|
|
if (not exists $phash{$cpid}) {
|
|
print_ticker();
|
|
printf "-E: tmax kill logic error: child pid not in phash\n";
|
|
return;
|
|
}
|
|
$phash{$cpid}->{kill} = 1;
|
|
if (exists $phash{$cpid}->{childs}) {
|
|
push @pids, @{$phash{$cpid}->{childs}};
|
|
}
|
|
}
|
|
|
|
# build list of pid to be killed, and trace message
|
|
my @kpids;
|
|
my @ktext;
|
|
foreach my $cpid (sort {$phash{$a}->{rank} <=> $phash{$b}->{rank} }
|
|
grep {$phash{$_}->{kill}}
|
|
keys %phash) {
|
|
push @kpids, $cpid;
|
|
push @ktext, sprintf "# %6d %6d %6d %s",
|
|
$cpid, $phash{$cpid}->{ppid},
|
|
$phash{$cpid}->{pgid},
|
|
substr($phash{$cpid}->{args}, $nstrip);
|
|
}
|
|
|
|
# print trace message, if selected
|
|
if ($opts{trace}) {
|
|
print_ticker();
|
|
printf "#-I: kill t%03d after %3.1fs, kill proccesses:\n",
|
|
$titem->{id}, $trun, join("\n");
|
|
print "# pid ppid pgid command\n";
|
|
print join("\n",@ktext) . "\n";
|
|
}
|
|
|
|
# and finally kill all processes of the job
|
|
kill 'TERM', @kpids;
|
|
|
|
return;
|
|
}
|
|
|
|
#-------------------------------------------------------------------------------
|
|
sub run_tests_multi {
|
|
@olist = @tlist;
|
|
|
|
while (scalar(@tlist) || scalar(@wlist)) { # while something to do
|
|
# start new jobs, if available and job slots free
|
|
start_jobs();
|
|
|
|
my @fhlist = map { $_->{fh} } @wlist;
|
|
my %fdhash;
|
|
foreach my $titem (@wlist) {
|
|
$fdhash{$titem->{fd}} = $titem;
|
|
}
|
|
|
|
my $sel = IO::Select->new(@fhlist);
|
|
my $neof = 0;
|
|
my $time_ticker = gettimeofday() + 0.1;
|
|
|
|
while ($neof == 0) {
|
|
my $wait_ticker = max(0.1, $time_ticker - gettimeofday() + 0.1);
|
|
my @fhlist = $sel->can_read($wait_ticker);
|
|
my $time_now = gettimeofday();
|
|
if ($time_now >= $time_ticker) {
|
|
print_ticker(\@wlist);
|
|
$time_ticker = $time_now + 0.9;
|
|
}
|
|
foreach my $fh (@fhlist) {
|
|
my $fd = fileno($fh);
|
|
my $titem = $fdhash{$fd};
|
|
my $buf = '';
|
|
my $nb = sysread $fh, $buf, 1024;
|
|
|
|
# data read
|
|
if ($nb) {
|
|
$titem->{out} .= $buf;
|
|
$titem->{nlines} += ($buf =~ tr/\n/\n/); # count \n in $buf
|
|
|
|
# eof or error
|
|
} else {
|
|
if (defined $titem->{killed}) {
|
|
$titem->{out} .= sprintf
|
|
"tbrun-I: test killed after %3.1fs\n", $titem->{killed};
|
|
}
|
|
if (not close $fh) {
|
|
my $err = $?;
|
|
$titem->{out} .= sprintf
|
|
"tbrun-I: test FAILed with exit status %d,%d\n",
|
|
($err>>8), ($err&0xff);
|
|
$nfail += 1;
|
|
$titem->{exitcode} = $err;
|
|
} else {
|
|
$titem->{exitcode} = 0;
|
|
}
|
|
|
|
$neof += 1;
|
|
for (my $i=0; $i < scalar(@wlist); $i++) {
|
|
next unless $wlist[$i]->{fd} == $fd;
|
|
splice @wlist, $i, 1;
|
|
last;
|
|
}
|
|
print_trace($titem) if $opts{trace};
|
|
}
|
|
} # foreach my $fh ...
|
|
|
|
# handle tmax
|
|
if (defined $opts{tmax}) {
|
|
foreach my $titem (@wlist) {
|
|
my $trun = $time_now - $titem->{tstart};
|
|
if ($trun > $opts{tmax}) {
|
|
kill_job($titem, $trun) unless defined $titem->{killed};
|
|
}
|
|
}
|
|
}
|
|
|
|
} # while ($neof == 0)
|
|
# here if at least one job finished
|
|
print_jobs();
|
|
}
|
|
|
|
return;
|
|
}
|
|
|
|
# ----------------------------------------------------------------------------
|
|
sub bailout {
|
|
my ($msg) = @_;
|
|
print STDERR "tbrun-F: $msg\n";
|
|
exit 1;
|
|
}
|
|
|
|
# ----------------------------------------------------------------------------
|
|
sub print_usage {
|
|
print "usage: tbrun [options] [dcsfile]\n";
|
|
print " --tag=<tlist> list of tags to run (def='default')\n";
|
|
print " --exclude=<tlist> tag combinations to exclude\n";
|
|
print " --mode=<mlist> list of modes to run\n";
|
|
print " --jobs=<njob> number of parallel jobs (def=1)\n";
|
|
print " --tee=<ofile> addition logfile for al stdout output\n";
|
|
print " --dry dry run, prints only the generated commands\n";
|
|
print " --trace prints additional information on job control\n";
|
|
print " --nomake don't execute make step of test bench\n";
|
|
print " --norun don't execute run step of test bench\n";
|
|
print " --rlmon enable the rlink monitor\n";
|
|
print " --rbmon enable the rbus monitor\n";
|
|
print " --bwait=<dt> startup wait for behavioral simulations (in ns)\n";
|
|
print " --swait=<dt> startup wait for post-* simulations (in ns)\n";
|
|
print " --help print short help text\n";
|
|
print "\n";
|
|
print " If no [dcsfile] is specified 'tbrun.yml' is used\n";
|
|
return;
|
|
}
|