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