michael@0: #!/usr/bin/perl
michael@0: 
michael@0: # Sixgill: Static assertion checker for C/C++ programs.
michael@0: # Copyright (C) 2009-2010  Stanford University
michael@0: # Author: Brian Hackett
michael@0: #
michael@0: # This program is free software: you can redistribute it and/or modify
michael@0: # it under the terms of the GNU General Public License as published by
michael@0: # the Free Software Foundation, either version 3 of the License, or
michael@0: # (at your option) any later version.
michael@0: #
michael@0: # This program is distributed in the hope that it will be useful,
michael@0: # but WITHOUT ANY WARRANTY; without even the implied warranty of
michael@0: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
michael@0: # GNU General Public License for more details.
michael@0: #
michael@0: # You should have received a copy of the GNU General Public License
michael@0: # along with this program.  If not, see <http://www.gnu.org/licenses/>.
michael@0: 
michael@0: # do a complete run of the system from raw source to reports. this requires
michael@0: # various run_monitor processes to be running in the background (maybe on other
michael@0: # machines) and watching a shared poll_file for jobs. if the output directory
michael@0: # for this script already exists then an incremental analysis will be performed
michael@0: # and the reports will only reflect the changes since the earlier run.
michael@0: 
michael@0: use strict;
michael@0: use warnings;
michael@0: use IO::Handle;
michael@0: use File::Basename qw(dirname);
michael@0: use Getopt::Long;
michael@0: use Cwd;
michael@0: 
michael@0: #################################
michael@0: # environment specific settings #
michael@0: #################################
michael@0: 
michael@0: my $WORKDIR;
michael@0: my $SIXGILL_BIN;
michael@0: 
michael@0: # poll file shared with the run_monitor script.
michael@0: my $poll_file;
michael@0: 
michael@0: # root directory of the project.
michael@0: my $build_dir;
michael@0: 
michael@0: # directory containing gcc wrapper scripts.
michael@0: my $wrap_dir;
michael@0: 
michael@0: # optional file with annotations from the web interface.
michael@0: my $ann_file = "";
michael@0: 
michael@0: # optional output directory to do a diff against.
michael@0: my $old_dir = "";
michael@0: 
michael@0: # run in the foreground
michael@0: my $foreground;
michael@0: 
michael@0: my $builder = "make -j4";
michael@0: 
michael@0: my $suppress_logs;
michael@0: GetOptions("build-root|b=s" => \$build_dir,
michael@0:            "poll-file=s" => \$poll_file,
michael@0:            "no-logs!" => \$suppress_logs,
michael@0:            "work-dir=s" => \$WORKDIR,
michael@0:            "sixgill-binaries|binaries|b=s" => \$SIXGILL_BIN,
michael@0:            "wrap-dir=s" => \$wrap_dir,
michael@0:            "annotations-file|annotations|a=s" => \$ann_file,
michael@0:            "old-dir|old=s" => \$old_dir,
michael@0:            "foreground!" => \$foreground,
michael@0:            "buildcommand=s" => \$builder,
michael@0:            )
michael@0:     or die;
michael@0: 
michael@0: if (not -d $build_dir) {
michael@0:     mkdir($build_dir);
michael@0: }
michael@0: if ($old_dir ne "" && not -d $old_dir) {
michael@0:     die "Old directory '$old_dir' does not exist\n";
michael@0: }
michael@0: 
michael@0: $WORKDIR ||= "sixgill-work";
michael@0: mkdir($WORKDIR, 0755) if ! -d $WORKDIR;
michael@0: $poll_file ||= "$WORKDIR/poll.file";
michael@0: $build_dir ||= "$WORKDIR/js-inbound-xgill";
michael@0: 
michael@0: if (!defined $SIXGILL_BIN) {
michael@0:     chomp(my $path = `which xmanager`);
michael@0:     if ($path) {
michael@0:         use File::Basename qw(dirname);
michael@0:         $SIXGILL_BIN = dirname($path);
michael@0:     } else {
michael@0:         die "Cannot find sixgill binaries. Use the -b option.";
michael@0:     }
michael@0: }
michael@0: 
michael@0: $wrap_dir ||= "$WORKDIR/xgill-inbound/wrap_gcc";
michael@0: $wrap_dir = "$SIXGILL_BIN/../scripts/wrap_gcc" if not (-e "$wrap_dir/basecc");
michael@0: die "Bad wrapper directory: $wrap_dir" if not (-e "$wrap_dir/basecc");
michael@0: 
michael@0: # code to clean the project from $build_dir.
michael@0: sub clean_project {
michael@0:     system("make clean");
michael@0: }
michael@0: 
michael@0: # code to build the project from $build_dir.
michael@0: sub build_project {
michael@0:     return system($builder) >> 8;
michael@0: }
michael@0: 
michael@0: our %kill_on_exit;
michael@0: END {
michael@0:     for my $pid (keys %kill_on_exit) {
michael@0:         kill($pid);
michael@0:     }
michael@0: }
michael@0: 
michael@0: # commands to start the various xgill binaries. timeouts can be specified
michael@0: # for the backend analyses here, and a memory limit can be specified for
michael@0: # xmanager if desired (and USE_COUNT_ALLOCATOR is defined in util/alloc.h).
michael@0: my $xmanager = "$SIXGILL_BIN/xmanager";
michael@0: my $xsource = "$SIXGILL_BIN/xsource";
michael@0: my $xmemlocal = "$SIXGILL_BIN/xmemlocal -timeout=20";
michael@0: my $xinfer = "$SIXGILL_BIN/xinfer -timeout=60";
michael@0: my $xcheck = "$SIXGILL_BIN/xcheck -timeout=30";
michael@0: 
michael@0: # prefix directory to strip off source files.
michael@0: my $prefix_dir = $build_dir;
michael@0: 
michael@0: ##########################
michael@0: # general purpose script #
michael@0: ##########################
michael@0: 
michael@0: # Prevent ccache from being used. I don't think this does any good. The problem
michael@0: # I'm struggling with is that if autoconf.mk still has 'ccache gcc' in it, the
michael@0: # builds fail in a mysterious way.
michael@0: $ENV{CCACHE_COMPILERCHECK} = 'date +%s.%N';
michael@0: delete $ENV{CCACHE_PREFIX};
michael@0: 
michael@0: my $usage = "USAGE: run_complete result-dir\n";
michael@0: my $result_dir = shift or die $usage;
michael@0: 
michael@0: if (not $foreground) {
michael@0:     my $pid = fork();
michael@0:     if ($pid != 0) {
michael@0:         print "Forked, exiting...\n";
michael@0:         exit(0);
michael@0:     }
michael@0: }
michael@0: 
michael@0: # if the result directory does not already exist, mark for a clean build.
michael@0: my $do_clean = 0;
michael@0: if (not (-d $result_dir)) {
michael@0:     $do_clean = 1;
michael@0:     mkdir $result_dir;
michael@0: }
michael@0: 
michael@0: if (!$suppress_logs) {
michael@0:     my $log_file = "$result_dir/complete.log";
michael@0:     open(OUT, ">>", $log_file) or die "append to $log_file: $!";
michael@0:     OUT->autoflush(1);  # don't buffer writes to the main log.
michael@0: 
michael@0:     # redirect stdout and stderr to the log.
michael@0:     STDOUT->fdopen(\*OUT, "w");
michael@0:     STDERR->fdopen(\*OUT, "w");
michael@0: }
michael@0: 
michael@0: # pids to wait on before exiting. these are collating worker output.
michael@0: my @waitpids;
michael@0: 
michael@0: chdir $result_dir;
michael@0: 
michael@0: # to do a partial run, comment out the commands here you don't want to do.
michael@0: 
michael@0: my $status = run_build();
michael@0: 
michael@0: # end of run commands.
michael@0: 
michael@0: for my $pid (@waitpids) {
michael@0:     waitpid($pid, 0);
michael@0:     $status ||= $? >> 8;
michael@0: }
michael@0: 
michael@0: print "Exiting run_complete with status $status\n";
michael@0: exit $status;
michael@0: 
michael@0: # get the IP address which a freshly created manager is listening on.
michael@0: sub get_manager_address
michael@0: {
michael@0:     my $log_file = shift or die;
michael@0: 
michael@0:     # give the manager one second to start, any longer and something's broken.
michael@0:     sleep(1);
michael@0: 
michael@0:     my $log_data = `cat $log_file`;
michael@0:     my ($port) = $log_data =~ /Listening on ([\.\:0-9]*)/
michael@0:       or die "no manager found";
michael@0:     print OUT "Connecting to manager on port $port\n" unless $suppress_logs;
michael@0:     print "Connecting to manager on port $port.\n";
michael@0:     return $1;
michael@0: }
michael@0: 
michael@0: sub run_build
michael@0: {
michael@0:     print "build started: ";
michael@0:     print scalar(localtime());
michael@0:     print "\n";
michael@0: 
michael@0:     # fork off a process to run the build.
michael@0:     defined(my $pid = fork) or die;
michael@0: 
michael@0:     # log file for the manager.
michael@0:     my $manager_log_file = "$result_dir/build_manager.log";
michael@0: 
michael@0:     if (!$pid) {
michael@0:         # this is the child process, fork another process to run a manager.
michael@0:         defined(my $pid = fork) or die;
michael@0:         exec("$xmanager -terminate-on-assert > $manager_log_file 2>&1") if (!$pid);
michael@0:         $kill_on_exit{$pid} = 1;
michael@0: 
michael@0:         if (!$suppress_logs) {
michael@0:             # open new streams to redirect stdout and stderr.
michael@0:             open(LOGOUT, "> $result_dir/build.log");
michael@0:             open(LOGERR, "> $result_dir/build_err.log");
michael@0:             STDOUT->fdopen(\*LOGOUT, "w");
michael@0:             STDERR->fdopen(\*LOGERR, "w");
michael@0:         }
michael@0: 
michael@0:         my $address = get_manager_address($manager_log_file);
michael@0: 
michael@0:         # write the configuration file for the wrapper script.
michael@0:         my $config_file = "$WORKDIR/xgill.config";
michael@0:         open(CONFIG, ">", $config_file) or die "create $config_file: $!";
michael@0:         print CONFIG "$prefix_dir\n";
michael@0:         print CONFIG Cwd::abs_path("$result_dir/build_xgill.log")."\n";
michael@0:         print CONFIG "$address\n";
michael@0:         my @extra = ("-fplugin-arg-xgill-mangle=1");
michael@0:         push(@extra, "-fplugin-arg-xgill-annfile=$ann_file")
michael@0:             if ($ann_file ne "" && -e $ann_file);
michael@0:         print CONFIG join(" ", @extra) . "\n";
michael@0:         close(CONFIG);
michael@0: 
michael@0: 	# Tell the wrapper where to find the config
michael@0: 	$ENV{"XGILL_CONFIG"} = Cwd::abs_path($config_file);
michael@0: 
michael@0:         # update the PATH so that the build will see the wrappers.
michael@0:         $ENV{"PATH"} = "$wrap_dir:" . $ENV{"PATH"};
michael@0: 
michael@0:         # do the build, cleaning if necessary.
michael@0:         chdir $build_dir;
michael@0:         clean_project() if ($do_clean);
michael@0:         my $exit_status = build_project();
michael@0: 
michael@0:         # signal the manager that it's over.
michael@0:         system("$xsource -remote=$address -end-manager");
michael@0: 
michael@0:         # wait for the manager to clean up and terminate.
michael@0:         print "Waiting for manager to finish (build status $exit_status)...\n";
michael@0:         waitpid($pid, 0);
michael@0:         my $manager_status = $?;
michael@0:         delete $kill_on_exit{$pid};
michael@0: 
michael@0:         # build is finished, the complete run can resume.
michael@0:         # return value only useful if --foreground
michael@0:         print "Exiting with status " . ($manager_status || $exit_status) . "\n";
michael@0:         exit($manager_status || $exit_status);
michael@0:     }
michael@0: 
michael@0:     # this is the complete process, wait for the build to finish.
michael@0:     waitpid($pid, 0);
michael@0:     my $status = $? >> 8;
michael@0:     print "build finished (status $status): ";
michael@0:     print scalar(localtime());
michael@0:     print "\n";
michael@0: 
michael@0:     return $status;
michael@0: }
michael@0: 
michael@0: sub run_pass
michael@0: {
michael@0:     my ($name, $command) = @_;
michael@0:     my $log_file = "$result_dir/manager.$name.log";
michael@0: 
michael@0:     # extra commands to pass to the manager.
michael@0:     my $manager_extra = "";
michael@0:     $manager_extra .= "-modset-wait=10" if ($name eq "xmemlocal");
michael@0: 
michael@0:     # fork off a manager process for the analysis.
michael@0:     defined(my $pid = fork) or die;
michael@0:     exec("$xmanager $manager_extra > $log_file 2>&1") if (!$pid);
michael@0: 
michael@0:     my $address = get_manager_address($log_file);
michael@0: 
michael@0:     # write the poll file for this pass.
michael@0:     if (! -d dirname($poll_file)) {
michael@0:         system("mkdir", "-p", dirname($poll_file));
michael@0:     }
michael@0:     open(POLL, "> $poll_file");
michael@0:     print POLL "$command\n";
michael@0:     print POLL "$result_dir/$name\n";
michael@0:     print POLL "$address\n";
michael@0:     close(POLL);
michael@0: 
michael@0:     print "$name started: ";
michael@0:     print scalar(localtime());
michael@0:     print "\n";
michael@0: 
michael@0:     waitpid($pid, 0);
michael@0:     unlink($poll_file);
michael@0: 
michael@0:     print "$name finished: ";
michael@0:     print scalar(localtime());
michael@0:     print "\n";
michael@0: 
michael@0:     # collate the worker's output into a single file. make this asynchronous
michael@0:     # so we can wait a bit and make sure we get all worker output.
michael@0:     defined($pid = fork) or die;
michael@0: 
michael@0:     if (!$pid) {
michael@0:         sleep(20);
michael@0:         exec("cat $name.*.log > $name.log");
michael@0:     }
michael@0: 
michael@0:     push(@waitpids, $pid);
michael@0: }
michael@0: 
michael@0: # the names of all directories containing reports to archive.
michael@0: my $indexes;
michael@0: 
michael@0: sub run_index
michael@0: {
michael@0:     my ($name, $kind) = @_;
michael@0: 
michael@0:     return if (not (-e "report_$kind.xdb"));
michael@0: 
michael@0:     print "$name started: ";
michael@0:     print scalar(localtime());
michael@0:     print "\n";
michael@0: 
michael@0:     # make an index for the report diff if applicable.
michael@0:     if ($old_dir ne "") {
michael@0:         system("make_index $kind $old_dir > $name.diff.log");
michael@0:         system("mv $kind diff_$kind");
michael@0:         $indexes .= " diff_$kind";
michael@0:     }
michael@0: 
michael@0:     # make an index for the full set of reports.
michael@0:     system("make_index $kind > $name.log");
michael@0:     $indexes .= " $kind";
michael@0: 
michael@0:     print "$name finished: ";
michael@0:     print scalar(localtime());
michael@0:     print "\n";
michael@0: }
michael@0: 
michael@0: sub archive_indexes
michael@0: {
michael@0:     print "archive started: ";
michael@0:     print scalar(localtime());
michael@0:     print "\n";
michael@0: 
michael@0:     system("tar -czf reports.tgz $indexes");
michael@0:     system("rm -rf $indexes");
michael@0: 
michael@0:     print "archive finished: ";
michael@0:     print scalar(localtime());
michael@0:     print "\n";
michael@0: }