Wojciech Jaworski / ENIAM

#! /usr/bin/perl
#
use strict;
use vars qw(@files %processes %prevstats $swigradir $parser);
use constant VMEM_LIMIT => 20000*1000*1000;
use constant CONCURRENCY_LEVEL => 20;
use constant DELAY => 2;
use POSIX ":sys_wait_h";

# pakiet Ubuntu: libbsd-resource-perl
use BSD::Resource;

%processes = (); # Will map PIDs to [‹świgra file›, ‹utime›, ‹stime›, ‹inactivity counter›, ‹vmem›]

%prevstats = ();
# open STAT, "<", "../parsestats.tab";
# while (<STAT>) {
# }
# close STAT;

open STAT, ">", "../parsestats.tab";

# SWI Prolog on Linux has the bad habit of hanging in a system call
# when memory gets exhausted.  For that reason we have to implement a
# framework for killing processes that get inactive but do not die.

# pakiet Ubuntu: libfile-slurp-perl
use File::Slurp;
# This function is Linux-specific.
# We assume this test will be performed each second.
sub is_alive {
    my $pid = shift;
    my @stat = split ' ', read_file("/proc/$pid/stat");
# Pola w tym pliku są opisane w man proc
# [2] state
# [13] cpu time in user mode
# [14] cpu time kernel mode
# [22] virtual memory size
    my $active = $stat[2] eq 'R' # process status
	|| $stat[13] > $processes{$pid}->[1]  # utime
	|| $stat[14] > $processes{$pid}->[2]; # stime
    if ($active) {
	$processes{$pid}->[3] = 0;
	$processes{$pid}->[1] = $stat[13]; # remember current utime
	$processes{$pid}->[2] = $stat[14]; # remember current stime
	$processes{$pid}->[4] = $stat[22] # remember max vmem
	    if $processes{$pid}->[4] < $stat[22];
    } else {
	$processes{$pid}->[3] ++;
    }
    print STDERR join ' ', "Process $pid is", ($active?'':'not'), 'active. ', 'IC:', $processes{$pid}->[3],
    'stat:', @stat[2,13..14,22], "\n";
    return $processes{$pid}->[3] < 10; # after 10 seconds of inactivity we consider a process really dead
}


die unless @ARGV == 1;

$swigradir = "$ENV{HOME}/swigra/parser";
$parser = 'gfjp2-bin';

@files = glob(shift);

print STDERR "There are ".scalar(@files)." files to process.\n";


while (@files >0) {

    for my $kid (keys %processes) {
	if (!is_alive($kid)) {
	    print STDERR "Killing $kid!\n";
	    kill('TERM', $kid);
	}
    }

    my $kid = waitpid(-1, WNOHANG);
    while ($kid >0)  {
	if (defined $processes{$kid}) {
	    print STDERR "Process $kid for $processes{$kid}->[0] has finished, ${\(scalar(keys %processes)-1)} running.\n";
	    print STAT "$processes{$kid}->[0]\t$processes{$kid}->[1]\t$processes{$kid}->[2]\t$processes{$kid}->[4]\n";
	    delete $processes{$kid};
#	    spawn_child(shift @files);
	} else {
	    print STDERR "STRANGE: we haven't been waiting for process $kid.\n";
	}
	$kid = waitpid(-1, WNOHANG);
    }

    spawn_child(shift @files)
	while (keys %processes < CONCURRENCY_LEVEL && @files > 0);

    sleep DELAY;
}

# wait for remaining children
while (keys %processes > 0) {
    for my $kid (keys %processes) {
	if (!is_alive($kid)) {
	    print STDERR "Killing $kid!\n";
	    kill('TERM', $kid);
	}
    }

    my $kid = waitpid(-1, WNOHANG);
    while ($kid >0)  {
	if (defined $processes{$kid}) {
	    print STDERR "Process $kid for $processes{$kid}->[0] has finished, ${\(scalar(keys %processes)-1)} running.\n";
	    delete $processes{$kid};
#	    spawn_child(shift @files);
	} else {
	    print STDERR "STRANGE: we haven't been waiting for process $kid.\n";
	}
	$kid = waitpid(-1, WNOHANG);
    }

    sleep DELAY;
}

# close STAT;

########################################################################

sub run_swigra { # to be executed in a child process!
    my $doa = shift;
    my $forest = $doa;
    $forest =~ s/.doa$/.forest/;
    # ulimit -n 8*60:
    # “Processes have soft and hard resource limits.  On crossing the
    # soft limit they receive a signal (for example the "SIGXCPU" or
    # "SIGXFSZ", corresponding to the "RLIMIT_CPU" and "RLIMIT_FSIZE",
    # respectively).  The processes can trap and handle some of these
    # signals, please see "Signals" in perlipc.  After the hard limit
    # the processes will be ruthlessly killed by the "KILL" signal
    # which cannot be caught.

    # We set the soft limit (setting the hard limit results in “invalid argument” error!):
    setrlimit(RLIMIT_CPU,60*60,RLIM_INFINITY) || die "setrlimit failed for cputime: $!";
# było 20G, ale trochę szkodziło serwerowi
    setrlimit(RLIMIT_VMEM,VMEM_LIMIT,RLIM_INFINITY) || die "setrlimit failed for vmem: $!";
    # nice -n 19
    setpriority(PRIO_PROCESS,0, 19) || die "setpriority failed: $!";

    open STDOUT, '>', $forest or die "Can't redirect STDOUT: $!";
    exec 'swipl', '-x', "$swigradir/$parser",'-t','halt', '-g',"['$doa']";

    }

sub spawn_child {
    my $file = shift;
    my $forest = $file;
    $forest =~ s/.doa$/.forest/;
    if ( -s $forest ) { # file exists and has nonzero size
	print STDERR "--- $forest already present.\n";
	return;
    }
    if (!defined(my $kidpid = fork())) {
	# fork returned undef, so failed
	die "cannot fork for $file:\n $!";
    } elsif ($kidpid == 0) {
	# fork returned 0, so this branch is the child
	run_swigra($file);
	# if the exec fails, fall through to the next statement
	die "can't exec Swigra: $!";
    } else { 
	# fork returned neither 0 nor undef, 
	# so this branch is the parent
	print STDERR "Started process $kidpid for $file.\n";
	$processes{$kidpid} = [$file,0,0,0];
    }
}

# # from http://www.perlmonks.org/?node_id=254756:
## failed with EPERM!
# sub set_max_cpu_time
#   {
#     my $n_seconds = shift;
#     my $s = pack( 'LL', $n_seconds, $n_seconds+1 );
#     $! = 0;
#     if ( syscall( 128, 0, $s ) == -1 )  # SYS_setrlimit, RLIMIT_CPU
#     {
#       if ( $! == 1 )  # EPERM
#       {
#         die "$!; Sorry, you need to be superuser to do that.\n";
#       }
#       elsif ( $! == 14 )  # EFAULT
#       {
#         die "$!; Error: argument to setrlimit pointed to an illegal ad
# +dress.\n";
#       }
#       elsif ( $! == 22 )  # EINVAL
#       {
#         die "$!; Error: the new rlim_cur exceeds the new rlim_max,
#           or the limit specified cannot be lowered because current usa
# +ge
#           is already higher than the limit.\n";
#       }
#     }
#   }


# non-blocking test for running children:
# use POSIX ":sys_wait_h";
# #...
# do {
#     $kid = waitpid(-1, WNOHANG);
# } while $kid > 0;

# redyrekcje:
#open(STDERR,">&STDOUT")