Release commit for 1.000008
[gitmo/Moo.git] / benchmark / class_factory
1 use strictures 1;
2
3 use Benchmark qw/:hireswallclock cmpthese/;
4 use Getopt::Long::Descriptive;
5
6 use Config;
7 $ENV{PERL5LIB} = join ($Config{path_sep}, @INC);
8
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 } ],
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)' ],
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
43 use Method::Generate::Accessor; # need to pre-load for the XS shut-off to work
44
45 $usage->die if $opts->{help};
46
47 $opts->{pregenerate} = 1 if $opts->{subprocess};
48
49 my $counters;
50 my $tasks = {};
51
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     }
64
65     _add_moosey_has (moose => 'Moose', $_);
66     _add_moosey_has (mouse => 'Mouse', $_)
67       if $ENV{MOUSE_PUREPERL};
68   }
69
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};
77   }
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";
86
87   # if forking must run for certain number of cycles, cputime doesn't work
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   }
94   print "\n";
95 }
96
97 exit 0; # the end
98
99 sub _add_moosey_has {
100   my ($name, $base, $attr_type) = @_;
101
102   my @to_eval;
103
104   for (1 .. $opts->{pregenerate} ) {
105     my $perl = 'use Sub::Quote;';
106
107     for ( 1.. $opts->{classes} ) {
108       my $class = "Bench::${base}_" . ++$counters->{class};
109       $perl .= "package $class; use $base;";
110
111       my @attr_names;
112       for ( 1.. $opts->{accessors} ) {
113         my $attr = "attribute_${attr_type}" . ++$counters->{acc};
114         push @attr_names, $attr;
115         $perl .= "has $attr => ($attrs_to_bench->{$attr_type});";
116       }
117
118       $perl .= '__PACKAGE__->meta->make_immutable;'
119         if $name !~ /^moo(_XS)?$/;
120
121       $counters->{accessors} = 0
122         unless $opts->{unique};
123
124       if ($opts->{run}) {
125         $perl .= "\$::obj = $class->new;";
126         $perl .= "\$::foo = \$::obj->$_; \$::obj->$_(1); \$::foo = \$::obj->$_;"
127           for @attr_names;
128       }
129     }
130
131     push @to_eval, $perl;
132   }
133
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   ;
144 }