3 use warnings FATAL => 'all';
9 # how many times to rerun everything unless -v is supplied
12 my $dumbbench_settings = {
13 target_rel_precision => 0.0003,
15 # no. of guaranteed initial runs
18 # target absolute precision (in s)
19 target_abs_precision => 0,
21 # method for calculating uncertainty
22 variability_measure => 'mad',
24 # no. of "sigma"s for the outlier rejection
25 outlier_rejection => 1,
27 # automatically determined at runtime to not run
28 # longer than $max_bench_duration seconds
29 #max_iterations => xxx
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,
37 my $acc_name = 'accessor';
38 my $q_acc_name = B::perlstring($acc_name);
42 provider => 'Object::Tiny::RW',
44 Object::Tiny::RW->import($q_acc_name);
49 provider => 'Class::Accessor',
50 type => 'mk_accessors'
54 provider => 'Class::Accessor::Grouped',
57 '$Class::Accessor::Grouped::USE_XS' => 0,
60 __PACKAGE__->mk_group_accessors (simple => $q_acc_name);
65 provider => 'Class::Accessor::Grouped',
68 __PACKAGE__->mk_group_accessors (inherited => $q_acc_name);
69 __PACKAGE__->$acc_name(42);
74 provider => 'Class::Accessor::Grouped',
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);
82 package Bench::Accessor::Parent;
83 our \@ISA = 'Bench::Accessor::GrandParent';
86 our \@ISA = 'Bench::Accessor::Parent';
91 provider => 'Class::Accessor::Lite',
93 Class::Accessor::Lite->mk_accessors($q_acc_name);
98 provider => 'Class::Accessor::Fast',
99 type => 'mk_accessors'
103 provider => 'Class::Accessor::Fast::XS',
104 type => 'mk_accessors'
112 \@_ > 1 ? \$_[0]->{$q_acc_name} = \$_[1] : \$_[0]->{$q_acc_name};
125 '$Method::Generate::Accessor::CAN_HAZ_XS' => 0,
136 provider => 'Mousse',
146 provider => 'Class::XSAccessor',
148 Class::XSAccessor->import({
149 accessors => [ $q_acc_name ]
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>
158 # provider => 'Class::XSAccessor::Compat',
159 # type => 'mk_accessors'
163 # provider => 'Class::Accessor::Grouped',
166 # '$Class::Accessor::Grouped::USE_XS' => 1,
169 # __PACKAGE__->mk_group_accessors (simple => $q_acc_name);
176 # '$Method::Generate::Accessor::CAN_HAZ_XS' => 1,
178 # type => 'mooselike',
183 ##############################
188 my $getopt = Getopt::Long::Parser->new(
189 config => [qw/gnu_getopt bundling_override no_ignore_case pass_through/]
194 $getopt->getoptions($opts, qw/
198 warn "\nIgnoring unrecognized option(s): @ARGV\n\n";
201 my $tasks = _generate_get_set_tasks(
204 iterations => $dumbbench_settings->{code_subiterations},
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 );
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 }] );
219 $bench_cycles = 1 if $opts->{verbose};
221 for (1 .. $bench_cycles) {
222 print "Perl $], take $_:\n";
223 _bench_and_cmp($tasks, $dumbbench_settings, $opts->{verbose});
229 sub _generate_get_set_tasks {
230 my $args = { ref $_[0] ? %{$_[0]} : @_ };
233 my @missing = grep { ! eval "require $_" } (
234 'Dumbbench', map { $_->{provider} || () } values %{$args->{plan}||{}},
237 print STDERR "Missing modules necessary for benchmark:\n\n";
238 print join (' ', (sort @missing), "\n\n");
242 # expand shorthand specs
243 for (values %{$args->{plan}} ) {
245 if ($_->{type} eq 'mooselike') {
246 $_->{has_constructor} = 1;
249 has $acc_name => (is => 'rw');
250 # not all moosey thingies have a finalizer
251 eval { __PACKAGE__->meta->make_immutable };
254 elsif ($_->{type} eq 'mk_accessors') {
257 __PACKAGE__->mk_accessors( $q_acc_name );
261 die "Unknown accessor maker type $_->{type}\n";
266 my $class_counter = 0;
271 my ($name, $plan) = ($_, $args->{plan}{$_});
273 my $class = sprintf 'Bench::Accessor::_%03d', $class_counter;
275 # otherwise the XS-shutoff won't work due to lazy-load
276 require Method::Generate::Accessor
277 if ( $plan->{provider}||'' ) eq 'Moo';
279 unshift @{"${class}::ISA"}, $plan->{provider}
282 my $init_src = <<EOS;
284 use warnings FATAL => 'all';
289 $init_src = "local $_ = $plan->{env}{$_};\n$init_src"
290 for (keys %{$plan->{env}||{}});
292 eval "$init_src; 1" or die "$name initializer failed: $@\n$init_src\n";
294 $::BENCH_objects[$class_counter] = $plan->{has_constructor}
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;
305 } ( 1 .. $args->{iterations} );
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";
315 provider => $plan->{provider},
316 accessor => $acc_name,
319 } keys %{$args->{plan}} };
323 ##############################
327 use Time::HiRes qw/gettimeofday tv_interval/;
328 use List::Util 'shuffle';
331 #my ($tasks, $db_opts, $verbose) = @_;
334 require Benchmark::Dumb;
337 Benchmark::Dumb::cmpthese ( _bench_tasks(@_) );
341 my ($tasks, $db_opts, $verbose) = @_;
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";
348 my ($results, $t0, $itertime, $maxiter);
350 my @tnames = shuffle keys %$tasks;
351 for my $i (0..$#tnames) {
354 my $c = eval $tasks->{$tnames[$i]}{src};
356 # fire several times to clear out deferred symtable muckery
358 $c->() for (1..$prerun);
360 # crude timing of an iteration
361 $t0 = [gettimeofday()];
362 $c->() for (1..$prerun);
363 $itertime = tv_interval($t0) / $prerun;
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)"
369 printf "%s%s: (task %d of %d, pretimed at %.03f/s)%s",
370 $verbose ? "\n" : $clr_ln,
375 $verbose ? "\n" : ' ... ',
378 print( "$n: deparsed accessor: " . _dumper( $tasks->{$n}{class}->can($tasks->{$n}{accessor}) ) )
379 if ($verbose||0) == 2;
381 my $bench = Dumbbench->new(
383 max_iterations => $maxiter,
385 $bench->add_instances(
386 Dumbbench::Instance::PerlSub->new(name => $n, code => $c),
390 no warnings 'redefine';
391 local *Time::HiRes::time = $time_override;
392 $t0 = [gettimeofday()];
395 printf "%s: Elapsed %.03f wall seconds\n", $n, tv_interval($t0);
401 $results->{$n} = Benchmark::Dumb->_new(
402 instance => ($bench->instances)[0]
406 print ($verbose ? "\n" : $clr_ln);
414 require Data::Dumper;
415 Data::Dumper->new([])->Indent(1)->Deparse(1)->Terse(1)->Sortkeys(1)->Quotekeys(0);
416 })->Values([@_])->Dump;