benchmark/accessors

   1 #!/usr/bin/perl
   2
   3 use warnings FATAL => 'all';
   4 use strict;
   5
   6 use B;
   7 use Time::HiRes ();
   8
   9 # how many times to rerun everything unless -v is supplied
  10 my $bench_cycles = 4;
  11
  12 my $dumbbench_settings = {
  13   target_rel_precision  => 0.0003,
  14
  15   # no. of guaranteed initial runs
  16   initial_runs          => 1500,
  17
  18   # target absolute precision (in s)
  19   target_abs_precision  => 0,
  20
  21   # method for calculating uncertainty
  22   variability_measure   => 'mad',
  23
  24   # no. of "sigma"s for the outlier rejection
  25   outlier_rejection     => 1,
  26
  27   # automatically determined at runtime to not run
  28   # longer than $max_bench_duration seconds
  29   #max_iterations       => xxx
  30
  31   # our local addition to Dumbbench
  32   max_bench_duration    => 20,
  33   gettime_clock_id      => Time::HiRes::CLOCK_PROCESS_CPUTIME_ID(),
  34   code_subiterations    => 200,
  35 };
  36
  37 my $acc_name = 'accessor';
  38 my $q_acc_name = B::perlstring($acc_name);
  39
  40 my $bench_plan = {
  41   OTRW => {
  42     provider => 'Object::Tiny::RW',
  43     install => qq|
  44       Object::Tiny::RW->import($q_acc_name);
  45     |,
  46   },
  47
  48   CA => {
  49     provider => 'Class::Accessor',
  50     type => 'mk_accessors'
  51   },
  52
  53   CAG_S => {
  54     provider => 'Class::Accessor::Grouped',
  55     add_isa => 1,
  56     env => {
  57       '$Class::Accessor::Grouped::USE_XS' => 0,
  58     },
  59     install => qq|
  60       __PACKAGE__->mk_group_accessors (simple => $q_acc_name);
  61     |,
  62   },
  63
  64   CAG_INH => {
  65     provider => 'Class::Accessor::Grouped',
  66     add_isa => 1,
  67     install => qq|
  68       __PACKAGE__->mk_group_accessors (inherited => $q_acc_name);
  69       __PACKAGE__->$acc_name(42);
  70     |,
  71   },
  72
  73   CAG_INHP => {
  74     provider => 'Class::Accessor::Grouped',
  75     install => qq|
  76       {
  77         package Bench::Accessor::GrandParent;
  78         our \@ISA = 'Class::Accessor::Grouped';
  79         __PACKAGE__->mk_group_accessors (inherited => $q_acc_name);
  80         __PACKAGE__->$acc_name(42);
  81
  82         package Bench::Accessor::Parent;
  83         our \@ISA = 'Bench::Accessor::GrandParent';
  84       }
  85
  86       our \@ISA = 'Bench::Accessor::Parent';
  87     |,
  88   },
  89
  90   CAL => {
  91     provider => 'Class::Accessor::Lite',
  92     install => qq|
  93       Class::Accessor::Lite->mk_accessors($q_acc_name);
  94     |,
  95   },
  96
  97   CAF => {
  98     provider => 'Class::Accessor::Fast',
  99     type => 'mk_accessors'
 100   },
 101
 102   CAF_XS => {
 103     provider => 'Class::Accessor::Fast::XS',
 104     type => 'mk_accessors'
 105   },
 106
 107   HANDMADE => {
 108     install => qq|
 109       sub $acc_name {
 110         no warnings;
 111         use strict;
 112         \@_ > 1 ? \$_[0]->{$q_acc_name} = \$_[1] : \$_[0]->{$q_acc_name};
 113       }
 114     |,
 115   },
 116
 117   moOse => {
 118     provider => 'Moose',
 119     type => 'mooselike',
 120   },
 121
 122   moo => {
 123     provider => 'Moo',
 124     env => {
 125       '$Method::Generate::Accessor::CAN_HAZ_XS' => 0,
 126     },
 127     type => 'mooselike',
 128   },
 129
 130   moUse_XS => {
 131     provider => 'Mouse',
 132     type => 'mooselike',
 133   },
 134
 135   moUse => {
 136     provider => 'Mousse',
 137     type => 'mooselike',
 138   },
 139
 140   mo => {
 141     provider => 'Mo',
 142     type => 'mooselike',
 143   },
 144
 145   XSA => {
 146     provider => 'Class::XSAccessor',
 147     install => qq|
 148       Class::XSAccessor->import({
 149         accessors => [ $q_acc_name ]
 150       }),
 151     |,
 152   },
 153
 154 #  # all of the things below should be identical
 155 #  # to XSA, as they are essentially the same code
 156 #  # yet I can't get the nu,bers to agree <sratchhead>
 157 #  CAF_XSAC => {
 158 #    provider => 'Class::XSAccessor::Compat',
 159 #    type => 'mk_accessors'
 160 #  },
 161 #
 162 #  CAG_S_XS => {
 163 #    provider => 'Class::Accessor::Grouped',
 164 #    add_isa => 1,
 165 #    env => {
 166 #      '$Class::Accessor::Grouped::USE_XS' => 1,
 167 #    },
 168 #    install => qq|
 169 #      __PACKAGE__->mk_group_accessors (simple => $q_acc_name);
 170 #    |,
 171 #  },
 172 #
 173 #  moo_XS => {
 174 #    provider => 'Moo',
 175 #    env => {
 176 #      '$Method::Generate::Accessor::CAN_HAZ_XS' => 1,
 177 #    },
 178 #    type => 'mooselike',
 179 #  },
 180 };
 181
 182
 183 ##############################
 184 ## Actual benching
 185 #####
 186
 187 use Getopt::Long ();
 188 my $getopt = Getopt::Long::Parser->new(
 189   config => [qw/gnu_getopt bundling_override no_ignore_case pass_through/]
 190 );
 191 my $opts = {
 192   verbose => 0,
 193 };
 194 $getopt->getoptions($opts, qw/
 195   verbose|v+
 196 /);
 197 if (@ARGV) {
 198   warn "\nIgnoring unrecognized option(s): @ARGV\n\n";
 199 }
 200
 201 my $tasks = _generate_get_set_tasks(
 202   plan => $bench_plan,
 203
 204   iterations => $dumbbench_settings->{code_subiterations},
 205
 206   execute => sprintf <<EOS,
 207 <SCRATCH> = <OBJECT>->$acc_name;
 208 <OBJECT>->$acc_name ( <ITER> );
 209 <OBJECT>->$acc_name ( <OBJECT>->$acc_name + <ITER> );
 210 <OBJECT>->$acc_name ( undef );
 211 EOS
 212
 213 );
 214
 215 #delete $tasks->{$_} for grep { $_ ne 'CAG_S_XS' and $_ ne 'XSA' } keys %$tasks;
 216 #delete $tasks->{$_} for grep { $_ =~ /XS/} keys %$tasks;
 217 #die _dumper([$tasks, { map { ref($_) => ref($_)->can('accessor') } @::BENCH_objects }] );
 218
 219 $bench_cycles = 1 if $opts->{verbose};
 220
 221 for (1 .. $bench_cycles) {
 222   print "Perl $], take $_:\n";
 223   _bench_and_cmp($tasks, $dumbbench_settings, $opts->{verbose});
 224   print "\n";
 225 }
 226
 227 exit;
 228
 229 sub _generate_get_set_tasks {
 230   my $args = { ref $_[0] ? %{$_[0]} : @_ };
 231
 232
 233   my @missing = grep { ! eval "require $_" } (
 234     'Dumbbench', map { $_->{provider} || () } values %{$args->{plan}||{}},
 235   );
 236   if (@missing) {
 237     print STDERR "Missing modules necessary for benchmark:\n\n";
 238     print join (' ', (sort @missing), "\n\n");
 239     exit 1;
 240   }
 241
 242   # expand shorthand specs
 243   for (values %{$args->{plan}} ) {
 244     if ($_->{type}) {
 245       if ($_->{type} eq 'mooselike') {
 246         $_->{has_constructor} = 1;
 247         $_->{install} = qq|
 248           use $_->{provider};
 249           has $acc_name => (is => 'rw');
 250           # not all moosey thingies have a finalizer
 251           eval { __PACKAGE__->meta->make_immutable };
 252         |;
 253       }
 254       elsif ($_->{type} eq 'mk_accessors') {
 255         $_->{add_isa} = 1;
 256         $_->{install} = qq|
 257           __PACKAGE__->mk_accessors( $q_acc_name );
 258         |;
 259       }
 260       else {
 261         die "Unknown accessor maker type $_->{type}\n";
 262       }
 263     }
 264   }
 265
 266   my $class_counter = 0;
 267   no strict 'refs';
 268   no warnings 'once';
 269   my $tasks = { map {
 270
 271     my ($name, $plan) = ($_, $args->{plan}{$_});
 272
 273     my $class = sprintf 'Bench::Accessor::_%03d', $class_counter;
 274
 275     # otherwise the XS-shutoff won't work due to lazy-load
 276     require Method::Generate::Accessor
 277       if ( $plan->{provider}||'' ) eq 'Moo';
 278
 279     unshift @{"${class}::ISA"}, $plan->{provider}
 280       if $plan->{add_isa};
 281
 282     my $init_src = <<EOS;
 283 package $class;
 284 use warnings FATAL => 'all';
 285 use strict;
 286 $plan->{install}
 287 EOS
 288
 289     $init_src = "local $_ = $plan->{env}{$_};\n$init_src"
 290       for (keys %{$plan->{env}||{}});
 291
 292     eval "$init_src; 1" or die "$name initializer failed: $@\n$init_src\n";
 293
 294     $::BENCH_objects[$class_counter] = $plan->{has_constructor}
 295       ? $class->new
 296       : bless({}, $class)
 297     ;
 298
 299     my $task_src = join "\n", map {
 300       my $exec = $args->{execute};
 301       $exec =~ s/<OBJECT>/\$::BENCH_objects[$class_counter]/g;
 302       $exec =~ s/<SCRATCH>/\$::BENCH_scratch/g;
 303       $exec =~ s/<ITER>/$_/g;
 304       $exec;
 305     } ( 1 .. $args->{iterations} );
 306
 307     $task_src = "sub { no warnings; use strict; $task_src }";
 308     eval $task_src or die "Unable to compile bench-task for $plan->{provider}: $@\n";
 309
 310     $class_counter++;
 311
 312     ($name => {
 313       src => $task_src,
 314       class => $class,
 315       provider => $plan->{provider},
 316       accessor => $acc_name,
 317     });
 318
 319   } keys %{$args->{plan}} };
 320 }
 321
 322
 323 ##############################
 324 ## Benchmarker Guts
 325 #####
 326
 327 use Time::HiRes qw/gettimeofday tv_interval/;
 328 use List::Util 'shuffle';
 329
 330 sub _bench_and_cmp {
 331   #my ($tasks, $db_opts, $verbose) = @_;
 332
 333   require Dumbbench;
 334   require Benchmark::Dumb;
 335
 336   local $| = 1;
 337   Benchmark::Dumb::cmpthese ( _bench_tasks(@_) );
 338 }
 339
 340 sub _bench_tasks {
 341   my ($tasks, $db_opts, $verbose) = @_;
 342
 343   my $clr_ln = "\r\x1b[J";
 344   my $time_override = eval "sub { Time::HiRes::clock_gettime($db_opts->{gettime_clock_id}) }"
 345     or die "Unable to compile Time::HiRes::time override: $@\n";
 346
 347   my $prerun = 100;
 348   my ($results, $t0, $itertime, $maxiter);
 349
 350   my @tnames = shuffle keys %$tasks;
 351   for my $i (0..$#tnames) {
 352     my $n = $tnames[$i];
 353
 354     my $c = eval $tasks->{$tnames[$i]}{src};
 355
 356     # fire several times to clear out deferred symtable muckery
 357     # and whatnot
 358     $c->() for (1..$prerun);
 359
 360     # crude timing of an iteration
 361     $t0 = [gettimeofday()];
 362     $c->() for (1..$prerun);
 363     $itertime = tv_interval($t0) / $prerun;
 364
 365     $maxiter = int( $db_opts->{max_bench_duration} / $itertime );
 366     die "Max iterations $maxiter too low for max runtime $db_opts->{max_bench_duration} ($itertime iter/s)"
 367       if $maxiter < 50;
 368
 369     printf "%s%s: (task %d of %d, pretimed at %.03f/s)%s",
 370       $verbose ? "\n" : $clr_ln,
 371       $n,
 372       $i+1,
 373       $#tnames+1,
 374       1 / $itertime,
 375       $verbose ? "\n" : ' ... ',
 376     ;
 377
 378     print( "$n: deparsed accessor: " . _dumper( $tasks->{$n}{class}->can($tasks->{$n}{accessor}) ) )
 379       if ($verbose||0) == 2;
 380
 381     my $bench = Dumbbench->new(
 382       %{ $db_opts || {} },
 383       max_iterations => $maxiter,
 384     );
 385     $bench->add_instances(
 386       Dumbbench::Instance::PerlSub->new(name => $n, code => $c),
 387     );
 388
 389     {
 390       no warnings 'redefine';
 391       local *Time::HiRes::time = $time_override;
 392       $t0 = [gettimeofday()];
 393       $bench->run;
 394       if ( $verbose ) {
 395         printf "%s: Elapsed %.03f wall seconds\n", $n, tv_interval($t0);
 396         $bench->report;
 397       }
 398     }
 399
 400
 401     $results->{$n} = Benchmark::Dumb->_new(
 402       instance => ($bench->instances)[0]
 403     );
 404   }
 405
 406   print ($verbose ? "\n" : $clr_ln);
 407
 408   $results;
 409 }
 410
 411 my $d;
 412 sub _dumper {
 413   ($d ||= do {
 414     require Data::Dumper;
 415     Data::Dumper->new([])->Indent(1)->Deparse(1)->Terse(1)->Sortkeys(1)->Quotekeys(0);
 416   })->Values([@_])->Dump;
 417 }