From: Peter Rabbitson <ribasushi@cpan.org>
Date: Wed, 31 Oct 2012 13:38:54 +0000 (+0100)
Subject: Radically rewrite and tighten benchmarker, add more acc. makers
X-Git-Tag: v0.10008~6
X-Git-Url: http://git.shadowcat.co.uk/gitweb/gitweb.cgi?p=p5sagit%2FClass-Accessor-Grouped.git;a=commitdiff_plain;h=aeb25196a1b624dd52d8342b48afd81f3dc1476b

Radically rewrite and tighten benchmarker, add more acc. makers
---

diff --git a/benchmark/accessors b/benchmark/accessors
index e28eba1..e2d858c 100644
--- a/benchmark/accessors
+++ b/benchmark/accessors
@@ -1,164 +1,414 @@
-BEGIN {
-  my @missing;
-  for (qw/
-    strictures
-    Class::Accessor::Grouped
-    Class::XSAccessor
-    Class::Accessor::Fast
-    Class::Accessor::Fast::XS
-    Class::XSAccessor::Compat
-    Moose
-    Mouse
-    Mousse
-    Moo
-    Dumbbench
-  /) {
-    eval "require $_" or push @missing, $_;
-  }
+#!/usr/bin/perl
 
-  if (@missing) {
-    die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n",
-      join ("\n", @missing);
-  }
+use warnings FATAL => 'all';
+use strict;
+
+use B;
+use Time::HiRes ();
+
+# how many times to rerun everything unless -v is supplied
+my $bench_cycles = 4;
+
+my $dumbbench_settings = {
+  target_rel_precision  => 0.0003,
+
+  # no. of guaranteed initial runs
+  initial_runs          => 1500,
+
+  # target absolute precision (in s)
+  target_abs_precision  => 0,
+
+  # method for calculating uncertainty
+  variability_measure   => 'mad',
+
+  # no. of "sigma"s for the outlier rejection
+  outlier_rejection     => 2,
+
+  # automatically determined at runtime to not run
+  # longer than $max_bench_duration seconds
+  #max_iterations       => xxx
+
+  # our local addition to Dumbbench
+  max_bench_duration    => 20,
+  gettime_clock_id      => Time::HiRes::CLOCK_PROCESS_CPUTIME_ID(),
+  code_subiterations    => 250,
+};
+
+my $acc_name = 'accessor';
+my $q_acc_name = B::perlstring($acc_name);
+
+my $bench_plan = {
+  OTRW => {
+    provider => 'Object::Tiny::RW',
+    install => qq|
+      Object::Tiny::RW->import($q_acc_name);
+    |,
+  },
+
+  CA => {
+    provider => 'Class::Accessor',
+    type => 'mk_accessors'
+  },
+
+  CAG_S => {
+    provider => 'Class::Accessor::Grouped',
+    add_isa => 1,
+    env => {
+      '$Class::Accessor::Grouped::USE_XS' => 0,
+    },
+    install => qq|
+      __PACKAGE__->mk_group_accessors (simple => $q_acc_name);
+    |,
+  },
+
+  CAG_S_XS => {
+    provider => 'Class::Accessor::Grouped',
+    add_isa => 1,
+    env => {
+      '$Class::Accessor::Grouped::USE_XS' => 1,
+    },
+    install => qq|
+      __PACKAGE__->mk_group_accessors (simple => $q_acc_name);
+    |,
+  },
+
+  CAG_INH => {
+    provider => 'Class::Accessor::Grouped',
+    add_isa => 1,
+    install => qq|
+      __PACKAGE__->mk_group_accessors (inherited => $q_acc_name);
+      __PACKAGE__->$acc_name(42);
+    |,
+  },
+
+  CAG_INHP => {
+    provider => 'Class::Accessor::Grouped',
+    install => qq|
+      {
+        package Bench::Accessor::GrandParent;
+        our \@ISA = 'Class::Accessor::Grouped';
+        __PACKAGE__->mk_group_accessors (inherited => $q_acc_name);
+        __PACKAGE__->$acc_name(42);
+
+        package Bench::Accessor::Parent;
+        our \@ISA = 'Bench::Accessor::GrandParent';
+      }
+
+      our \@ISA = 'Bench::Accessor::Parent';
+    |,
+  },
+
+  CAL => {
+    provider => 'Class::Accessor::Lite',
+    install => qq|
+      Class::Accessor::Lite->mk_accessors($q_acc_name);
+    |,
+  },
+
+  CAF => {
+    provider => 'Class::Accessor::Fast',
+    type => 'mk_accessors'
+  },
+
+  CAF_XS => {
+    provider => 'Class::Accessor::Fast::XS',
+    type => 'mk_accessors'
+  },
+
+  CAF_XSAC => {
+    provider => 'Class::XSAccessor::Compat',
+    type => 'mk_accessors'
+  },
+
+  XSA => {
+    provider => 'Class::XSAccessor',
+    install => qq|
+      Class::XSAccessor->import({
+        accessors => [ $q_acc_name ]
+      }),
+    |,
+  },
+
+  HANDMADE => {
+    install => qq|
+      sub $acc_name {
+        no warnings;
+        use strict;
+        \@_ > 1 ? \$_[0]->{$q_acc_name} = \$_[1] : \$_[0]->{$q_acc_name};
+      }
+    |,
+  },
+
+  moOse => {
+    provider => 'Moose',
+    type => 'mooselike',
+  },
+
+  moo_XS => {
+    provider => 'Moo',
+    env => {
+      '$Method::Generate::Accessor::CAN_HAZ_XS' => 1,
+    },
+    type => 'mooselike',
+  },
+
+  moo => {
+    provider => 'Moo',
+    env => {
+      '$Method::Generate::Accessor::CAN_HAZ_XS' => 0,
+    },
+    type => 'mooselike',
+  },
+
+  moUse_XS => {
+    provider => 'Mouse',
+    type => 'mooselike',
+  },
+
+  moUse => {
+    provider => 'Mousse',
+    type => 'mooselike',
+  },
+
+  mo => {
+    provider => 'Mo',
+    type => 'mooselike',
+  },
+};
+
+
+##############################
+## Actual benching
+#####
+
+use Getopt::Long ();
+my $getopt = Getopt::Long::Parser->new(
+  config => [qw/gnu_getopt bundling_override no_ignore_case pass_through/]
+);
+my $opts = {
+  verbose => 0,
+};
+$getopt->getoptions($opts, qw/
+  verbose|v+
+/);
+if (@ARGV) {
+  warn "\nIgnoring unrecognized option(s): @ARGV\n\n";
 }
 
+my $tasks = _generate_get_set_tasks(
+  plan => $bench_plan,
+
+  iterations => $dumbbench_settings->{code_subiterations},
 
-use strictures 1;
-use Benchmark::Dumb ':all';
+  execute => sprintf <<EOS,
+<SCRATCH> = <OBJECT>->$acc_name;
+<OBJECT>->$acc_name ( <ITER> );
+<OBJECT>->$acc_name ( <OBJECT>->$acc_name + <ITER> );
+<OBJECT>->$acc_name ( undef );
+EOS
 
-{
-  package Bench::Accessor::GrandParent;
-  use strictures 1;
+);
 
-  use base 'Class::Accessor::Grouped';
-  __PACKAGE__->mk_group_accessors ('inherited', 'cag_inhp');
-  __PACKAGE__->cag_inhp('initial parent value');
+#delete $tasks->{$_} for grep { $_ ne 'CAG_S_XS' and $_ ne 'XSA' } keys %$tasks;
+#delete $tasks->{$_} for grep { $_ =~ /XS/} keys %$tasks;
+#die _dumper([$tasks, { map { ref($_) => ref($_)->can('accessor') } @::BENCH_objects }] );
 
-  package Bench::Accessor::Parent;
-  use strictures 1;
-  use base 'Bench::Accessor::GrandParent';
+$bench_cycles = 1 if $opts->{verbose};
 
-  package Bench::Accessor;
+for (1 .. $bench_cycles) {
+  print "Perl $], take $_:\n";
+  _bench_and_cmp($tasks, $dumbbench_settings, $opts->{verbose});
+  print "\n";
+}
 
-  use strictures 1;
+exit;
 
-  our @ISA;
+sub _generate_get_set_tasks {
+  my $args = { ref $_[0] ? %{$_[0]} : @_ };
 
-  use base qw/Bench::Accessor::Parent Class::Accessor::Grouped Class::Accessor::Fast/;
-  use Class::XSAccessor { accessors => [ 'xsa' ] };
 
-  {
-    local $Class::Accessor::Grouped::USE_XS = 0;
-    __PACKAGE__->mk_group_accessors ('simple', 'cag');
+  my @missing = grep { ! eval "require $_" } (
+    'Dumbbench', map { $_->{provider} || () } values %{$args->{plan}||{}},
+  );
+  if (@missing) {
+    print STDERR "Missing modules necessary for benchmark:\n\n";
+    print join (' ', (sort @missing), "\n\n");
+    exit 1;
   }
-  {
-    local $Class::Accessor::Grouped::USE_XS = 1;
-    __PACKAGE__->mk_group_accessors ('simple', 'cag_xs');
+
+  # expand shorthand specs
+  for (values %{$args->{plan}} ) {
+    if ($_->{type}) {
+      if ($_->{type} eq 'mooselike') {
+        $_->{has_constructor} = 1;
+        $_->{install} = qq|
+          use $_->{provider};
+          has $acc_name => (is => 'rw');
+          # not all moosey thingies have a finalizer
+          eval { __PACKAGE__->meta->make_immutable };
+        |;
+      }
+      elsif ($_->{type} eq 'mk_accessors') {
+        $_->{add_isa} = 1;
+        $_->{install} = qq|
+          __PACKAGE__->mk_accessors( $q_acc_name );
+        |;
+      }
+      else {
+        die "Unknown accessor maker type $_->{type}\n";
+      }
+    }
   }
 
-  __PACKAGE__->mk_group_accessors ('inherited', 'cag_inh');
-  __PACKAGE__->cag_inh('initial value');
+  my $class_counter = 0;
+  no strict 'refs';
+  no warnings 'once';
+  my $tasks = { map {
 
-  __PACKAGE__->mk_accessors('caf');
+    my ($name, $plan) = ($_, $args->{plan}{$_});
 
-  {
-    require Class::Accessor::Fast::XS;
-    local @ISA = 'Class::Accessor::Fast::XS';
-    __PACKAGE__->mk_accessors ('caf_xs');
-  }
+    my $class = sprintf 'Bench::Accessor::_%03d', $class_counter;
 
-  {
-    require Class::XSAccessor::Compat;
-    local @ISA = 'Class::XSAccessor::Compat';
-    __PACKAGE__->mk_accessors ('caf_xsa');
-  }
+    # otherwise the XS-shutoff won't work due to lazy-load
+    require Method::Generate::Accessor
+      if ( $plan->{provider}||'' ) eq 'Moo';
 
-  sub handmade {
-    no warnings;
-    no strict;
-    @_ > 1 ? $_[0]->{handmade} = $_[1] : $_[0]->{handmade};
-  }
+    unshift @{"${class}::ISA"}, $plan->{provider}
+      if $plan->{add_isa};
 
-}
-my $bench_objs = {
-  base => bless ({}, 'Bench::Accessor')
-};
+    my $init_src = <<EOS;
+package $class;
+use warnings FATAL => 'all';
+use strict;
+$plan->{install}
+EOS
 
-sub _add_moose_task {
-  my ($tasks, $name, $class) = @_;
-  my $meth = lc($name);
-
-  my $gen_class = "Bench::Accessor::$class";
-  eval <<"EOC";
-package $gen_class;
-use $class;
-has $meth => (is => 'rw');
-# some moosey thingies can not do this
-eval { __PACKAGE__->meta->make_immutable };
-EOC
-
-  $bench_objs->{$name} = $gen_class->new;
-  _add_task ($tasks, $name, $meth, $name);
-}
+    $init_src = "local $_ = $plan->{env}{$_};\n$init_src"
+      for (keys %{$plan->{env}||{}});
 
-sub _add_task {
-  my ($tasks, $name, $meth, $slot) = @_;
+    eval "$init_src; 1" or die "$name initializer failed: $@\n$init_src\n";
 
-  # we precompile the desired amount of loops so that the loop itself
-  # does not get in the way with some sort of optimization or whatnot
+    $::BENCH_objects[$class_counter] = $plan->{has_constructor}
+      ? $class->new
+      : bless({}, $class)
+    ;
 
-  use Devel::Dwarn;
-#  Dwarn { $meth => $bench_objs->{$slot}->can($meth) };
+    my $task_src = join "\n", map {
+      my $exec = $args->{execute};
+      $exec =~ s/<OBJECT>/\$::BENCH_objects[$class_counter]/g;
+      $exec =~ s/<SCRATCH>/\$::BENCH_scratch/g;
+      $exec =~ s/<ITER>/$_/g;
+      $exec;
+    } ( 1 .. $args->{iterations} );
 
-  my $perl;
-  for (1 .. 100) {
-    $perl .= "
-      \$::init_val = \$bench_objs->{$slot}->$meth;
-      \$bench_objs->{$slot}->$meth($_);
-      \$bench_objs->{$slot}->$meth(\$bench_objs->{$slot}->$meth + $_);
-      \$bench_objs->{$slot}->$meth(undef);
-    ";
-  }
+    $task_src = "sub { no warnings; use strict; $task_src }";
+    eval $task_src or die "Unable to compile bench-task for $plan->{provider}: $@\n";
 
-  $tasks->{$name} = eval "sub { use warnings; use strict; $perl } " or die $@;
+    $class_counter++;
 
-  # prime things up (have the task run a couple times)
-  $tasks->{$name}->() for (1..5);
+    ($name => {
+      src => $task_src,
+      class => $class,
+      provider => $plan->{provider},
+      accessor => $acc_name,
+    });
+
+  } keys %{$args->{plan}} };
 }
 
-my $tasks = {
-#  'direct' => sub {
-#    $bench_objs->{base}{direct} = 1;
-#    $bench_objs->{base}{direct} = $bench_objs->{base}{direct} + 1;
-#  }
-};
 
-for (qw/CAG CAG_XS CAG_INH CAG_INHP CAF CAF_XS CAF_XSA XSA HANDMADE/) {
-  _add_task ($tasks, $_, lc($_), 'base');
-}
+##############################
+## Benchmarker Guts
+#####
 
-my $moose_based = {
-  moOse => 'Moose',
-  moo_XS => 'Moo',
-  moUse_XS => 'Mouse',
-  moUse => 'Mousse',
-};
-for (keys %$moose_based) {
-  _add_moose_task ($tasks, $_, $moose_based->{$_})
-}
+use Time::HiRes qw/gettimeofday tv_interval/;
+use List::Util 'shuffle';
 
-{
-  no warnings 'once';
-  local $Method::Generate::Accessor::CAN_HAZ_XS = 0;
-  _add_moose_task ($tasks, moo => 'Moo');
+sub _bench_and_cmp {
+  #my ($tasks, $db_opts, $verbose) = @_;
+
+  require Dumbbench;
+  require Benchmark::Dumb;
+
+  local $| = 1;
+  Benchmark::Dumb::cmpthese ( _bench_tasks(@_) );
 }
 
-#delete $tasks->{$_} for grep { $_ !~ /CAG/ } keys %$tasks;
+sub _bench_tasks {
+  my ($tasks, $db_opts, $verbose) = @_;
+
+  my $clr_ln = "\r\x1b[J";
+  my $time_override = eval "sub { Time::HiRes::clock_gettime($db_opts->{gettime_clock_id}) }"
+    or die "Unable to compile Time::HiRes::time override: $@\n";
+
+  my $prerun = 100;
+  my ($results, $t0, $itertime, $maxiter);
+
+  my @tnames = shuffle keys %$tasks;
+  for my $i (0..$#tnames) {
+    my $n = $tnames[$i];
+
+    my $c = eval $tasks->{$tnames[$i]}{src};
+
+    # fire several times to clear out deferred symtable muckery
+    # and whatnot
+    $c->() for (1..$prerun);
+
+    # crude timing of an iteration
+    $t0 = [gettimeofday()];
+    $c->() for (1..$prerun);
+    $itertime = tv_interval($t0) / $prerun;
+
+    $maxiter = int( $db_opts->{max_bench_duration} / $itertime );
+    die "Max iterations $maxiter too low for max runtime $db_opts->{max_bench_duration} ($itertime iter/s)"
+      if $maxiter < 50;
+
+    printf "%s%s: (task %d of %d, pretimed at %.03f/s)%s",
+      $verbose ? "\n" : $clr_ln,
+      $n,
+      $i+1,
+      $#tnames+1,
+      1 / $itertime,
+      $verbose ? "\n" : ' ... ',
+    ;
+
+    print( "$n: deparsed accessor: " . _dumper( $tasks->{$n}{class}->can($tasks->{$n}{accessor}) ) )
+      if ($verbose||0) == 2;
+
+    my $bench = Dumbbench->new(
+      %{ $db_opts || {} },
+      max_iterations => $maxiter,
+    );
+    $bench->add_instances(
+      Dumbbench::Instance::PerlSub->new(name => $n, code => $c),
+    );
+
+    {
+      no warnings 'redefine';
+      local *Time::HiRes::time = $time_override;
+      $t0 = [gettimeofday()];
+      $bench->run;
+      if ( $verbose ) {
+        printf "%s: Elapsed %.03f wall seconds\n", $n, tv_interval($t0);
+        $bench->report;
+      }
+    }
+
+
+    $results->{$n} = Benchmark::Dumb->_new(
+      instance => ($bench->instances)[0]
+    );
+  }
 
-for (1 .. 3) {
-  print "Perl $], take $_:\n";
-#  DB::enable_profile();
-  cmpthese ( '50.0001', $tasks );
-#  DB::disable_profile();
-  print "\n";
+  print ($verbose ? "\n" : $clr_ln);
+
+  $results;
+}
+
+my $d;
+sub _dumper {
+  ($d ||= do {
+    require Data::Dumper;
+    Data::Dumper->new([])->Indent(1)->Deparse(1)->Terse(1)->Sortkeys(1)->Quotekeys(0);
+  })->Values([@_])->Dump;
 }