The Perl Toolchain Summit needs more sponsors. If your company depends on Perl, please support this very important event.
package PerlBench;

use strict;
use base 'Exporter';
our @EXPORT_OK = qw(timeit timeit_once make_timeit_sub make_timeit_sub_code);

our $VERSION = "0.96";

use PerlBench::Stats qw(calc_stats);
use PerlBench::Utils qw(sec_f);
use Time::HiRes qw(gettimeofday);
use Carp qw(croak);


sub timeit {
    my($code, %opt) = @_;
    my $init = $opt{init};

    # XXX auto determine how long we need to time stuff
    my $enough = $opt{enough} || 1;

    # auto determine $loop_count and $repeat_count
    print STDERR "# Determine loop count - enough is " . sec_f($enough) . "\n"
	if $opt{verbose};
    my($loop_count, $repeat_count) = do {
	my $count = 1;
	my $repeat = $opt{repeat} || 1;
	while (1) {
	    print STDERR "#  $count ==> " if $opt{verbose};
	    my $t = timeit_once($code, $init, $count, $repeat);
	    print STDERR sec_f($t, undef), "\n" if $opt{verbose};
	    last if $t > $enough;
	    if ($t < 0.00001) {
		$count *= 1000;
		next;
	    }
	    elsif ($t < 0.01) {
		$count *= 2;
		next;
	    }
	    $count = int($count * ($enough / $t) * 1.05) + 1;
	}
	($count, $repeat);
    };

    my @experiment;
    push(@experiment, {
        loop_count => $loop_count,
        repeat_count => $repeat_count,
    });
    $loop_count++ if $loop_count % 2;
    push(@experiment, {
        loop_count => $loop_count / 2,
        repeat_count => $repeat_count * 2,
    });

    my $pl = "tt$$.pl";
    open(my $fh, ">", $pl) || die "Can't create $pl: $!";
    print $fh "#!perl\n";
    print $fh "use strict;\n";
    print $fh "require Time::HiRes;\n";
    print $fh "{\n    $init;\n" if $init;
    print $fh "my \@TIMEIT = (\n";
    for my $e (@experiment) {
	print $fh &make_timeit_sub_code($code, undef, $e->{loop_count}, $e->{repeat_count}), ",\n";
    }
    print $fh ");\n";

    print $fh <<'EOT';

my $e = shift || die;
my $trials = shift || die;
my $loop_count = shift || die;
my @t;
my $sum = 0;
for (1.. $trials) {
    print "t$e=", $TIMEIT[$e-1]->(), "\n";
}
print "---\n";
EOT
    print $fh "}\n" if $init;
    close($fh) || die "Can't write $pl: $!";

    print STDERR "# Running tests...\n" if $opt{verbose};
    my $rounds = 4;
    for my $round (1..$rounds) {
	printf STDERR "#  %.0f%%\n", (($round-1)/$rounds)*100 if $opt{verbose} && $round > 1;
	my $e_num = 0;
	for my $e (@experiment) {
	    $e_num++;
	    open($fh, "$^X $pl $e_num 7 $loop_count |") || die "Can't run $pl: $!";
	    while (<$fh>) {
		#print "XXX $_";
		if (/^t(\d+)=(.*)/) {
		    die unless $1 eq $e_num;
		    my $t = $2+0;
		    push(@{$e->{t}}, $t);
		}
	    }
	    close($fh);
	}
    }
    unlink($pl);
    print STDERR "# done\n" if $opt{verbose};

    for my $e (@experiment) {
	my $t = $e->{t} ||return;
	calc_stats($e->{t}, $e);

	my $count = $e->{loop_count} * $e->{repeat_count};
	$e->{count} = $count;
    }

    my $loop_overhead = do {
	my $e1 = $experiment[0];
	my $e2 = $experiment[-1];
	my $t1 = $e1->{med} / $e1->{loop_count};
	my $t2 = $e2->{med} / $e2->{loop_count};
	my $f = $e2->{repeat_count} / $e1->{repeat_count};
	$f * $t1 - $t2;
    };

    for my $e (@experiment) {
	$e->{loop_overhead} = $loop_overhead * $e->{loop_count};
	$e->{loop_overhead_relative} = $e->{loop_overhead} / $e->{med};
    }

    my %res;
    $res{x} = \@experiment;

    # calculate combined stats
    my @t;
    for my $e (@experiment) {
	my $c = $e->{count};
	my $o = $e->{loop_overhead};
	push(@t, map { ($_-$o)/$c } @{$e->{t}});
    }
    calc_stats(\@t, \%res);

    for my $f (qw(count loop_overhead_relative)) {
	# XXX avg
	$res{$f} = $experiment[0]{$f};
    }

    return \%res;
}

sub timeit_once {
    return make_timeit_sub(@_)->();
}

sub make_timeit_sub {
    my $code = make_timeit_sub_code(@_);
    my $sub = eval $code;
    die $@ if $@;
    return $sub;
}

sub make_timeit_sub_code {
    my($code, $init, $loop_count, $repeat_count) = @_;
    $loop_count = int($loop_count);
    die unless $loop_count > 0;
    die if $loop_count + 1 == $loop_count;  # too large
    $repeat_count ||= 1;
    $init = "" unless defined $init;
    return <<EOT1 . "$init;$code" . <<'EOT2' . ($code x $repeat_count) . <<'EOT3';
sub {
    my \$COUNT = shift || $loop_count;
    \$COUNT++;
    package main;
EOT1

    my($BEFORE_S, $BEFORE_US) = Time::HiRes::gettimeofday();
    while (--$COUNT) {
EOT2

    }
    my($AFTER_S, $AFTER_US) = Time::HiRes::gettimeofday();
    return ($AFTER_S - $BEFORE_S) + ($AFTER_US - $BEFORE_US)/1e6;
}
EOT3
}

1;