#!/usr/bin/perl
## -*- mode: Perl -*-
##
## Copyright (c) 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 The University of Utah
## All rights reserved.
##
## This file is distributed under the University of Illinois Open Source
## License.  See the file COPYING for details.

######################################################################
#
# This is a generic Delta debugger that is parameterized by an
# interestingness test implemented as a shell script and a collection
# of transformation operators implemented as Perl modules.
#
####################################################################

use strict;
use warnings;
require 5.10.0;

use FindBin;
use lib $FindBin::Bin, '/clangarm64/share/creduce/perl';
use Exporter::Lite;
use File::Basename;
use File::Compare;
use File::Which;
use Getopt::Tabular;
use POSIX;
use Regexp::Common;
use File::Spec;
use File::Temp;
use File::Copy;
use Carp;
$SIG{ __DIE__ } = sub { Carp::confess( @_ ) };

# Load and use the Term::ReadKey module if available, don't complain otherwise
my $SKIP_KEY_OFF = 0;
$SKIP_KEY_OFF = 1 unless eval { require Term::ReadKey; };

if ($^O eq "MSWin32") {
    eval { require Win32::Process; Win32::Process->import(); };
}

use creduce_config qw(PACKAGE_STRING);
use creduce_utils;

my $NPROCS;

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

my $MAX_CRASH_DIRS = 10;
my $MAX_EXTRA_DIRS = 25000;
my $GIVEUP_CONSTANT = 50000;
my $PRINT_DIFF = 0;
my $SKIP_FIRST;
my $SAVE_TEMPS;
my $SLLOOWW = 0;
my $NODEFAULT;
my $TIMING = 0;
my $ABS_TIMING = 0;
my $TIMEOUT_IN_SECONDS = 300; # 5 minutes.
my $DEBUG_SMP = 0;
my $DIE_ON_PASS_BUG = 0;
my $SILENT_PASS_BUGS = 0;
my $TIDY = 0;
my $ALSO_INTERESTING = -1;
my $NOKILL = 0;
my $MAX_WIN;
my $NO_CACHE = 0;
my $NOTC = 0;
my $PKG = creduce_config::PACKAGE_STRING;
my $COMMIT = creduce_config::GIT_VERSION;

sub print_version() {
    print "$PKG ($COMMIT)\n";
    exit(0);
}

my @options = (
    ["--version",             "call",    0, \&print_version,   "Print the version information"] ,
    ["--n",                   "integer", 1, \$NPROCS,          "Number of cores to use; C-Reduce tries to automatically pick a good setting but its choice may be too low or high for your situation", "<N>"],
    ["--tidy",                "const",   1, \$TIDY,            "Do not make a backup copy of each file to reduce as file.orig"],
    ["--shaddap",             "const",   1, \$SILENT_PASS_BUGS, "Suppress output about non-fatal internal errors"],
    ["--die-on-pass-bug",     "const",   1, \$DIE_ON_PASS_BUG, "Terminate C-Reduce if a pass encounters an otherwise non-fatal problem"],
    ["--sllooww",             "const",   1, \$SLLOOWW,         "Try harder to reduce, but perhaps take a long time to do so"],
    ["--also-interesting",    "integer", 1, \$ALSO_INTERESTING, "A process exit code (somewhere in the range 64-113 would be usual) that, when returned by the interestingness test, will cause C-Reduce to save a copy of the variant", "<exitcode>"],
    ["--debug",               "const",   1, \$DEBUG,           "Print debug information"],
    ["--no-kill",             "const",   1, \$NOKILL,          "Wait for parallel instances to terminate on their own instead of killing them (only useful for debugging)"],
    ["--no-give-up",          "const",   0, \$GIVEUP_CONSTANT, "Don't give up on a pass that hasn't made progress for ${GIVEUP_CONSTANT} iterations"],
    ["--print-diff",          "const",   1, \$PRINT_DIFF,      "Show changes made by transformations, for debugging"],
    ["--save-temps",          "const",   1, \$SAVE_TEMPS,      "Don't delete /tmp/creduce-xxxxxx directories on termination"],
    ["--not-c",               "const",   1, \$NOTC,            "Don't run passes that are specific to C and C++, use this mode for reducing other languages"],
    ["--skip-initial-passes", "const",   1, \$SKIP_FIRST,      "Skip initial passes (useful if input is already partially reduced)"],
    ["--timing",              "const",   1, \$TIMING,          "Print timestamps about reduction progress"],
    ["--abs-timing",          "const",   1, \$ABS_TIMING,      "Print timestamps about reduction progress using absolute time"],
    ["--no-cache",            "const",   1, \$NO_CACHE,        "Don't cache behavior of passes"],
    ["--timeout",             "integer", 1, \$TIMEOUT_IN_SECONDS, "Interestingness test timeout in seconds"],
    ["--no-default-passes",   "const",   1, \$NODEFAULT,       "Start with an empty pass schedule"],
    ["--add-pass",            "call",    0, \&add_pass,        "Add the specified pass to the schedule", "<pass> <sub-pass> <priority>"],
    ["--remove-pass",         "call",    0, \&remove_pass,     "Remove all instances of the specified pass from the schedule.", "<pass> [sub-pass]"],
    ["--skip-key-off",        "const",   1, \$SKIP_KEY_OFF,    "Disable skipping the rest of the current pass when \"s\" is pressed"],
    ["--max-improvement",     "integer", 1, \$MAX_WIN,         "Largest improvement in file size from a single transformation that C-Reduce should accept (useful only to slow C-Reduce down)", "<bytes>"],
);

@options = sort { return @{$a}[0] cmp @{$b}[0]; } @options;
my $help = <<HELP;
$PKG ($COMMIT) -- a C and C++ program reducer

C-Reduce requires an "interestingness test" and one or more files to
reduce, which must be writable. The interestingness test is an
executable program (usually a shell script) that returns 0 when a
partially reduced file is interesting (a candidate for further
reduction) and returns non-zero when a partially reduced file is not
interesting (not a candidate for further reduction -- all
uninteresting files are discarded).

C-Reduce runs the interestingness test in a fresh temporary directory
containing only the partially reduced file(s). Thus, when the
interestingness test examines a partially reduced file, it must do so
using a relative path to the current working directory. On the other
hand, when the interestingness test refers to any file that is not
being reduced, this should be done using an absolute path.

The interestingness test should be deterministic and should not expect
any command line arguments.

C-Reduce can and does introduce infinite loops during
reduction. Therefore, if your interestingness test runs the compiled
program, this should be done under a timeout. You can implement the
timeout yourself, for example using the UNIX "timeout" command, or
alternatively you can give C-Reduce a timeout (which is on by default,
but is set very long: 5 minutes). An advantage of using C-Reduce's
timeout is that when a test is killed due to timing out, a message
will be printed. If you do implement a timeout yourself, we recommend
that your interestingness test returns exit code 124 when a subcommand
times out. This will not affect the reduction but it will cause
C-Reduce to print a message stating the interestingness test
reported a timeout. It is important to ensure that timeouts are not
occurring too often (especially during C-Reduce's initial passes) or
else C-Reduce will work poorly.

There is a particularly subtle issue regarding timeouts, which is that
the interestingness test may slow down due to resource contention when
C-Reduce runs multiple copies of it on different cores. We have
observed slowdowns of up to 50% due to (we suspect) cache
thrashing. You must take this slowdown into account when choosing a
timeout or else timeouts might occur very frequently.

As a quick example of an interestingness test, if you consider a file
to be interesting if GCC's vectorizer fires while compiling it, you
might write this shell script:

  gcc -w -O3 foo.c -S &&
  grep xmm foo.s

To see if your interestingness test is working, try running these
commands:

  DIR=\`mktemp -d\`
  cp file_to_reduce [optionally, more files to reduce] \$DIR
  cd \$DIR
  /path/to/interestingness_test
  echo \$\?

This should result in "0" being echoed to the terminal. If this does
not happen, the interestingness test is flawed and C-Reduce won't be
able to make use of it.

If you haven\'t written an interestingness test before, please refer to
this tutorial for additional guidance:

  https://embed.cs.utah.edu/creduce/using/

If at all possible, run C-Reduce on preprocessed code, generated for
example using:

  gcc -E -P file.c

If you cannot reduce preprocessed code, you can either reduce just the
non-preprocessed file or else perform a multi-file reduction on the
file and its transitive includes (or any subset of them). In the first case
you need to set the CREDUCE_INCLUDE_PATH environment variable to a colon-
separated list of include directories in order for clang_delta to find them.

If your interestingness test involves a cross compiler and the characteristics
of the cross target differs from the host you will need to set
CREDUCE_TARGET_TRIPLE to match the cross target. This is particularly important
if you are working with non-preprocessed code and use CREDUCE_INCLUDE_PATH.

Press "s" at any time to skip to the next pass (this feature is
disabled unless the Perl module Term::ReadKey is available on your
system).
HELP

my $usage_text = <<USAGE;
usage: creduce [options] interestingness_test file_to_reduce [optionally, more files to reduce]
       creduce --help for more information

USAGE

sub usage() {
    print $usage_text;
    exit(1);
}

Getopt::Tabular::SetHelp ($help, $usage_text);
Getopt::Tabular::SetOptionPatterns qw|(--)([\w-]+) (-)(\w+)|;
Getopt::Tabular::SetHelpOption("--help");
GetOptions(\@options, \@ARGV) or exit(1);
usage() unless (@ARGV >= 2);
defined $NPROCS or $NPROCS = nprocs();

my @custom_methods;
my %removed_methods;

sub add_pass {
    my ($opt, $args, $dest) = @_;
    my $name = shift @$args;
    my $subpass = shift @$args;
    my $pri = shift @$args;
    return 0 unless defined $name && defined $subpass && defined $pri;
    my %pass = ();
    $pass{"name"} = $name;
    $pass{"arg"} = $subpass;
    $pass{"pri"} = $pri;
    push @custom_methods, \%pass;
    return 1;
}

sub remove_pass {
    my ($opt, $args, $dest) = @_;
    my $name = shift @$args;
    my $subpass = shift @$args;
    return 0 unless defined $name;
    $subpass = "*" unless defined $subpass;
    $removed_methods{$name . "::" . $subpass} = 1;
    return 1;
}

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

my $total_file_size = 0;
my $orig_total_file_size = 0;

# these are set at startup time and never change
my $test;
my $orig_dir;

my @toreduce;
my %fileonly;
my %suffix;

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

sub print_pct () {
    my $s = 0;
    foreach my $f (@toreduce) {
        $s += -s $f;
    }
    my $pct = 100 - ($s * 100.0 / $orig_total_file_size);
    printf "(%.1f %%, $s bytes)\n", $pct;
}

my @tmpdirs;

sub make_tmpdir () {
    my $dir = File::Temp::tempdir("creduce-XXXXXX",
                                  $SAVE_TEMPS ? (CLEANUP => 0) : (CLEANUP => 1),
                                  DIR => File::Spec->tmpdir);
    push @tmpdirs, $dir;
    return $dir;
}

sub remove_tmpdirs () {
    return if $SAVE_TEMPS;
    while (my $dir = shift(@tmpdirs)) {
        File::Path::remove_tree ($dir, {verbose => 0, safe => 0, error => \my $err});
    }
}

sub create_extra_dir() {
    my $dir;
    for (my $i=0; $i<$MAX_EXTRA_DIRS; $i++) {
        $dir = File::Spec->catfile($orig_dir, sprintf "creduce_extra_%05d", $i);
        last unless -d $dir;
    }
    # just bail if we've already created enough of these dirs, no need
    # to clutter things up even more...
    return if -d $dir;
    mkdir $dir or die;
    my @files = glob "*";
    foreach my $f (@files) {
        File::Copy::move($f, $dir) or die "Could not move file\n";
    }
    print "created extra directory '$dir' for you to look at later\n";
}

# returns true if interesting, false otherwise
sub delta_test () {
    my $res;
    eval {
        local $SIG{ALRM} = sub { die "TIMEOUT\n"; };
        alarm($TIMEOUT_IN_SECONDS);
        if ($DEBUG) {
            $res = runit ("$test");
        } else {
            if($^O eq "MSWin32") {
                $res = runit ("$test > NUL 2>&1");
            } else {
                $res = runit ("$test > /dev/null 2>&1");
            }
        }
        print "(Interestingness test reported a timeout.)\n" if $res == 124;
        create_extra_dir() if ($ALSO_INTERESTING != -1 && $res == $ALSO_INTERESTING);
        alarm(0);
    };
    if ($@) {
        print "(Interestingness test killed by timeout at ${TIMEOUT_IN_SECONDS} seconds.)\n";
        kill ('TERM', 0); # take out the whole process group
        die("bug -- should not have reached this line");
    }
    return ($res == 0);
}

sub copy_files_here() {
    foreach my $f (@toreduce) {
        File::Copy::copy($f,$fileonly{$f}) or die "cannot copy '$f'";
    }
}

sub sanity_check () {
    print "sanity check... " if $DEBUG;
    my $tmpdir = make_tmpdir();
    print "tmpdir = $tmpdir\n" if ($DEBUG);
    chdir $tmpdir or die;
    copy_files_here();
    if (!delta_test()) {
        chdir $orig_dir;
        my $stuff = "";
        foreach my $f (sort keys %fileonly) {
            $stuff .= " $f";
        }
        print <<"EOT";

C-Reduce cannot run because the interestingness test does not return
zero. Please ensure that it does so not only in the directory where
you are invoking C-Reduce, but also in an arbitrary temporary
directory containing only the files that are being reduced. In other
words, running these commands:

  DIR=\`mktemp -d\`
  cp$stuff \$DIR
  cd \$DIR
  $test
  echo \$\?

should result in "0" being echoed to the terminal.

See "creduce --help" for more information.

EOT
        exit(1);
    }
    print "successful\n" if $DEBUG;
    chdir $orig_dir or die;
    remove_tmpdirs();
}

my $old_len = 1000000000;

sub call_prereq_check ($) {
    (my $method) = @_;
    my $str = $method."::check_prereqs";
    no strict "refs";
    &${str}() or die "prereqs not found for pass $method";
    print "successfully checked prereqs for $method\n" if $DEBUG;
}

sub call_new ($$$) {
    (my $method,my $fn,my $arg) = @_;
    my $str = $method."::new";
    no strict "refs";
    return &${str}($fn,$arg);
}

sub call_advance ($$$$) {
    (my $method,my $fn,my $arg,my $state) = @_;
    my $str = $method."::advance";
    no strict "refs";
    return &${str}($fn,$arg,$state);
}

sub call_transform ($$$$) {
    (my $method,my $fn,my $arg,my $state) = @_;
    my $str = $method."::transform";
    no strict "refs";
    return &${str}($fn,$arg,$state);
}

# @variants is the list of variants that we're currently considering;
# it is speculative by assuming that each subsequent variant is
# uninteresting; once an interesting variant is found, the speculation
# is incorrect and we have to empty out this list using killem() and
# start again; elements of this list are tuples where the first
# element is the pid of the child process (if running) or -1 (if we've
# already waited for that child)
my @variants = ();
my @procs = ();
my $num_running = 0;

sub killem() {
    if($^O eq "MSWin32") {
        while (scalar(@procs) > 0) {
            my $proc = shift @procs;
            # Kill process group
            # Win32::Process::Info might be an alternative
            # $proc->Kill(1); #does not kill the children
            my $pid = $proc->GetProcessID();
            system "TASKKILL /F /T /PID $pid > NUL 2>&1"
                unless $NOKILL;
            $proc->Wait(Win32::Process::INFINITE());
            $num_running--;
        }
        while (scalar(@variants) > 0) {
            my $kidref = shift @variants;
            die unless (scalar(@{$kidref})==5);
            (my $pid, my $newsh, my $tmpdir, my $tmpfn, my $result) = @{$kidref};
            File::Path::remove_tree ($tmpdir, {verbose => 0, safe => 0, error => \my $err})
                unless $SAVE_TEMPS;
        }
    } else {
        while (scalar(@variants) > 0) {
            my $kidref = shift @variants;
            die unless (scalar(@{$kidref})==5);
            (my $pid, my $newsh, my $tmpdir, my $tmpfn, my $result) = @{$kidref};
            if ($pid != -1) {
                # kill the whole group
                kill ('TERM', -$pid)
                    unless $NOKILL;
                waitpid ($pid, 0);
                $num_running--;
            }
            File::Path::remove_tree ($tmpdir, {verbose => 0, safe => 0, error => \my $err})
                unless $SAVE_TEMPS;
        }
    }
}

sub fork_helper($) {
    (my $tmpfn) = @_;
    if ($^O eq "MSWin32") {
        my $cmd = which("cmd.exe");
        my $cmdline = qq{/C "$test" $tmpfn};
        $cmdline .= " > NUL 2>&1" unless $DEBUG;

        my $proc;
        Win32::Process::Create($proc,
                               $cmd,
                               $cmdline,
                               0,
                               Win32::Process::NORMAL_PRIORITY_CLASS() |
                               Win32::Process::CREATE_NEW_PROCESS_GROUP(),
                               ".") || die;
        push @procs, $proc;
        return $proc->GetProcessID();
    } else {
        my $pid = fork();
        die "fork() failed! please try this reduction again with less parallelism."
          unless defined $pid;
        die unless ($pid >= 0);
        if ($pid == 0) {
            # put this process (the child) into a process group named by
            # its pid so that we'll be able to kill its entire subtree
            # later
            setpgrp();
            # flip the T/F flag back into a 0/1
            my $res = delta_test();
            print "delta_test() returned $res\n" if $DEBUG;
            my $exitcode = $res ? 0 : 1;
            print "forked child exiting with $exitcode (1 == uninteresting, 0 == interesting)\n" if $DEBUG_SMP;
            exit($exitcode);
        }
        return $pid;
    }
}

sub wait_helper() {
    if ($^O eq "MSWin32") {
        return -1 if @procs == 0;

        while(1) {
            my $proc = shift @procs;
            $proc->Wait(Win32::Process::INFINITE());

            my $exit_code;
            if ($proc->GetExitCode($exit_code) != Win32::Process::STILL_ACTIVE()) {
                $? = $exit_code << 8;
                return $proc->GetProcessID();
            }
            push @procs, $proc;
        }
    } else {
        my $cpid = wait();
        die if ($cpid == -1);
        return $cpid;
    }
}

sub check_for_nonzero_size() {
    my $nonzero = 0;
    foreach my $fn (@toreduce) {
        if (-s $fn != 0) {
            $nonzero = 1;
            last;
        }
    }
    if (!$nonzero) {
        print "\n";
        if (scalar(@toreduce) > 1) {
            print "All files being reduced have reached zero size; ";
        } else {
            print "The file being reduced has reached zero size; ";
        }
        print <<EOT;
our work here is done.

If you did not want a zero size file, you must help C-Reduce out by
making sure that your interestingness test does not find files like
this to be interesting.

EOT
        exit(1);
    }
}

sub report_pass_bug($$$) {
    (my $delta_method, my $delta_arg, my $prob) = @_;
    if (!$SILENT_PASS_BUGS) {
        my $dir;
        for (my $i=0; $i<$MAX_CRASH_DIRS; $i++) {
            $dir = File::Spec->catfile($orig_dir, sprintf "creduce_bug_%03d", $i);
            last unless -d $dir;
        }
        # just bail if we've already created enough of these dirs, no need
        # to clutter things up even more...
        return if -d $dir;
        mkdir $dir or die;
        chdir $dir or die;
        copy_files_here();
        my $cont = $DIE_ON_PASS_BUG ? "" :
            "\nThis bug is not fatal, C-Reduce will continue to execute.\n";
        my $MSG = <<"EOT";

***************************************************

${delta_method}::${delta_arg} has encountered a bug:
${prob}

Please consider tarring up ${dir}
and mailing it to creduce-bugs\@flux.utah.edu and we will try to fix
the bug.
${cont}
***************************************************

EOT
        open OF, ">PASS_BUG_INFO.TXT";
        print OF "$PKG\n";
        print OF "$COMMIT\n";
        my @l = POSIX::uname();
        foreach my $s (@l) {
            print OF "$s\n";
        }
        print OF "$MSG";
        close OF;
        print $MSG;
    }
    if ($DIE_ON_PASS_BUG) {
        print "Exiting upon request due to pass bug.\n";
        exit(1);
    }
}

my $pass_num = 0;
my %method_worked = ();
my %method_failed = ();
my %cache = ();
my $start_time = time();

# invariant: parallel execution does not escape this function
#
# the parallelization strategy is described here:
#   http://blog.regehr.org/archives/749
sub delta_pass ($) {
    (my $mref) = @_;
    my $delta_method = ${$mref}{"name"};
    my $delta_arg = ${$mref}{"arg"};
    my $skip = 0;

    die unless (scalar(@variants)==0);
    die unless ($num_running==0);

    check_for_nonzero_size();

    print "\n" if $DEBUG;
    my $passname = "$delta_method :: $delta_arg";
    print "===< $passname >===\n";

    @toreduce = sort bysize @toreduce;
    foreach my $fn (@toreduce) {
        next unless (-s $fn > 0);
        my $file_before_pass = read_file($fn);
        if (!$NO_CACHE) {
            my $cached = $cache{$passname}{$file_before_pass};
            if (defined $cached) {
                write_file($fn, $cached);
                print "(cache hit for $fn)\n";
                next;
            }
        }
        my $state = call_new ($delta_method,$fileonly{$fn},$delta_arg);
        my $since_success = 0;
        my $stopped = 0;

      AGAIN:

        # create child processes until either:
        # 1. we exhaust the concurrency budget
        # 2. the pass tells us to STOP
        # 3. $SKIP_KEY_OFF is not set and the "s" key on the terminal is pressed
        if (!$SKIP_KEY_OFF) {
            Term::ReadKey::ReadMode(3);
            my $key = Term::ReadKey::ReadKey(-1);
            Term::ReadKey::ReadMode(0);
            if (defined($key) && $key eq "s") {
                print "\n****** skipping the rest of this pass ******\n\n";
                $skip = 1;
            }
        }
        while (!($stopped || $skip) && $num_running < $NPROCS) {
            my $tmpdir = make_tmpdir();
            chdir $tmpdir or die;
            copy_files_here();
            # creating the variant is done in the parent, it's only
            # testing variants that happens in parallel
            my $variant = File::Spec->catfile($tmpdir, $fileonly{$fn});
            (my $delta_res, $state) = call_transform ($delta_method,$variant,$delta_arg,$state);
            if ($delta_res != $OK && $delta_res != $STOP) {
                report_pass_bug($delta_method, $delta_arg,
                                ($delta_res == $ERROR) ? $state :
                                "unknown return code");
            }
            if ($delta_res == $STOP || $delta_res == $ERROR) {
                chdir $orig_dir or die;
                $stopped = 1;
            } else {
                system "diff $fn $variant" if ($PRINT_DIFF);
                if (compare ($fn, $variant) == 0) {
                    report_pass_bug($delta_method, $delta_arg,
                                    "pass failed to modify the variant");
                    chdir $orig_dir or die;
                    $stopped = 1;
                } else {
                    my $pid = fork_helper ($variant);
                    my @l = ($pid, $state, $tmpdir, $variant, -99);
                    push @variants, \@l;
                    chdir $orig_dir or die;
                    $num_running++;
                    print "forked $pid, num_running = ${num_running}\n" if $DEBUG_SMP;
                    $state = call_advance ($delta_method, $variant, $delta_arg, $state);
                }
            }
        }

        if ($num_running > 0) {
            print "parent is waiting\n" if $DEBUG_SMP;
            my $xpid = wait_helper();
            # UNIX 0/1 back to Perl T/F
            my $delta_result = (($? >> 8) == 0) ? 1 : 0;
            print "child $xpid had delta_result ${delta_result} (0 == uninteresting, 1 == interesting)\n"
                if $DEBUG_SMP;
            $num_running--;
            my $found = 0;
            my $len = scalar (@variants);
            for (my $k=0; $k<scalar(@variants); $k++) {
                my $kidref = $variants[$k];
                die unless (scalar(@{$kidref})==5);
                (my $pid,my $newsh,my $tmpdir,my $var,my $res) = @{$kidref};
                if ($xpid == $pid) {
                    $found = 1;
                    my @l = (-1,$newsh,$tmpdir,$var,$delta_result);
                    splice (@variants, $k, 1, \@l);
                    last;
                }
            }
            die unless $found;
            die unless ($len == scalar (@variants));
        }

        # starting at the front of the list, peel off all variants that
        # aren't backed up by a running subprocess
        while (scalar (@variants) > 0) {
            (my $pid,my $newsh,my $tmpdir,my $variant,my $delta_result) = @{$variants[0]};
            last unless ($pid == -1);
            my $trash = shift @variants;
            if ($delta_result &&
                (!defined $MAX_WIN || ((-s $fn) - (-s $variant) < $MAX_WIN))) {
                # now that the delta test succeeded, this becomes our
                # new best version

                # nuke all ongoing speculation
                killem ();

                # here is where we actually accept the new result: we
                # need to grab both the file and the pass state
                File::Copy::copy ($variant, $fn) or die;
                $state = $newsh;

                # we don't want to be stopped by a speculative transformation
                $stopped = 0;

                $since_success = 0;
                $method_worked{$passname}++;
                print "delta test success " if $DEBUG;
                print_pct();
                print "timestamp " . (time()-$start_time) . " size ".(-s $fn)."\n"
                    if $TIMING;
                print "timestamp " . time() . " size ".(-s $fn)."\n"
                    if $ABS_TIMING;
            } else {
                print "delta test failure\n" if $DEBUG;
                $since_success++;
                $method_failed{$passname}++;
            }
            print "[${pass_num} $passname] " if $DEBUG;
            File::Path::remove_tree ($tmpdir, {verbose => 0, safe => 0, error => \my $err})
                unless $SAVE_TEMPS;
        }

        # nasty heuristic for avoiding getting stuck by buggy passes
        # that keep reporting success w/o making progress -- FIXME
        # report a bug here
        if ($GIVEUP_CONSTANT != 0 && ($since_success > $GIVEUP_CONSTANT)) {
            killem();
            report_pass_bug($delta_method, $delta_arg, "pass got stuck");
            remove_tmpdirs();
            next;
        }

        # termination condition for this pass
        if (($skip || $stopped) && scalar(@variants)==0) {
            remove_tmpdirs();
            $cache{$passname}{$file_before_pass} = read_file($fn) unless $NO_CACHE;
            next;
        }

        goto AGAIN;
    }
}

sub line_delta_pass ($) {
    (my $n) = @_;
    my $line = { "name" => "pass_lines", "arg" => "$n", };
    delta_pass ($line);
}

my @all_methods = (

    { "name" => "pass_include_includes", "arg" => "0",               "pri" => 100, "C" => 1, },
    { "name" => "pass_unifdef",  "arg" => "0",                       "pri" => 450,  "first_pass_pri" =>  0, "C" => 1, },
    { "name" => "pass_comments", "arg" => "0",                       "pri" => 452,  "first_pass_pri" =>  0, "C" => 1, },
    { "name" => "pass_ifs",  "arg" => "0",                           "pri" => 453,  "first_pass_pri" =>  0, "C" => 1, },
    { "name" => "pass_includes", "arg" => "0",                                      "first_pass_pri" =>  1, "C" => 1, },
    { "name" => "pass_line_markers", "arg" => "0",                                  "first_pass_pri" =>  1, "C" => 1, },
    { "name" => "pass_blank",    "arg" => "0",                                      "first_pass_pri" =>  2, },
    { "name" => "pass_clang_binsrch",    "arg" => "replace-function-def-with-decl", "first_pass_pri" =>  3, "C" => 1, },
    { "name" => "pass_clang_binsrch",    "arg" => "remove-unused-function",         "first_pass_pri" =>  4, "C" => 1, },

    { "name" => "pass_lines",    "arg" => "0",                      "pri" => 410,  "first_pass_pri" =>  20,   "last_pass_pri" => 999, },
    { "name" => "pass_lines",    "arg" => "1",                      "pri" => 411,  "first_pass_pri" =>  21, },
    { "name" => "pass_lines",    "arg" => "2",                      "pri" => 412,  "first_pass_pri" =>  22, },
    { "name" => "pass_lines",    "arg" => "3",                      "pri" => 413,  "first_pass_pri" =>  23, },
    { "name" => "pass_lines",    "arg" => "4",                      "pri" => 414,  "first_pass_pri" =>  24, },
    { "name" => "pass_lines",    "arg" => "6",                      "pri" => 415,  "first_pass_pri" =>  25, },
    { "name" => "pass_lines",    "arg" => "8",                      "pri" => 416,  "first_pass_pri" =>  26, },
    { "name" => "pass_lines",    "arg" => "10",                     "pri" => 417,  "first_pass_pri" =>  27, },

    { "name" => "pass_clang_binsrch",    "arg" => "replace-function-def-with-decl", "first_pass_pri" => 33, "C" => 1, },
    { "name" => "pass_clang_binsrch",    "arg" => "remove-unused-function",         "first_pass_pri" => 34, "C" => 1, },

    { "name" => "pass_special",  "arg" => "a",                                     "first_pass_pri" => 110, "C" => 1, },
    { "name" => "pass_special",  "arg" => "b",                      "pri" => 555,  "first_pass_pri" => 110, "C" => 1, },
    { "name" => "pass_special",  "arg" => "c",                      "pri" => 555,  "first_pass_pri" => 110, "C" => 1, },
    { "name" => "pass_ternary",  "arg" => "b",                      "pri" => 104,  "C" => 1, },
    { "name" => "pass_ternary",  "arg" => "c",                      "pri" => 105,  "C" => 1, },

    { "name" => "pass_balanced", "arg" => "curly",                  "pri" => 110,  "first_pass_pri" =>  41, },
    { "name" => "pass_balanced", "arg" => "curly2",                 "pri" => 111,  "first_pass_pri" =>  42, },
    { "name" => "pass_balanced", "arg" => "curly3",                 "pri" => 112,  "first_pass_pri" =>  43, },
    { "name" => "pass_balanced", "arg" => "parens",                 "pri" => 113,  },
    { "name" => "pass_balanced", "arg" => "angles",                 "pri" => 114,  },
    { "name" => "pass_balanced", "arg" => "square",                 "pri" => 115,  },
    { "name" => "pass_balanced", "arg" => "curly-inside",           "pri" => 150,  },
    { "name" => "pass_balanced", "arg" => "parens-inside",          "pri" => 151,  },
    { "name" => "pass_balanced", "arg" => "angles-inside",          "pri" => 152,  },
    { "name" => "pass_balanced", "arg" => "square-inside",          "pri" => 153,  },
    { "name" => "pass_balanced", "arg" => "curly-only",             "pri" => 160,  },
    { "name" => "pass_balanced", "arg" => "parens-only",            "pri" => 9700,  }, # sometimes *real* slow
    { "name" => "pass_balanced", "arg" => "angles-only",            "pri" => 162,  },
    { "name" => "pass_balanced", "arg" => "square-only",            "pri" => 163,  },
    { "name" => "pass_balanced", "arg" => "parens-to-zero",         "pri" => 9000,  "first_pass_pri" => 44 },

    { "name" => "pass_clang",    "arg" => "remove-namespace",       "pri" => 200,  "C" => 1, },
    { "name" => "pass_clang",    "arg" => "aggregate-to-scalar",    "pri" => 201,  "C" => 1, },
   #{ "name" => "pass_clang",    "arg" => "binop-simplification",   "pri" => 201,  "C" => 1, },
    { "name" => "pass_clang",    "arg" => "local-to-global",        "pri" => 9500, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "param-to-global",        "pri" => 203,  "C" => 1, },
    { "name" => "pass_clang",    "arg" => "param-to-local",         "pri" => 204,  "C" => 1, },
    { "name" => "pass_clang",    "arg" => "remove-nested-function", "pri" => 205,  "C" => 1, },
    { "name" => "pass_clang",    "arg" => "rename-fun",                            "last_pass_pri" => 207, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "union-to-struct",        "pri" => 208,  },
    { "name" => "pass_clang",    "arg" => "rename-param",                          "last_pass_pri" => 209, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "rename-var",                            "last_pass_pri" => 210, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "rename-class",                          "last_pass_pri" => 211, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "rename-cxx-method",                     "last_pass_pri" => 212, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "return-void",            "pri" => 212, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "simple-inliner",         "pri" => 213, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "reduce-pointer-level",   "pri" => 214, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "lift-assignment-expr",   "pri" => 215, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "copy-propagation",       "pri" => 216, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "callexpr-to-value",      "pri" => 217,  "first_pass_pri" => 49, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "replace-callexpr",       "pri" => 218,  "first_pass_pri" => 50, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "simplify-callexpr",      "pri" => 219,  "first_pass_pri" => 51, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "remove-unused-function", "pri" => 220,  "first_pass_pri" => 40, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "remove-unused-enum-member", "pri" => 221, "first_pass_pri" => 51, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "remove-enum-member-value", "pri" => 222, "first_pass_pri" => 52, "C" => 1, },
    { "name" => "pass_clang_binsrch", "arg" => "remove-unused-var", "pri" => 223,  "first_pass_pri" => 53, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "simplify-if",            "pri" => 224, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "reduce-array-dim",       "pri" => 225, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "reduce-array-size",      "pri" => 226, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "move-function-body",     "pri" => 227, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "simplify-comma-expr",    "pri" => 228, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "simplify-dependent-typedef",   "pri" => 229, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "replace-simple-typedef", "pri" => 230, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "replace-dependent-typedef",     "pri" => 231, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "replace-one-level-typedef-type",     "pri" => 232, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "remove-unused-field",    "pri" => 233, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "instantiate-template-type-param-to-int",  "pri" => 234, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "instantiate-template-param",    "pri" => 235, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "template-arg-to-int",    "pri" => 236, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "template-non-type-arg-to-int", "pri" => 237, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "reduce-class-template-param",  "pri" => 238, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "remove-trivial-base-template", "pri" => 239, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "class-template-to-class",      "pri" => 240, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "remove-base-class",      "pri" => 241, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "replace-derived-class",  "pri" => 242, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "remove-unresolved-base", "pri" => 243, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "remove-ctor-initializer","pri" => 244, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "replace-class-with-base-template-spec","pri" => 245, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "simplify-nested-class",  "pri" => 246, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "remove-unused-outer-class",    "pri" => 247, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "empty-struct-to-int",    "pri" => 248, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "remove-pointer",         "pri" => 249, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "reduce-pointer-pairs",   "pri" => 250, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "remove-array",           "pri" => 251, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "remove-addr-taken",      "pri" => 252, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "simplify-struct",        "pri" => 253, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "replace-undefined-function",   "pri" => 254, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "replace-array-index-var",      "pri" => 255, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "replace-array-access-with-index",     "pri" => 256, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "replace-dependent-name", "pri" => 257, "C" => 1,  },
    { "name" => "pass_clang",    "arg" => "simplify-recursive-template-instantiation",       "pri" => 258, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "vector-to-array",        "pri" => 259, "C" => 1,   },
    { "name" => "pass_clang",    "arg" => "combine-global-var",                    "last_pass_pri" => 990, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "combine-local-var",                     "last_pass_pri" => 991, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "simplify-struct-union-decl",            "last_pass_pri" => 992, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "move-global-var",                       "last_pass_pri" => 993, "C" => 1, },
    { "name" => "pass_clang",    "arg" => "unify-function-decl",                   "last_pass_pri" => 994, "C" => 1, },
    { "name" => "pass_peep",     "arg" => "a",                      "pri" => 9500,  },
    { "name" => "pass_peep",     "arg" => "c",                      "pri" => 9500,  },
    { "name" => "pass_ints",     "arg" => "a",                      "pri" => 9600,  },
    { "name" => "pass_ints",     "arg" => "b",                      "pri" => 9601,  },
    { "name" => "pass_ints",     "arg" => "c",                      "pri" => 9602,  },
    { "name" => "pass_ints",     "arg" => "d",                      "pri" => 9603,  },
    { "name" => "pass_ints",     "arg" => "e",                      "pri" => 9603,  },
    { "name" => "pass_indent",   "arg" => "regular",                "pri" => 1000,  },
    { "name" => "pass_clex",     "arg" => "delete-string",                         "last_pass_pri" => 1001, },
    { "name" => "pass_indent",   "arg" => "final",                                 "last_pass_pri" => 9999, },
    { "name" => "pass_clex", "arg" => "rm-toks-1",              "pri" => 9016, },
    { "name" => "pass_clex", "arg" => "rm-toks-2",              "pri" => 9017, },
    { "name" => "pass_clex", "arg" => "rm-toks-3",              "pri" => 9018, },
    { "name" => "pass_clex", "arg" => "rm-toks-4",              "pri" => 9019, },
    { "name" => "pass_clex", "arg" => "rm-toks-5",              "pri" => 9020, },
    { "name" => "pass_clex", "arg" => "rm-toks-6",              "pri" => 9021, },
    { "name" => "pass_clex", "arg" => "rm-toks-7",              "pri" => 9022, },
    { "name" => "pass_clex", "arg" => "rm-toks-8",              "pri" => 9023, },
    { "name" => "pass_clex", "arg" => "rm-toks-9",              "pri" => 9024, },
    { "name" => "pass_clex", "arg" => "rm-toks-10",             "pri" => 9025, },
    { "name" => "pass_clex", "arg" => "rm-toks-11",             "pri" => 9026, },
    { "name" => "pass_clex", "arg" => "rm-toks-12",             "pri" => 9027, },
    { "name" => "pass_clex", "arg" => "rm-toks-13",             "pri" => 9028, },
    { "name" => "pass_clex", "arg" => "rm-toks-14",             "pri" => 9029, },
    { "name" => "pass_clex", "arg" => "rm-toks-15",             "pri" => 9030, },
    { "name" => "pass_clex", "arg" => "rm-toks-16",             "pri" => 9031, },
    { "name" => "pass_clex", "arg" => "rename-toks",            "pri" => 9800, "last_pass_pri" => 1000, },
    { "name" => "pass_clex", "arg" => "delete-string",          "pri" => 9801, },
    { "name" => "pass_clex", "arg" => "define",                 "pri" => 9802, },
    # { "name" => "pass_clex", "arg" => "shorten-string",         "pri" => 9804, },
    # { "name" => "pass_clex", "arg" => "x-string",               "pri" => 9805, },

    );

if ($SLLOOWW) {
    push @all_methods, (
        { "name" => "pass_clex", "arg" => "rm-tok-pattern-8",       "pri" => 9100, },
        { "name" => "pass_clex", "arg" => "rm-toks-17",             "pri" => 9015, },
        { "name" => "pass_clex", "arg" => "rm-toks-18",             "pri" => 9014, },
        { "name" => "pass_clex", "arg" => "rm-toks-19",             "pri" => 9013, },
        { "name" => "pass_clex", "arg" => "rm-toks-20",             "pri" => 9012, },
        { "name" => "pass_clex", "arg" => "rm-toks-21",             "pri" => 9011, },
        { "name" => "pass_clex", "arg" => "rm-toks-22",             "pri" => 9010, },
        { "name" => "pass_clex", "arg" => "rm-toks-23",             "pri" => 9009, },
        { "name" => "pass_clex", "arg" => "rm-toks-24",             "pri" => 9008, },
        { "name" => "pass_clex", "arg" => "rm-toks-25",             "pri" => 9007, },
        { "name" => "pass_clex", "arg" => "rm-toks-26",             "pri" => 9006, },
        { "name" => "pass_clex", "arg" => "rm-toks-27",             "pri" => 9005, },
        { "name" => "pass_clex", "arg" => "rm-toks-28",             "pri" => 9004, },
        { "name" => "pass_clex", "arg" => "rm-toks-29",             "pri" => 9003, },
        { "name" => "pass_clex", "arg" => "rm-toks-30",             "pri" => 9002, },
        { "name" => "pass_clex", "arg" => "rm-toks-31",             "pri" => 9001, },
        { "name" => "pass_clex", "arg" => "rm-toks-32",             "pri" => 9000, },
        { "name" => "pass_peep", "arg" => "b",                      "pri" => 9500,  },
    );
} else {
    push @all_methods, (
        { "name" => "pass_clex", "arg" => "rm-tok-pattern-4",       "pri" => 9100, },
    );
}

if ($NODEFAULT) {
    if (scalar(@custom_methods) < 1) {
        print <<EOT;

Since you asked for no default passes and added no extra passes
explicitly, C-Reduce doesn't have anything to do. Exiting.

EOT
        exit(1);
    }
    @all_methods = ();
}

foreach my $r (@custom_methods) {
    push @all_methods, $r;
}

my $which;

sub bypri {
    my %aa = %{$a};
    my %bb = %{$b};
    return $aa{$which} <=> $bb{$which};
}

sub pass_iterator ($) {
    ($which) = @_;
    my @l = ();
    foreach my $href (@all_methods) {
        my %pass = %{$href};

        next if defined $removed_methods{$pass{'name'} . "::" . $pass{'arg'}};
        next if defined $removed_methods{$pass{'name'} . "::" . "*"};

        if (defined $pass{$which}) {
            next if $NOTC && defined($pass{"C"});
            push @l, $href;
        }
    }
    my @sorted_list = sort bypri @l;
    return sub {
        return (shift @sorted_list);
    }
}

my %file_attr_to_error = (
    e => "not found",
    f => "is not a plain file",
    r => "is not readable",
    w => "is not writable",
    x => "is not executable",
);

sub check_file_attributes($$$) {
    my ($prefix, $file, $attrs) = @_;
    for my $attr (split //, $attrs) {
        if (eval '! -' . $attr . ' $file') {
            print "$prefix '$file' $file_attr_to_error{$attr}\n";
            usage();
        }
    }
}

############################### main #################################

# no buffering
$| = 1;

my @normal_signals = qw(TERM INT HUP PIPE);
use sigtrap 'handler', \&sigHandler, 'normal-signals';

my $root_process_pid = $$;

sub sigHandler {
    my ($sigName) = @_;
    exit(1) unless ($$ == $root_process_pid);
    killem();
    chdir $orig_dir;
    remove_tmpdirs();
    die "$sigName caught, terminating $$\n";
}

my %prereqs_checked;
foreach my $mref (@all_methods) {
    my %method = %{$mref};
    my $mname = $method{"name"};
    die unless defined ($mname);

    # a tiny bit of typo protection
    foreach my $k (keys %method) {
        die "didn't expect '$k'"
            unless ($k eq "name" || $k eq "first_pass_pri" || $k eq "C" ||
                    $k eq "pri" || $k eq "last_pass_pri" || $k eq "arg");
    }

    next if defined ($prereqs_checked{$mname});

    # FIXME supposedly we can just require $mname; (without the eval)
    # here but that doesn't work...
    eval "require $mname";
    die $@ if $@;
    call_prereq_check($mname);
    $prereqs_checked{$mname} = 1;
}
print "\n" if $DEBUG;

$test = File::Spec->rel2abs(shift @ARGV);
usage() unless defined($test);
check_file_attributes("test script", $test, "efrx");

{
  my %files_seen;
  while (@ARGV) {
    my $f = File::Spec->rel2abs(shift @ARGV);
    die "oops-- shouldn't try to reduce '$f' more than once" if ($files_seen{$f});
    $files_seen{$f} = 1;
    push @toreduce, $f;
    check_file_attributes("file", $f, "efrw");
  }
}

sub bysize {
    return (-s $b) <=> (-s $a);
}

sub byrsize {
    return (-s $a) <=> (-s $b);
}

foreach my $f (@toreduce) {
    my $s = -s $f;
    (my $fo) = fileparse($f);
    $fileonly{$f} = $fo;
    # optionally, make a backup of the file(s) we're reducing-- this
    # is useful when reductions go wrong
    if (!$TIDY && (! -e "${fo}.orig")) {
        File::Copy::copy($f,"${fo}.orig") or die;
    }
    $orig_total_file_size += -s $f;
    $total_file_size += -s $f;
}

$orig_dir = getcwd();

# no point proceeding if the test doesn't start out interesting
sanity_check();

print "===< $$ >===\n";
printf "running $NPROCS interestingness test%s in parallel\n",
    $NPROCS == 1 ? "" : "s";

# some passes we run first since they often make good headway quickliy
if (not $SKIP_FIRST) {
    print "INITIAL PASSES\n" if $DEBUG;
    my $next = pass_iterator("first_pass_pri");
    while (my $item = $next->()) {
        delta_pass ($item);
    }
}

# iterate to global fixpoint
print "MAIN PASSES\n" if $DEBUG;

while (1) {
    my $next = pass_iterator("pri");
    while (my $item = $next->()) {
        delta_pass ($item);
    }
    $pass_num++;
    my $s = 0;
    foreach my $f (@toreduce) {
        $s += -s $f;
    }
    print "Termination check: size was $total_file_size; now $s\n";
    last if ($s >= $total_file_size);
    $total_file_size = $s;
}

# some passes we run last since they work best as cleanup
print "CLEANUP PASS\n" if $DEBUG;
{
    my $next = pass_iterator("last_pass_pri");
    while (my $item = $next->()) {
        delta_pass ($item);
    }
}

print "===================== done ====================\n";

print "\n";
print "pass statistics:\n";
foreach my $m (sort { $method_worked{$a} <=> $method_worked{$b} }
               keys %method_worked) {
    my $w = $method_worked{$m};
    my $f = $method_failed{$m};
    $f = 0 unless defined($f);
    print "  method $m worked $w times and failed $f times\n";
}

foreach my $fn (sort byrsize @toreduce) {
    print "\n          ******** $fn ********\n\n";
    open INF, "<$fn" or die;
    while (<INF>) {
        print;
    }
    close INF;
}

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

## Local Variables:
## indent-tabs-mode: nil
## End:
