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 }