test_random.pl

#!/usr/bin/env perl
$|=1;
use strict;
use IO::Select;
use rob_misc;
use robqueue;
use threads;
use threads::shared;
use 5.16.0;
use Term::ReadKey;
use Term::ANSIScreen qw(cls :cursor);
use Text::ANSITable;
binmode(STDOUT, ":utf8");
use Term::ANSIColor;

#
# Script to run binary_c across many CPUs
# perhaps through valgrind. Can be set to exit on error.
# NB to do this it must run each system individually,
# which is a little slow.
#


my ($wchar, $hchar, $wpixels, $hpixels) = GetTerminalSize();
my $args = "@ARGV";
check_ps() unless($args=~/skip_valgrind_check/);
$SIG{INT} = \&reaper;
my $valgrind = ($args=~/valgrind/) ? 'valgrind' : ''; # valgrind or ''
my $nice = ($args=~/nice=(\d+)/) ? "nice -n +$1" : 'nice';
my $timeout = ($args=~/timeout=(\d+)/) ? "timeout -s 9 $1" : '';
my $repeat = ($args=~/repeat=(\d+)/)[0] // 1;
my $logtimes = ($args=~/logtimes/) ? 1 : 0;
my $ignore_time = ($args=~/ignore_time=(\S+)/)[0] // 2.0; # do not log time if < this
my $exit_on_error = ($args=~/exit_on_error/) // 0;
my $newlogs = ($args=~/newlogs/) ? 1 : 0;
my $opener = $newlogs ? '>' : '>>';
open(my $log,$opener,"$ENV{HOME}/binary_c_test_random.log")||die;
open(my $logtimes_file,$opener,"$ENV{HOME}/binary_c_test_random.logtimes")||die;
my $locklog :shared;
$log->autoflush(1);
my @screenlog : shared;
my $settle = ($args=~/(settle)/)[0] // 10; # wait this many seconds before output
my $sleeptime = ($args=~/sleeptime=(\S+)/)[0] // 0.25; # number of s to wait between checking for binary_c output 
my $twarn = ($args=~/twarn=(\S+)/)[0] // 180.0; # warn if no output for this time
my $warn_every = ($args=~/warn_every=(\S+)/)[0] // 10.0; # warn every this many seconds
my $n_binary_c_threads = ($args=~/threads=cpu/i) ? (rob_misc::ncpus()-1) : ($args=~/threads=(\d+)/)[0] // 1;
my $nstore = ($args=~/nstore=(\d+)/)[0] // 1000;# store this many lines of output

print "Options : 
valgrind $valgrind
nice : $nice
timeout : $timeout
repeat : $repeat 
logtimes : $logtimes
ignore_time : $ignore_time
settle : $settle
sleeptime : $sleeptime
twarn : $twarn
warn_every : $warn_every
n_binary_c_threads : $n_binary_c_threads
nstore : $nstore

Files: log = $log, logtimes_file = $logtimes_file
    \n";

my $q = robqueue->new(
    nthreads=>$n_binary_c_threads+1,
    subr=>\&runsystem,
    prepend_thread_number_to_subroutine=>1
    );
my $tsincewarn = 0;



while(1)
{
    $q->q(1);
    $q->qwait();
}
$q->end();

sub runsystem
{
    my $n = shift;
    if($n==0)
    {
        # first thread 
        while(1)
        {
            sleep 1;
            outscreenlog();
        }
    }
    else
    {
        my $s = IO::Select->new();
        my $cmd = "stdbuf -i 0 -e 0 -o 0 $nice $timeout tbse $valgrind --repeat $repeat --random_systems 1 --log_filename /tmp/c_log-$n.dat  2>\&1 ";
        my $args;
        my $logfile = "/tmp/binary_c_test_random_log.$n";
        open(my $outlog,'>',$logfile)||confess("cannot open $logfile for output");
        autoflush $outlog;
        open(my $f,$cmd.' |')||confess('cannot run '.$cmd);
        $s->add($f);
        autoflush $f 1;
        my @r;
        my $tsince = 0;
        my $tsincewarn = $warn_every;
        while(defined $f && $f)
        {
            my @can = $s->can_read(0.25);
            if(scalar @can)
            {
                my $l = <$f>;
                if(!defined $l)
                {
                    # EOF : command has finished 
                    close $f;
                    $f = undef;
                }
                else
                {
                    # line of data : process
                    print {$outlog} $l;
                    
                    push(@r,$l);

                    # if we've exceeded the number of saved lines, remove the top one
                    if(scalar @r > $nstore)
                    {
                        shift @r;
                    }
                    
                    if($l=~/(--M_1.*)/g)
                    {
                        $args = $1;
                        setlog($n,$tsince,"$args\n");
                    }
                    elsif($l=~/runtime\s+=\s+(\S+)/)
                    {
                        my $runtime = $1;
                        if($runtime > $ignore_time)
                        {
                            state $logtimes_lock : shared;
                            printf {$logtimes_file} "%s %s\n",
                                $runtime, 
                                $args;
                        }
                    }
                }
                $tsince = 0;
            }
            else
            {
                $tsince += $sleeptime;
                
                if($tsince >= $twarn)
                {
                    if($tsincewarn >= $warn_every )
                    {
                        $tsincewarn = 0;
                        setlog($n,$tsince,"Warning : thread $n has had no output for $tsince seconds\n");
                    }
                    else
                    {
                        $tsincewarn += $sleeptime;        
                    }
                }
            }
        }
        close $f if(defined $f);
        my $status = $?;
        setlog($n, 0, "thread $n finished with status $status\n");

        my $r = join("\n",@r);
        if($status!=0 ||
           $r =~ /Exit\ binary/ ||
           $r =~ /action on error/ ||
           $r =~ /jump or move depends on uninit/ ||
           $r =~ /definitely lost/)
        {
            my $file = '/tmp/test_random_error'.$n.'.out';
            print "Error on thread $n (see $file)\n\n$args\n\n";
            dumpfile($file,$r);
            print {$log} "\n# Error on thread $n :\n# $args\n\n";
         
            if($exit_on_error)
            {
                exit(0);
            }
        }
    }
}

sub memuse
{
    state $prev :shared;
    state $first;
    $prev//=0;
    my $t = time();
    $first//=$t+$settle;
    my $mem;
    if($t > $first)
    {
        $mem = mem_usage(1,$$,1);
        if($mem!=$prev)
        {
            printf "MEM %s MB\n",$mem;
        }
        if(!defined $prev || $mem>$prev)
        {
            lock $locklog;
            printf {$log} "%s %s\n",time(),$mem;
            $prev = $mem;
        }
    }
    return $mem;
}

sub reaper
{
    # kill all threads, clean up
    print "Caught CTRL-C : ending\n";
    map
    {
        $_->exit();
    }threads->list(threads::running);
    `killall -9 memcheck-amd64-`;
    exit;
};

sub setlog
{
    # set log grid string
    state $setlog_lock : shared;
    lock $setlog_lock; 
    my ($n, $tsince, $s) = @_;
    chomp $s;
    $screenlog[$n] = shared_clone([$tsince,$s]);
}

sub outscreenlog
{
    # output log grid to screen
    state $setlog_lock : shared;
    lock $setlog_lock; 
    my $h = 'test_random.pl '.$args.' : '.sprintf("%s",memuse()//'unknown');
    my $t = Text::ANSITable->new;
    $t->border_style('Default::bold');  # if not, a nice default is picked
    $t->columns(["Thread","Tsince","Status"]);
    $t->set_column_style('Status',wrap=>0);
    for(my $i=1;$i<=$#screenlog;$i++)
    {
        $t->add_row([$i,$screenlog[$i]->[0],substr($screenlog[$i]->[1],0,$wchar-30)]);
    }
    print cls(),locate(0,0),$h,"\n",$t->draw();
}

sub check_ps
{
    my $r = `ps aux|grep valgrind`;
    if($r=~m!/usr/bin/valgrind.bin!)
    {
        print "Valgrind is already running : please stop it first!\n";
        #print $r;
        exit;
    }
}