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 |
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"; |
8019c4d8 |
196 | } |
197 | |
aeb25196 |
198 | my $tasks = _generate_get_set_tasks( |
199 | plan => $bench_plan, |
200 | |
201 | iterations => $dumbbench_settings->{code_subiterations}, |
8019c4d8 |
202 | |
aeb25196 |
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 |
8019c4d8 |
209 | |
aeb25196 |
210 | ); |
396618fc |
211 | |
aeb25196 |
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 }] ); |
396618fc |
215 | |
aeb25196 |
216 | $bench_cycles = 1 if $opts->{verbose}; |
396618fc |
217 | |
aeb25196 |
218 | for (1 .. $bench_cycles) { |
219 | print "Perl $], take $_:\n"; |
220 | _bench_and_cmp($tasks, $dumbbench_settings, $opts->{verbose}); |
221 | print "\n"; |
222 | } |
8019c4d8 |
223 | |
aeb25196 |
224 | exit; |
8019c4d8 |
225 | |
aeb25196 |
226 | sub _generate_get_set_tasks { |
227 | my $args = { ref $_[0] ? %{$_[0]} : @_ }; |
8019c4d8 |
228 | |
8019c4d8 |
229 | |
aeb25196 |
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; |
8019c4d8 |
237 | } |
aeb25196 |
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 | } |
8019c4d8 |
261 | } |
52e85101 |
262 | |
aeb25196 |
263 | my $class_counter = 0; |
264 | no strict 'refs'; |
265 | no warnings 'once'; |
266 | my $tasks = { map { |
52e85101 |
267 | |
aeb25196 |
268 | my ($name, $plan) = ($_, $args->{plan}{$_}); |
8019c4d8 |
269 | |
aeb25196 |
270 | my $class = sprintf 'Bench::Accessor::_%03d', $class_counter; |
8019c4d8 |
271 | |
aeb25196 |
272 | # otherwise the XS-shutoff won't work due to lazy-load |
273 | require Method::Generate::Accessor |
274 | if ( $plan->{provider}||'' ) eq 'Moo'; |
71eea8e1 |
275 | |
aeb25196 |
276 | unshift @{"${class}::ISA"}, $plan->{provider} |
277 | if $plan->{add_isa}; |
8019c4d8 |
278 | |
aeb25196 |
279 | my $init_src = <<EOS; |
280 | package $class; |
281 | use warnings FATAL => 'all'; |
282 | use strict; |
283 | $plan->{install} |
284 | EOS |
8019c4d8 |
285 | |
aeb25196 |
286 | $init_src = "local $_ = $plan->{env}{$_};\n$init_src" |
287 | for (keys %{$plan->{env}||{}}); |
8019c4d8 |
288 | |
aeb25196 |
289 | eval "$init_src; 1" or die "$name initializer failed: $@\n$init_src\n"; |
8019c4d8 |
290 | |
aeb25196 |
291 | $::BENCH_objects[$class_counter] = $plan->{has_constructor} |
292 | ? $class->new |
293 | : bless({}, $class) |
294 | ; |
52e85101 |
295 | |
aeb25196 |
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} ); |
396618fc |
303 | |
aeb25196 |
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"; |
af71d687 |
306 | |
aeb25196 |
307 | $class_counter++; |
396618fc |
308 | |
aeb25196 |
309 | ($name => { |
310 | src => $task_src, |
311 | class => $class, |
312 | provider => $plan->{provider}, |
313 | accessor => $acc_name, |
314 | }); |
315 | |
316 | } keys %{$args->{plan}} }; |
8019c4d8 |
317 | } |
318 | |
8019c4d8 |
319 | |
aeb25196 |
320 | ############################## |
321 | ## Benchmarker Guts |
322 | ##### |
8019c4d8 |
323 | |
aeb25196 |
324 | use Time::HiRes qw/gettimeofday tv_interval/; |
325 | use List::Util 'shuffle'; |
8019c4d8 |
326 | |
aeb25196 |
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(@_) ); |
af71d687 |
335 | } |
8019c4d8 |
336 | |
aeb25196 |
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 | } |
396618fc |
402 | |
aeb25196 |
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; |
8019c4d8 |
414 | } |