Commit | Line | Data |
aeb25196 |
1 | #!/usr/bin/perl |
8019c4d8 |
2 | |
aeb25196 |
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 |
e89e4f1a |
25 | outlier_rejection => 1, |
aeb25196 |
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(), |
e89e4f1a |
34 | code_subiterations => 200, |
aeb25196 |
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 | |
aeb25196 |
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 | |
aeb25196 |
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 | |
aeb25196 |
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 | }, |
e89e4f1a |
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 | # }, |
aeb25196 |
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"; |
8019c4d8 |
199 | } |
200 | |
aeb25196 |
201 | my $tasks = _generate_get_set_tasks( |
202 | plan => $bench_plan, |
203 | |
204 | iterations => $dumbbench_settings->{code_subiterations}, |
8019c4d8 |
205 | |
aeb25196 |
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 |
8019c4d8 |
212 | |
aeb25196 |
213 | ); |
396618fc |
214 | |
aeb25196 |
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 }] ); |
396618fc |
218 | |
aeb25196 |
219 | $bench_cycles = 1 if $opts->{verbose}; |
396618fc |
220 | |
aeb25196 |
221 | for (1 .. $bench_cycles) { |
222 | print "Perl $], take $_:\n"; |
223 | _bench_and_cmp($tasks, $dumbbench_settings, $opts->{verbose}); |
224 | print "\n"; |
225 | } |
8019c4d8 |
226 | |
aeb25196 |
227 | exit; |
8019c4d8 |
228 | |
aeb25196 |
229 | sub _generate_get_set_tasks { |
230 | my $args = { ref $_[0] ? %{$_[0]} : @_ }; |
8019c4d8 |
231 | |
8019c4d8 |
232 | |
aeb25196 |
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; |
8019c4d8 |
240 | } |
aeb25196 |
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 | } |
8019c4d8 |
264 | } |
52e85101 |
265 | |
aeb25196 |
266 | my $class_counter = 0; |
267 | no strict 'refs'; |
268 | no warnings 'once'; |
269 | my $tasks = { map { |
52e85101 |
270 | |
aeb25196 |
271 | my ($name, $plan) = ($_, $args->{plan}{$_}); |
8019c4d8 |
272 | |
aeb25196 |
273 | my $class = sprintf 'Bench::Accessor::_%03d', $class_counter; |
8019c4d8 |
274 | |
aeb25196 |
275 | # otherwise the XS-shutoff won't work due to lazy-load |
276 | require Method::Generate::Accessor |
277 | if ( $plan->{provider}||'' ) eq 'Moo'; |
71eea8e1 |
278 | |
aeb25196 |
279 | unshift @{"${class}::ISA"}, $plan->{provider} |
280 | if $plan->{add_isa}; |
8019c4d8 |
281 | |
aeb25196 |
282 | my $init_src = <<EOS; |
283 | package $class; |
284 | use warnings FATAL => 'all'; |
285 | use strict; |
286 | $plan->{install} |
287 | EOS |
8019c4d8 |
288 | |
aeb25196 |
289 | $init_src = "local $_ = $plan->{env}{$_};\n$init_src" |
290 | for (keys %{$plan->{env}||{}}); |
8019c4d8 |
291 | |
aeb25196 |
292 | eval "$init_src; 1" or die "$name initializer failed: $@\n$init_src\n"; |
8019c4d8 |
293 | |
aeb25196 |
294 | $::BENCH_objects[$class_counter] = $plan->{has_constructor} |
295 | ? $class->new |
296 | : bless({}, $class) |
297 | ; |
52e85101 |
298 | |
aeb25196 |
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} ); |
396618fc |
306 | |
aeb25196 |
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"; |
af71d687 |
309 | |
aeb25196 |
310 | $class_counter++; |
396618fc |
311 | |
aeb25196 |
312 | ($name => { |
313 | src => $task_src, |
314 | class => $class, |
315 | provider => $plan->{provider}, |
316 | accessor => $acc_name, |
317 | }); |
318 | |
319 | } keys %{$args->{plan}} }; |
8019c4d8 |
320 | } |
321 | |
8019c4d8 |
322 | |
aeb25196 |
323 | ############################## |
324 | ## Benchmarker Guts |
325 | ##### |
8019c4d8 |
326 | |
aeb25196 |
327 | use Time::HiRes qw/gettimeofday tv_interval/; |
328 | use List::Util 'shuffle'; |
8019c4d8 |
329 | |
aeb25196 |
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(@_) ); |
af71d687 |
338 | } |
8019c4d8 |
339 | |
aeb25196 |
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 | } |
396618fc |
405 | |
aeb25196 |
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; |
8019c4d8 |
417 | } |