mirror of https://github.com/pragma-/pbot.git
compiler_vm updates
- make compiler_output_merger.pl more resistant to being killed
- support gcc 4.9.0's -fdiagnostics-show-caret
(disable in channel, enable in paste)
- force a newline to be added to program output to prevent output
from being buffered by output merger
This commit is contained in:
Pragmatic Software
parent
aa00540c8d
commit
7a99175bd7
|
|
@ -13,8 +13,8 @@ use warnings;
|
|||
# These are set automatically by the build/commit script
|
||||
use constant {
|
||||
BUILD_NAME => "PBot",
|
||||
BUILD_REVISION => 489,
|
||||
BUILD_DATE => "2014-02-25",
|
||||
BUILD_REVISION => 490,
|
||||
BUILD_DATE => "2014-02-27",
|
||||
};
|
||||
|
||||
1;
|
||||
|
|
|
|||
|
|
@ -5,6 +5,8 @@ use strict;
|
|||
|
||||
use IPC::Open2;
|
||||
use Fcntl qw/:flock/;
|
||||
use POSIX ":sys_wait_h";
|
||||
use Linux::Pid qw/getppid/;
|
||||
|
||||
my $outfile = '.output';
|
||||
|
||||
|
|
@ -20,31 +22,72 @@ sub write_output {
|
|||
close $fh;
|
||||
}
|
||||
|
||||
sub merge {
|
||||
my ($file) = @_;
|
||||
sub merge_file {
|
||||
my ($file, $pid) = @_;
|
||||
|
||||
# create empty file
|
||||
open my $fh, '>', $file;
|
||||
close $fh;
|
||||
|
||||
my ($out, $in);
|
||||
open2 $out, $in, "tail -f $file";
|
||||
open2 $out, $in, "tail -q -F $file --pid=$pid";
|
||||
print "merging $file to $outfile\n";
|
||||
while(my $line = <$out>) {
|
||||
chomp $line;
|
||||
if(getppid == 1) {
|
||||
print "$file: Parent died, exiting\n";
|
||||
exit;
|
||||
}
|
||||
print "$file: got [$line]\n";
|
||||
write_output $line;
|
||||
}
|
||||
}
|
||||
|
||||
my $pid = fork();
|
||||
die "fork failed: $!" if not defined $pid;
|
||||
sub merge {
|
||||
my ($file) = @_;
|
||||
|
||||
if($pid == 0) {
|
||||
merge '.gdb_output';
|
||||
exit;
|
||||
} else {
|
||||
merge '.prog_output';
|
||||
my $pid = fork;
|
||||
die "fork failed: $!" if not defined $pid;
|
||||
|
||||
if($pid == 0) {
|
||||
print "$file pid: $$\n";
|
||||
while(1) {
|
||||
merge_file $file, $$;
|
||||
print "merge $file killed, restarting...\n";
|
||||
}
|
||||
exit;
|
||||
} else {
|
||||
return $pid;
|
||||
}
|
||||
}
|
||||
|
||||
waitpid $pid, 0;
|
||||
my ($gdb_pid, $prog_pid);
|
||||
|
||||
sub merge_outputs {
|
||||
$gdb_pid = merge '.gdb_output';
|
||||
$prog_pid = merge '.prog_output';
|
||||
|
||||
print "merge_outputs: gdb_pid: $gdb_pid; prog_pid: $prog_pid\n";
|
||||
|
||||
while(1) {
|
||||
sleep 1;
|
||||
}
|
||||
}
|
||||
|
||||
$SIG{CHLD} = \&REAPER;
|
||||
sub REAPER {
|
||||
my $stiff;
|
||||
while (($stiff = waitpid(-1, &WNOHANG)) > 0) {
|
||||
print "child died: $stiff\n";
|
||||
print "reaper: gdb_pid: $gdb_pid; prog_pid: $prog_pid\n";
|
||||
|
||||
if($stiff == $gdb_pid) {
|
||||
$gdb_pid = merge '.gdb_output';
|
||||
} elsif($stiff == $prog_pid) {
|
||||
$prog_pid = merge '.prog_output';
|
||||
}
|
||||
}
|
||||
$SIG{CHLD} = \&REAPER;
|
||||
}
|
||||
|
||||
merge_outputs;
|
||||
|
|
|
|||
|
|
@ -13,7 +13,7 @@ my $SERIAL_PORT = 3333;
|
|||
my $HEARTBEAT_PORT = 3336;
|
||||
|
||||
my $COMPILE_TIMEOUT = 7;
|
||||
my $NOGRAPHIC = 0;
|
||||
my $NOGRAPHIC = 1;
|
||||
|
||||
sub server_listen {
|
||||
my $port = shift @_;
|
||||
|
|
@ -46,7 +46,7 @@ sub vm_start {
|
|||
}
|
||||
|
||||
if($pid == 0) {
|
||||
my $command = "nice -n -20 qemu-system-x86_64 -M pc -net none -hda /home/compiler/compiler/compiler-savedvm.qcow2 -m 128 -monitor tcp:127.0.0.1:$MONITOR_PORT,server,nowait -serial tcp:127.0.0.1:$SERIAL_PORT,server,nowait -serial tcp:127.0.0.1:$HEARTBEAT_PORT,server -boot c -loadvm 1 -enable-kvm -no-kvm-irqchip" . ($NOGRAPHIC ? "" : " -nographic");
|
||||
my $command = "nice -n -20 qemu-system-x86_64 -M pc -net none -hda /home/compiler/compiler/compiler-savedvm.qcow2 -m 128 -monitor tcp:127.0.0.1:$MONITOR_PORT,server,nowait -serial tcp:127.0.0.1:$SERIAL_PORT,server,nowait -serial tcp:127.0.0.1:$HEARTBEAT_PORT,server -boot c -loadvm 1 -enable-kvm -no-kvm-irqchip" . ($NOGRAPHIC ? " -nographic" : "");
|
||||
my @command_list = split / /, $command;
|
||||
exec(@command_list);
|
||||
} else {
|
||||
|
|
|
|||
|
|
@ -911,7 +911,7 @@ $code =~ s/(?:\n\n)+/\n\n/g;
|
|||
|
||||
print "final code: [$code]\n" if $debug;
|
||||
|
||||
$input = `fortune -u` if not length $input;
|
||||
$input = `fortune -u -s` if not length $input;
|
||||
$input =~ s/[\n\r\t]/ /msg;
|
||||
$input =~ s/:/ - /g;
|
||||
$input =~ s/\s+/ /g;
|
||||
|
|
@ -920,7 +920,9 @@ print FILE "$nick: [lang:$lang][args:$args][input:$input]\n", pretty($code), "\n
|
|||
|
||||
my $pretty_code = pretty $code;
|
||||
|
||||
$args .= ' -paste' if defined $got_paste or $got_run eq "paste";
|
||||
$output = compile($lang, $pretty_code, $args, $input, $USE_LOCAL);
|
||||
$args =~ s/ -paste$// if defined $got_paste or $got_run eq "paste";
|
||||
|
||||
if($output =~ m/^\s*$/) {
|
||||
$output = $nooutput
|
||||
|
|
|
|||
|
|
@ -3,6 +3,8 @@
|
|||
use warnings;
|
||||
use strict;
|
||||
|
||||
use Proc::ProcessTable;
|
||||
|
||||
my $USE_LOCAL = defined $ENV{'CC_LOCAL'};
|
||||
|
||||
my %languages = (
|
||||
|
|
@ -28,6 +30,8 @@ my %languages = (
|
|||
},
|
||||
);
|
||||
|
||||
my $merger_pid;
|
||||
|
||||
sub runserver {
|
||||
my ($input, $output, $heartbeat);
|
||||
|
||||
|
|
@ -128,13 +132,20 @@ sub interpret {
|
|||
|
||||
my $cmdline = $languages{$lang}{'cmdline'};
|
||||
|
||||
my $diagnostics_caret;
|
||||
if($user_args =~ s/\s+-paste//) {
|
||||
$diagnostics_caret = '-fdiagnostics-show-caret';
|
||||
} else {
|
||||
$diagnostics_caret = '-fno-diagnostics-show-caret';
|
||||
}
|
||||
|
||||
if(length $user_args) {
|
||||
print "Replacing args with $user_args\n";
|
||||
my $user_args_quoted = quotemeta($user_args);
|
||||
$user_args_quoted =~ s/\\ / /g;
|
||||
$cmdline =~ s/\$args/$user_args_quoted/;
|
||||
$cmdline =~ s/\$args/$user_args_quoted $diagnostics_caret/;
|
||||
} else {
|
||||
$cmdline =~ s/\$args/$languages{$lang}{'args'}/;
|
||||
$cmdline =~ s/\$args/$languages{$lang}{'args'} $diagnostics_caret/;
|
||||
}
|
||||
|
||||
$cmdline =~ s/\$file/$languages{$lang}{'file'}/;
|
||||
|
|
@ -164,7 +175,19 @@ sub interpret {
|
|||
}
|
||||
|
||||
print "Executing gdb\n";
|
||||
unlink '.output';
|
||||
|
||||
open my $truncate_output, '>', '.output';
|
||||
close $truncate_output;
|
||||
unlink '.gdb_output', '.prog_output';
|
||||
|
||||
if(not defined $merger_pid or not find_pid($merger_pid)) {
|
||||
waitpid $merger_pid, 0 if defined $merger_pid;
|
||||
print "compiler_vm_server: starting merger\n";
|
||||
$merger_pid = start_merger;
|
||||
sleep 1;
|
||||
print "merger started; pid: $merger_pid\n";
|
||||
}
|
||||
|
||||
my $user_input_quoted = quotemeta $user_input;
|
||||
$user_input_quoted =~ s/\\"/"'\\"'"/g;
|
||||
($ret, $result) = execute(60, "bash -c \"date -s \@$date; ulimit -t 1; compiler_watchdog.pl $user_input_quoted\"");
|
||||
|
|
@ -227,4 +250,27 @@ sub execute {
|
|||
return ($ret, $result);
|
||||
}
|
||||
|
||||
sub start_merger {
|
||||
my $merger_pid = fork;
|
||||
die "merger fork failed: $!" if not defined $merger_pid;
|
||||
|
||||
if($merger_pid == 0) {
|
||||
exec('compiler_output_merger.pl');
|
||||
die "merger exec failed: $!";
|
||||
} else {
|
||||
print "compiler_vm_server: merger startered; pid: $merger_pid\n";
|
||||
return $merger_pid;
|
||||
}
|
||||
}
|
||||
|
||||
sub find_pid {
|
||||
my ($pid) = @_;
|
||||
return 0 if not defined $pid;
|
||||
my $t = new Proc::ProcessTable('enable_ttys' => 0);
|
||||
foreach my $p (@{ $t->table }) {
|
||||
return 1 if $p->pid == $pid;
|
||||
}
|
||||
return 0;
|
||||
}
|
||||
|
||||
runserver;
|
||||
|
|
|
|||
|
|
@ -17,6 +17,7 @@ my $got_output = 0;
|
|||
my $local_vars = "";
|
||||
|
||||
sub flushall;
|
||||
sub writenewline;
|
||||
sub gdb;
|
||||
|
||||
use IO::Handle;
|
||||
|
|
@ -95,7 +96,8 @@ sub execute {
|
|||
my $line = <$out>;
|
||||
print "== got: $line\n" if $debug >= 5;
|
||||
if($line =~ m/^\d+\s+return.*?;\s*$/ or $line =~ m/^\d+\s+}\s*$/) {
|
||||
if($got_output == 0 and -s '.output' == 0) {
|
||||
writenewline $in, $out;
|
||||
if($got_output == 0 and -s '.output' <= 1) {
|
||||
print "no output, checking locals\n" if $debug >= 5;
|
||||
gdb $in, "print \"Go.\"\ninfo locals\nprint \"Ok.\"\n";
|
||||
|
||||
|
|
@ -477,6 +479,18 @@ sub gdb {
|
|||
print $in "$command\n";
|
||||
}
|
||||
|
||||
sub writenewline {
|
||||
my ($in, $out) = @_;
|
||||
|
||||
gdb $in, "call puts(\"\")\nprint \"Ok.\"\n";
|
||||
while(my $line = <$out>) {
|
||||
chomp $line;
|
||||
$line =~ s/^\(gdb\)\s*//;
|
||||
$line =~ s/\$\d+ = 0$//;
|
||||
last if $line =~ m/\$\d+ = "Ok."/;
|
||||
}
|
||||
}
|
||||
|
||||
sub flushall {
|
||||
my ($in, $out) = @_;
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue