view release on metacpan or  search on metacpan

examples/Benchmark.pm  view on Meta::CPAN

    $n+=0; # force numeric now, so garbage won't creep into the eval
    croak "negative loopcount $n" if $n<0;
    confess usage unless defined $c;
    my($t0, $t1, $td); # before, after, difference

    # find package of caller so we can execute code there
    my($curpack) = caller(0);
    my($i, $pack)= 0;
    while (($pack) = caller(++$i)) {
	last if $pack ne $curpack;
    }

    my ($subcode, $subref);
    if (ref $c eq 'CODE') {
	$subcode = "sub { for (1 .. \$_[0]) { local \$_; package $pack; &\$c; } }";
        $subref  = eval $subcode;
    }
    else {
	$subcode = "sub { for (1 .. \$_[0]) { local \$_; package $pack; $c;} }";
        $subref  = _doeval($subcode);
    }
    croak "runloop unable to compile '$c': $@\ncode: $subcode\n" if $@;
    print STDERR "runloop $n '$subcode'\n" if $Debug;

    if (our $USE_PARALLEL) {
        my $nchild = $Forks::Super::MAX_PROC;
        $nchild = 2 if $nchild < 2;
        $nchild = 20 if $nchild > 20;

#        my @n = map { my $nreps = int($n / $_); $n -= $nreps; $nreps } reverse(1 .. $nchild);
#        print STDERR "\@n = @n\n";
        
        my @td = pmap {
            my $tbase = Benchmark->new(0)->[1];
            my $limit = 1;
            while ( ( $t0 = Benchmark->new(0) )->[1] == $tbase ) {
                for (my $i=0; $i < $limit; $i++) { my $x = $i / 1.5 } # burn user CPU
                $limit *= 1.1;
            }
            $subref->($_);
            $t1 = Benchmark->new($_);
            &timediff($t1, $t0);
        } map {
            $n -= my $nreps = int($n / $_);
            $nreps;
        } reverse(1 .. $nchild);
        $td = shift @td;
        foreach my $tdc (@td) {
            $td->[$_] += $tdc->[$_] for 0 .. $#$tdc;
        }
    } else {
        # Wait for the user timer to tick.  This makes the error range more like
        # -0.01, +0.  If we don't wait, then it's more like -0.01, +0.01.  This
        # may not seem important, but it significantly reduces the chances of
        # getting a too low initial $n in the initial, 'find the minimum' loop
        # in &countit.  This, in turn, can reduce the number of calls to
        # &runloop a lot, and thus reduce additive errors.
        #
        # Note that its possible for the act of reading the system clock to
        # burn lots of system CPU while we burn very little user clock in the
        # busy loop, which can cause the loop to run for a very long wall time.
        # So gradually ramp up the duration of the loop. See RT #122003
        #
        my $tbase = Benchmark->new(0)->[1];
        my $limit = 1;
        while ( ( $t0 = Benchmark->new(0) )->[1] == $tbase ) {
            for (my $i=0; $i < $limit; $i++) { my $x = $i / 1.5 } # burn user CPU
            $limit *= 1.1;
        }
        $subref->($n);
        $t1 = Benchmark->new($n);
        $td = &timediff($t1, $t0);
    }
    timedebug("runloop:",$td);
    $td;
}

$_Usage{timeit} = <<'USAGE';
usage: $result = timeit($count, 'code' );        or
       $result = timeit($count, sub { code } );
USAGE

sub timeit {
    my($n, $code) = @_;
    my($wn, $wc, $wd);

    die usage unless defined $code and
                     (!ref $code or ref $code eq 'CODE');

    printf STDERR "timeit $n $code\n" if $Debug;
    my $cache_key = $n . ( ref( $code ) ? 'c' : 's' );
    if ($Do_Cache && exists $Cache{$cache_key} ) {
	$wn = $Cache{$cache_key};
    } else {
	$wn = &runloop($n, ref( $code ) ? sub { } : '' );
	# Can't let our baseline have any iterations, or they get subtracted
	# out of the result.
	$wn->[5] = 0;
	$Cache{$cache_key} = $wn;
    }

    $wc = &runloop($n, $code);

    $wd = timediff($wc, $wn);
    timedebug("timeit: ",$wc);
    timedebug("      - ",$wn);
    timedebug("      = ",$wd);

    $wd;
}


my $default_for = 3;
my $min_for     = 0.1;


$_Usage{countit} = <<'USAGE';
usage: $result = countit($time, 'code' );        or
       $result = countit($time, sub { code } );
USAGE