Commit | Line | Data |
6f8df574 |
1 | use strictures 1; |
2 | |
3 | use Benchmark qw/:hireswallclock cmpthese/; |
4 | use Getopt::Long::Descriptive; |
5 | |
2cd5e970 |
6 | use Config; |
7 | $ENV{PERL5LIB} = join ($Config{path_sep}, @INC); |
8 | |
6f8df574 |
9 | |
10 | my ($opts, $usage); |
11 | BEGIN { |
12 | ($opts, $usage) = describe_options( |
13 | '%c: %o' => |
14 | [ 'help|h' => 'Print usage message and exit' ], |
15 | [ 'classes|c:i' => 'How many classes to create per benchmark cycle (def 10)', { default => 10 } ], |
2cd5e970 |
16 | [ 'accessors|a:i' => 'How many accessors/attributes of each type to create per class (def 10)', { default => 10 } ], |
17 | [ 'subprocess|startup|s' => 'Run the code in a subprocess to benchmark actual time spent on compilation' ], |
18 | [ 'pregenerate|p:i' => 'How many bench-runs to pre-generate for compilation in case --subprocess is not used (def 1000)', { default => 1000} ], |
19 | [ 'run|r' => 'Use each accessor at runtime (get/set/get cycle)' ], |
6f8df574 |
20 | [ 'unique|u' => 'Make accessor names globally unique (instead of just per class)' ], |
21 | [ 'bench|b:s' => 'Which benchmarks to run (all|xs|pp)', { default => 'all', regex => qr/^(?:all|xs|pp)$/ } ], |
22 | { getopt_conf => [qw/gnu_getopt bundling_override no_ignore_case/] }, |
23 | ); |
24 | |
25 | # can not change this runtime, thus in-block |
26 | $ENV{MOUSE_PUREPERL} = 1 if $opts->{bench} eq 'pp'; |
27 | |
28 | my @missing; |
29 | for (qw/ |
30 | Moose |
31 | Moo |
32 | Mouse |
33 | /) { |
34 | eval "require $_" or push @missing, $_; |
35 | } |
36 | |
37 | if (@missing) { |
38 | die sprintf "Missing modules necessary for benchmark:\n\n%s\n\n", |
39 | join ("\n", @missing); |
40 | } |
41 | } |
42 | |
2cd5e970 |
43 | use Method::Generate::Accessor; # need to pre-load for the XS shut-off to work |
6f8df574 |
44 | |
45 | $usage->die if $opts->{help}; |
46 | |
2cd5e970 |
47 | $opts->{pregenerate} = 1 if $opts->{subprocess}; |
48 | |
6f8df574 |
49 | my $counters; |
50 | my $tasks = {}; |
51 | |
2cd5e970 |
52 | my $attrs_to_bench = { |
53 | plain => q|is => 'rw'|, |
54 | lazy_default => q|is => 'rw', lazy => 1, default => sub { {} }|, |
55 | lazy_default_qsub => q|is => 'rw', lazy => 1, default => Sub::Quote::quote_sub q{ {} }|, |
56 | }; |
57 | |
58 | for (keys %$attrs_to_bench) { |
59 | if ($opts->{bench} =~ /all|pp/) { |
60 | { |
61 | local $Method::Generate::Accessor::CAN_HAZ_XS = 0; |
62 | _add_moosey_has (moo => 'Moo', $_); |
63 | } |
6f8df574 |
64 | |
2cd5e970 |
65 | _add_moosey_has (moose => 'Moose', $_); |
66 | _add_moosey_has (mouse => 'Mouse', $_) |
67 | if $ENV{MOUSE_PUREPERL}; |
68 | } |
6f8df574 |
69 | |
2cd5e970 |
70 | if ($opts->{bench} =~ /all|xs/) { |
71 | { |
72 | local $Method::Generate::Accessor::CAN_HAZ_XS = 1; |
73 | _add_moosey_has (moo_XS => 'Moo', $_); |
74 | } |
75 | _add_moosey_has (mouse_XS => 'Mouse', $_) |
76 | unless $ENV{MOUSE_PUREPERL}; |
6f8df574 |
77 | } |
6f8df574 |
78 | } |
79 | |
80 | # run each task once, prime whatever caches there may be |
81 | $_->() for values %$tasks; |
82 | |
83 | # Actual Benchmarking |
84 | for (1, 2) { |
85 | print "Perl $], take $_:\n"; |
2cd5e970 |
86 | |
87 | # if forking must run for certain number of cycles, cputime doesn't work |
18a09449 |
88 | foreach my $type (sort keys %$attrs_to_bench) { |
89 | print "Benchming ${type}:\n"; |
90 | my %these = map { (split ' ', $_)[0] => $tasks->{$_} } |
91 | grep /${type}$/, keys %$tasks; |
92 | cmpthese ( $opts->{subprocess} ? 15 : -1 , \%these ); |
93 | } |
6f8df574 |
94 | print "\n"; |
95 | } |
96 | |
97 | exit 0; # the end |
98 | |
99 | sub _add_moosey_has { |
2cd5e970 |
100 | my ($name, $base, $attr_type) = @_; |
6f8df574 |
101 | |
2cd5e970 |
102 | my @to_eval; |
103 | |
104 | for (1 .. $opts->{pregenerate} ) { |
105 | my $perl = 'use Sub::Quote;'; |
6f8df574 |
106 | |
6f8df574 |
107 | for ( 1.. $opts->{classes} ) { |
2cd5e970 |
108 | my $class = "Bench::${base}_" . ++$counters->{class}; |
6f8df574 |
109 | $perl .= "package $class; use $base;"; |
2cd5e970 |
110 | |
111 | my @attr_names; |
6f8df574 |
112 | for ( 1.. $opts->{accessors} ) { |
2cd5e970 |
113 | my $attr = "attribute_${attr_type}" . ++$counters->{acc}; |
114 | push @attr_names, $attr; |
115 | $perl .= "has $attr => ($attrs_to_bench->{$attr_type});"; |
6f8df574 |
116 | } |
117 | |
2cd5e970 |
118 | $perl .= '__PACKAGE__->meta->make_immutable;' |
c9b16e36 |
119 | if $name !~ /^moo(_XS)?$/; |
2cd5e970 |
120 | |
6f8df574 |
121 | $counters->{accessors} = 0 |
122 | unless $opts->{unique}; |
2cd5e970 |
123 | |
124 | if ($opts->{run}) { |
4ce62c03 |
125 | $perl .= "\$::obj = $class->new;"; |
126 | $perl .= "\$::foo = \$::obj->$_; \$::obj->$_(1); \$::foo = \$::obj->$_;" |
2cd5e970 |
127 | for @attr_names; |
128 | } |
6f8df574 |
129 | } |
130 | |
2cd5e970 |
131 | push @to_eval, $perl; |
6f8df574 |
132 | } |
133 | |
2cd5e970 |
134 | $tasks->{"$name $attr_type"} = $opts->{subprocess} |
135 | ? sub { |
136 | open (my $subproc, '|-', $^X, '-'); |
137 | print $subproc $to_eval[0]; |
138 | close $subproc; |
139 | } |
140 | : sub { |
141 | eval shift @to_eval; |
142 | } |
143 | ; |
6f8df574 |
144 | } |