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   cmpthese ( $opts->{subprocess} ? 15 : -1 , $tasks );
  89   print "\n";
  90 }
  91
  92 exit 0; # the end
  93
  94 sub _add_moosey_has {
  95   my ($name, $base, $attr_type) = @_;
  96
  97   # this works only with Moo, not with Moose, not with Mouse
  98   return if ($attr_type =~ /qsub/ and $name !~ /moo\b/ );
  99
 100   my @to_eval;
 101
 102   for (1 .. $opts->{pregenerate} ) {
 103     my $perl = 'use Sub::Quote;';
 104
 105     for ( 1.. $opts->{classes} ) {
 106       my $class = "Bench::${base}_" . ++$counters->{class};
 107       $perl .= "package $class; use $base;";
 108
 109       my @attr_names;
 110       for ( 1.. $opts->{accessors} ) {
 111         my $attr = "attribute_${attr_type}" . ++$counters->{acc};
 112         push @attr_names, $attr;
 113         $perl .= "has $attr => ($attrs_to_bench->{$attr_type});";
 114       }
 115
 116       $perl .= '__PACKAGE__->meta->make_immutable;'
 117         if $name !~ /moo\b/;
 118
 119       $counters->{accessors} = 0
 120         unless $opts->{unique};
 121
 122       if ($opts->{run}) {
 123         $perl .= 'package main;';
 124         $perl .= "our \$foo = $class->$_; $class->$_(1); our \$foo = $class->$_;"
 125           for @attr_names;
 126       }
 127     }
 128
 129     push @to_eval, $perl;
 130   }
 131
 132   $tasks->{"$name $attr_type"} = $opts->{subprocess}
 133     ? sub {
 134       open (my $subproc, '|-', $^X, '-');
 135       print $subproc $to_eval[0];
 136       close $subproc;
 137     }
 138     : sub {
 139       eval shift @to_eval;
 140     }
 141   ;
 142 }