bisect/bisect.pl

#!/usr/bin/env perl

# This script drives the bisection of LLVM/Clang/RT regressions
# by receiving checkout, build and test commands.
#
# By default, the lines are:
#   checkout: './checkout.sh'
#      build: './run.sh'
#       test: ''
#
# Which means: success == builds.
#
# If you use a different checkout script, make sure it accepts one
# parameter, the SVN revision.
#
# Since testing is the hard part, you should write your own
# custom test script for each job, but you can reuse the checkout
# and run scripts if you like.
#
# The test script should return 0 when the commit is GOOD and non-zero
# when it is bad.
#
# The build script has a way to quickly test (check-all, test-suite)
# and you can use that as well, as a shortcut for the testing.

use strict;
use warnings;
use Getopt::Std;
use Scalar::Util qw(looks_like_number);

################################## Command line parsing and validation
my ($prog) = ($0 =~ /\/([^\/]+)$/);
my $syntax = "Syntax: $prog [-c checkout_script] [-b build_script] [-t test_script] good_rev bad_rev\n";
die $syntax unless &getopts('c:b:t:');
our($opt_c, $opt_b, $opt_t);
# Job Statuses
my $Good = 0;
my $CompilerError = 1;
my $TestError = 2;
# Defaults
my ($checkout, $build, $test) = ("./checkout.sh", "./run.sh", "");
$checkout = $opt_c if defined $opt_c;
$build = $opt_b if defined $opt_b;
$test = $opt_t if defined $opt_t;
# Validate
die "Invalid checkout script '$checkout'\n" unless &validate_script(\$checkout);
die "Invalid run script '$build'\n" unless &validate_script(\$build);
die "Invalid test script '$test'\n" unless not $test or &validate_script(\$test);
# Revs
my $last = scalar @ARGV-1;
die $syntax unless $last == 1;
my $good_rev = $ARGV[$last-1];
die $syntax unless looks_like_number $good_rev;
my $bad_rev = $ARGV[$last];
die $syntax unless looks_like_number $bad_rev;
die "Bad rev '$bad_rev' is less than or equal good rev '$good_rev'\n"
  unless $bad_rev > $good_rev;
&main();
exit;

################################## Main bisect logic

sub main () {
  my ($good, $bad) = ($good_rev, $bad_rev);

  # Header
  print "\n==============================================\n".
        " Checkout script: $checkout\n".
        "    Build script: $build\n".
        "     Test script: $test\n".
        " Range: [ $good, $bad ]\n".
        "\n==============================================\n";

  # Iterations
  my $step = 1;
  my $range = $bad-$good;
  my $forced_rev = 0;
  while ($bad > $good and $bad != $good+1) {
    my $rev = int($good+($bad-$good)/2);
    # Use forced rev, from compilation error
    if ($forced_rev) {
      $rev = $forced_rev;
      $forced_rev = 0;
    }
    print "\n---------------------------\n";
    print "Step $step: $good -> $rev -> $bad\n";
    my $result = &check($rev);
    # All good
    if ($result == $Good) {
      print "Revision '$rev' is good\n";
      rename "$rev.log", "$rev.good";
      $good = $rev;
    # Compiler error when test should run
    } elsif ($result == $CompilerError and $test) {
      print "Revision '$rev' has a compiler error\n".
            "Since you're looking for a test error,\n".
            "we'll skip a rev\n";
      rename "$rev.log", "$rev.compile";
      $forced_rev = $rev+1;
    # Proper error
    } else {
      print "Revision '$rev' is bad\n";
      rename "$rev.log", "$rev.bad";
      $bad = $rev;
    }
    $step++;
  }

  # Final status
  print "\n==============================================\n".
        " First bad revision is '$bad'\n".
        " Found in $step steps in a range of $range commits".
        "\n==============================================\n";
}

################################## Checkout, run, test

sub check ($) {
  my ($rev) = @_;
  unlink "$rev.log";
  my $log = "2>&1 >> $rev.log";
  print "Checking out rev '$rev'\n";
  die "Error while checking out '$rev'\n" if system("$checkout $rev $log");
  print "Building rev '$rev'\n";
  return $CompilerError if system("$build $log");
  if ($test) {
    print "Testing rev '$rev'\n";
    return $TestError if system("$test $log");
  }
  return $Good;
}

################################## Helpers

sub validate_script($) {
  my ($command) = @_;
  my ($script) = split /\s+/, $$command;
  return 0 if (! -x $script);
  if ($script !~ /^[\/\.]/) {
    $script = "./$script";
    return 0 if (! -x $script);
    $$command = "./$$command";
  }
  return 1;
}